A scheme (in scheme) that compilers to a stack machine

stack-compiler.rkt

#lang racket

(define current-idx 0)
(define (get-fresh-param!)
  (let [(idx current-idx)]
    (set! current-idx (+ idx 1))
    (string->symbol
     (string-append "?" (number->string idx)))))

(define (compile exp)
  (define (replace exp target desired)

    (match exp
      [`(λ (,param) ,body)
       (if (eq? param target)
           exp
           `(λ (,param) ,(replace body target desired)))]
      [(? list? ls)
       (for/list ([item ls])
         (replace item target desired))]
      [(? symbol? s)
       (if (eq? s target)
           desired
           s)]
      [else exp]))
  
  (match exp
    [`(λ (,n) ,body)
     (let [(param (get-fresh-param!))] 
       (list (append (list param '->)
                     (compile (replace body n param)))))]
    [`(,f ,x)
     (append (compile x)
             (compile f)
             (list 'CALL))]
    [(? number? n) (list n)]
    [(? symbol? s) (list s)]))

(define (transform exp)
  (define (curry params body)
    (if (empty? params)
        body
        `(λ (,(car params)) ,(curry (cdr params) body))))

  (define (curry-apply f args)
    (if (null? args)
        f
        (curry-apply (list f (car args)) (cdr args))))
  
  (match exp
    [`(λ ,params ,body)
     (curry params (transform body))]
    [`(if ,a ,b ,c)
     `((((if ,(transform a))
         (λ (_) ,(transform b)))
        (λ (_) ,(transform c)))
       ok)]
    [(list f args ..1)
     (curry-apply (transform f) (map transform args))]
    [else exp]))

(define stdlib
  (list (list '+ (λ (a) (λ (b) (+ a b))))
        (list '- (λ (a) (λ (b) (- a b))))
        (list '* (λ (a) (λ (b) (* a b))))
        (list '/ (λ (a) (λ (b) (/ a b))))
        (list '= (λ (a) (λ (b) (= a b))))
        (list 'null? null?)
        (list 'eq? eq?)
        (list 'equal? equal?)
        (list 'if (λ (cond) (λ (csq) (λ (alt) (if cond csq alt)))))
        (list 'cons (λ (a) (λ (b) (cons a b))))
        (list 'car (λ (a) (λ (b) (car a b))))
        (list 'cdr (λ (a) (λ (b) (cdr a b))))))

; Since everything is curried, (1 *) evaluates to a
; racket procedure :( so I consider `procedure?` to
; also identify functions in the "standard library"
;
; I don't like that these are sprinkled about
(define (stdlib? sym)
  (or (procedure? sym)
      (assoc sym stdlib)))
(define (stdlib->f sym)
  (cond [(symbol? sym) (cadr (assoc sym stdlib))]
        [(procedure? sym) sym]
        [else
         (error "UNKNOWN STDLIB --" sym)]))

(define (exec ls st [debug #f])
  (define (replace ls target desired)
    (for/list ([item ls])
      (cond [(list? item)
             (if (not (eq? (car item) target))
                 (cons (car item)
                       (replace (cdr item) target desired))
                 item)]
            [(eq? item target) desired]
            [else item])))

  (begin
    (if debug
        (begin
          (displayln ls)
          (displayln st)
          (displayln "-----"))
        'noop)

    (if (null? ls)
        st
        (match (car ls)
          ['CALL
           (match st
             [(list proc arg rest ...)
              (cond
                [(stdlib? proc)
                 (exec (cdr ls)
                       (cons ((stdlib->f proc) arg)
                             rest)
                       debug)]
                [(list? proc)
                 (let* [(param (car proc))
                        (replaced-body
                         (replace (cddr proc) param arg))
                        ; Currently lambdas need to exec on an empty
                        ; stack. This seems not ideal?
                        (new-stack '())]
                   (exec (cdr ls)
                         (append (exec replaced-body new-stack debug)
                                 rest)
                         debug))]
                [else
                 (error "exec CALL EXPECTED PROC --" proc)])]
             [else (error "exec STACK UNDERFLOW -- CALL")])]
          ; Numbers, lambdas, and symbols evaluate to themselves
          [(? number? n)
           (exec (cdr ls) (cons n st) debug)]
          [(? list? body)
           (exec (cdr ls) (cons body st) debug)]
          [(? symbol? s)
           (exec (cdr ls) (cons s st) debug)]
          [else (error "exec UNKNOWN INSTRUCTION --" (car ls))]))))

(define sq-sum
  '((λ (a b) (+ (* a a) (* b b))) 4 5))

(define fizzbuzz
  '((λ (n) (if (= n 3) (+ n 1) (/ n 0))) 3))

(transform fizzbuzz)
(compile (transform fizzbuzz))
(exec (compile (transform fizzbuzz)) '())