macros-as-staging2.rkt

#lang racket

; Interpreter for MetaScheme, the core staged language. 

(struct lit [v] #:transparent)
(struct lam [xs e] #:transparent)
(struct ref [x] #:transparent)
(struct app [e1 e2] #:transparent)
(struct lif [c t e] #:transparent)
(struct quot [e] #:transparent)
(struct unquot [e] #:transparent)

(struct rep [e] #:transparent)
(struct clo [xs e env] #:transparent)

(struct prim [proc] #:transparent)

(struct bind [phase val])

(define gensym
  (let ([ctr 0])
    (λ (sym)
      (define init (symbol->string sym))
      (define base init #;(car (string-split init "-")))
      (set! ctr (+ ctr 1))
      (string->symbol (string-append base "-" (number->string ctr))))))

(define (eval exp env)
  (match exp
    [(lit v)
     v]
    [(ref x)
     (match-define (bind (or 0 'all) b-v)
       (hash-ref env x (lambda () (error 'eval "unbound reference ~a" x))))
     b-v]
    [(lam x e)
     (clo x e env)]
    [(app e1 e2)
     (lapply (eval e1 env)
             (eval e2 env))]
    [(lif c t e)
     (if (eval c env)
         (eval t env)
         (eval e env))]
    [(quot e)
     (rep (stage e env 1))]
    ))

(define (lapply f v)
  (match f
    [(clo x b c-env)
     (eval b (hash-set c-env x (bind 0 v)))]
    [(prim proc)
     (proc v)]))

(define (stage exp env ph)
  (match exp
    [(lit v)
     (lit v)]
    [(ref x)
     (match-define (bind b-ph b-v) (hash-ref env x))
     (cond
       [(equal? 'all b-ph)
        (ref x)]
       [(= ph b-ph)
        (ref b-v)]
       [else
        (error 'stage "variable not in phase: ~a" x)])]
    [(lam x e)
     (define g (gensym x))
     (lam g (stage e (hash-set env x (bind ph g)) ph))]
    [(app e1 e2)
     (app (stage e1 env ph)
          (stage e2 env ph))]
    [(lif c t e)
     (lif (stage c env ph) (stage t env ph) (stage e env ph))]
    [(quot e)
     (quot (stage e env (+ ph 1)))]
    [(unquot e)
     (let loop ([e^ (unquot e)]
                [ph ph])
       (cond
         [(= ph 0)
          (rep-e (eval e^ env))]
         [(unquot? e^)
          (loop (unquot-e e^) (- ph 1))]
         [else
          (unquot (stage e env (- ph 1)))]))]))

(define (make-prim n f)
  (let rec ([n n]
            [args '()])
    (if (= n 0)
        (apply f (reverse args))
        (prim (lambda (x)
                (rec (- n 1) (cons x args)))))))

(define (select top-sexp path)
  (let loop ([sexp top-sexp]
             [path path])
    (if (null? path)
        sexp
        (if (< (car path) (length sexp))
            (loop (list-ref sexp (car path)) (cdr path))
            (error 'parse "bad syntax: ~a" top-sexp)))))

(define prim-info
  (list
   (cons 'run (make-prim 1 (lambda (v) (eval (rep-e v) prim-env))))
   (cons 'lift (make-prim 1 (lambda (v) (rep (lit v)))))
   (cons 'error (make-prim 3 error))
   (cons 'car (make-prim 1 car))
   (cons 'cdr (make-prim 1 cdr))
   (cons 'cadr (make-prim 1 cadr))
   (cons '- (make-prim 2 -))
   (cons '* (make-prim 2 *))
   (cons '+ (make-prim 2 +))
   (cons '/ (make-prim 2 /))
   (cons 'not (make-prim 1 not))
   (cons 'null? (make-prim 1 null?))
   (cons 'list? (make-prim 1 list?))
   (cons 'box (make-prim 1 box))
   (cons 'unbox (make-prim 1 unbox))
   (cons 'set-box! (make-prim 2 set-box!))
   (cons 'pair? (make-prim 1 pair?))
   (cons 'symbol? (make-prim 1 symbol?))
   (cons 'number? (make-prim 1 number?))
   (cons 'select (make-prim 2 select))
   (cons 'procedure? (make-prim 1 procedure?))
   (cons 'equal? (make-prim 2 equal?))
   (cons 'hash-set (make-prim 3 hash-set))
   (cons 'hash-ref (make-prim 2 hash-ref))
   (cons 'hash-has-key? (make-prim 2 hash-has-key?))
   (cons 'debug (make-prim 1 (lambda (v) (displayln v) v)))
   ))

(define prim-env
  (make-immutable-hash
   (map (λ (p) (cons (car p) (bind 'all (cdr p))))
        prim-info)))


; Bootstrap parser. Only necessary for parsing the implementation of the real,
; embedded parser. Not extensible with macros, so no environment and doesn't check
; binding.
(define (parse exp)
  (match exp
    [(or (? number?) (? string?) #t #f)
     (lit exp)]
    [`(,'quote ,e)
     (lit e)]
    [(? symbol?)
     (ref exp)]
    [`(lambda (,x) ,e)
     (lam x (parse e))]
    [`(if ,c ,t ,e)
     (lif (parse c) (parse t) (parse e))]
    [`(,'quasiquote ,e)
     (quot (parse e))]
    [`(,'unquote ,e)
     (unquot (parse e))]
    [`(,e1 ,e2)
     (app (parse e1) (parse e2))]

    ; Sugar to make the bootstrap easier
    [`(let ([,x ,e]) ,b)
     (app (lam x (parse b)) (parse e))]
    [`(cond . ,(list cs ...))
     (let loop ([cs cs])
       (match cs
         [(list `[else ,e])
          (parse e)]
         [(list-rest `[,c, e] rest)
          (lif (parse c)
               (parse e)
               (loop rest))]))]

    
    ))

; Tests for the bootstrap language: parser + core evaluator
(define (bev e) (eval (parse e) prim-env))
(module+ test
  (require rackunit)

  (check-equal? (bev '(((lambda (x) (lambda (y) x)) 4) 5))
                4)

  ; Run
  (check-equal? (bev '(run `5))
                5)

  ; Primitives
  (check-equal? (bev '(if #t (car '(a b)) 'b))
                'a)
  
  ; Hygiene of MetaScheme quotations
  (check-equal? (bev '(((run `(lambda (x) ,((lambda (y) `(lambda (x) ,y)) `x)))
                        'good)
                       'bad))
                'good)

  ; Bootstrap sugar
  (check-equal? (bev '(let ([x 5]) x))
                5)

  ; Lifting data. I don't know if this is safe to try to apply
  ; to closures; so far I'm using it for s-expressions and staged code
  (check-equal? (bev '(let ([x 5]) (run (lift x))))
                5)
  )

(define prim-parser-env
  (make-immutable-hash
   (map (λ (p) (cons (car p) (rep (ref (car p)))))
        prim-info)))


#|



[`(,'quasiquote ,e)
 (quot (parse e))]
[`(,'unquote ,e)
 (unquot (parse e))]

|#

(define parser-stx
  '(lambda (parse)
     (lambda (stx)
       (lambda (env)
         (let ([bad-syntax (lambda (stx) (((error 'parse) "bad syntax: ~a") stx))])
           (let ([handle-app (lambda (stx)
                               (if (pair? (cdr stx))
                                   ; application
                                   `(,((parse (car stx)) env)
                                     ,((parse (cadr stx)) env))
                                   (bad-syntax stx)))])
             (cond
               [(number? stx)
                (lift stx)]
               [((equal? stx) #t)
                (lift stx)]
               [((equal? stx) #f)
                (lift stx)]
               [(symbol? stx)
                ((hash-ref env) stx)]
               [(pair? stx)
                (if (symbol? (car stx))
                    (let ([sym (car stx)])
                      (cond
                        [((equal? 'quote) sym)
                         (lift ((select stx) '(1)))]
                        [((equal? 'lambda) sym)
                         `(lambda (v)
                            ,((parse ((select stx) '(2)))
                              (((hash-set env) ((select stx) '(1 0))) `v)))]
                        [((equal? 'if) sym)
                         `(if ,((parse ((select stx) '(1))) env)
                              ,((parse ((select stx) '(2))) env)
                              ,((parse ((select stx) '(3))) env))]
                        [((equal? 'quasiquote) sym)
                         ``,,((parse ((select stx) '(1))) env)]
                        [((equal? 'unquote) sym)
                         ((parse ((select stx) '(1))) env)]
                        [else
                         (if ((hash-has-key? env) sym)
                             (let ([stager ((hash-ref env) sym)])
                               (if (procedure? stager)
                                   ((stager stx) env)
                                   (handle-app stx)))
                             (handle-app stx))]))
                    (handle-app stx))]
               [else (bad-syntax stx)])))))))

; Tie the knot for the bootstrap parser, externally to the language. We'll later
; implement letrec inside the language via the real parser.
(define parser-clo
  (let ([b (box #f)])
    (let ([fixed (make-prim 2 (lambda (stx env)
                                (lapply (lapply (unbox b) stx) env)))])
      (set-box! b (lapply (bev parser-stx) fixed))
      (unbox b))))

(define (ev stx)
  (eval (rep-e (lapply (lapply parser-clo stx) prim-parser-env))
        prim-env))

(ev '(((lambda (x) (lambda (y) (if x x y))) 5) 6))

(ev '(lambda (x) ``(lambda (y) ,,x)))
;(lapply (bev '(lambda (x) `(lambda (y) x))) 6)