metacircular-2.rkt

#lang racket

;; Analyze takes an expression as its only argument, and returns a procedure
;; that, when called with an environment as its only argument, returns a
;; result equivalent to evaluating the original expression in the provided
;; environment.

(define (eval exp env)
  ((analyze exp) env))

(define (analyze exp)
  (cond ((evself? exp) (lambda (env) exp))
        ((symbol? exp) (lambda (env) (lookup exp env)))
        ((quoted? exp) (azquot exp))
        ((begin? exp) (azseq (exps exp)))
        ((and? exp) (azand (exps exp)))
        ((or? exp) (azor (exps exp)))
        ((if? exp) (analyze (if->cond exp)))
        ((cond? exp) (azcond (clauses exp)))
        ((lambda? exp) (azlambda exp))
        ((let? exp) (analyze (let->combination exp)))
        ((let*? exp) (analyze (let*->nested-lets exp)))
        ((letrec? exp) (analyze (letrec->let-simscope exp)))
        ((define? exp) (azdefn exp))
        ((assign? exp) (azset exp))
        (else (azapply exp))
        ))

(define (azapply exp)
  (let ((fproc (analyze (proc exp)))
        (aprocs (map analyze (args exp))))
    (lambda (env)
      (exapply (fproc env)
               (map (lambda (aproc) (aproc env))
                    aprocs)))))

(define (exapply proc args)
  (cond ((primop? proc)
         (apply (primop proc) args))
        ((closure? proc)
         ((proc-body proc)
          (bind (proc-params proc)
                args
                (proc-env proc))))
        (else
         (error "Unknown procedure type -- EXAPPLY" proc))))

(define (azquot exp)
  (let ((qval (quote-text exp)))
    (lambda (env) qval)))

(define (azseq exps)
  (define (sequentially proc1 proc2)
    (lambda (env) (proc1 env) (proc2 env)))
  (define (iter first-proc rest-procs)
    (if (null? rest-procs)
        first-proc
        (iter (sequentially first-proc (car rest-procs))
              (cdr rest-procs))))
  (let ((procs (map analyze exps)))
    (if (null? procs)
        (error "Empty sequence -- ANALYZE" exps)
        (iter (car procs) (cdr procs)))))

(define (azand exps)
  (define (test-one proc)
    (lambda (env)
      (let ((val (proc env)))
        (if (true? val) val false))))
  (define (test-two proc1 proc2)
    (lambda (env)
      (let ((val (proc1 env)))
        (if (not (true? val))
            false
            (proc2 env)))))
  (define (iter first-proc rest-procs)
    (if (null? rest-procs)
        (test-one first-proc)
        (iter (test-two first-proc (car rest-procs))
              (cdr rest-procs))))
  (let ((procs (map analyze exps)))
    (if (null? procs)
        (lambda (env) true)
        (iter (car procs) (cdr procs)))))

(define (azor exps)
  (define (test-one proc)
    (lambda (env)
      (let ((val (proc env)))
        (if (true? val) val false))))
  (define (test-two proc1 proc2)
    (lambda (env)
      (let ((val (proc1 env)))
        (if (true? val)
            val
            (proc2 env)))))
  (define (iter first-proc rest-procs)
    (if (null? rest-procs)
        (test-one first-proc)
        (iter (test-two first-proc (car rest-procs))
              (cdr rest-procs))))
  (let ((procs (map analyze exps)))
    (if (null? procs)
        (lambda (env) false)
        (iter (car procs) (cdr procs)))))

(define (azcond clauses)
  (let
    ((resproc
      (cond
        ((null? clauses) (lambda (env) 'undefined))
        ((eq? (caar clauses) 'else)
         (let ((cproc (analyze (cadar clauses))))
           (lambda (env)
             (cproc env))))
        (else
         (let ((pproc (analyze (caar clauses)))
               (cproc (analyze (cadar clauses)))
               (aproc (azcond (cdr clauses))))
           (lambda (env)
             (cond ((true? (pproc env)) (cproc env))
                   (else (aproc env)))))))))
      (lambda (env)
        (resproc env))))

(define (azlambda exp)
  (let ((vars (lambda-params exp))
        (bproc (azseq (scan-out-defines (lambda-body exp)))))
    (lambda (env) (mkclosure vars bproc env))))

(define (azdefn exp)
  (let ((defnvar (var exp))
        (defnproc (analyze (val exp))))
    (lambda (env)
      (defnvar! defnvar (defnproc env) env))))

(define (azset exp)
  (let ((setvar (var exp))
        (setproc (analyze (val exp))))
    (lambda (env)
      (setvar! setvar (setproc env) env))))

;;; syntax

(define (evself? exp)
  (or (number? exp) (string? exp)))

; (quote <exp>)
(define (quoted? exp) (tagged-list? exp 'quote))
(define (quote-text exp) (cadr exp))

; (begin <exp_1> ... <exp_n>)
(define (begin? exp) (tagged-list? exp 'begin))
(define (exps exp) (cdr exp))

; (and <exp_1> ... <exp_n>)
; (or <exp_1> ... <exp_n>

(define (and? exp) (tagged-list? exp 'and))
(define (or? exp) (tagged-list? exp 'or))

; (if <pred> <consequent> <alternative>)
(define (if? exp) (tagged-list? exp 'if))
(define (if->cond exp)
  (list 'cond
        (list (predicate exp) (consequent exp))
        (list 'else (alternative exp))))
(define (predicate exp) (cadr exp))
(define (consequent exp) (caddr exp))
(define (alternative exp) (cadddr exp))

; (cond ((<pred_1> <exp_1>) ... (<pred_n> <exp_n>) [(else <alternative>)]))
(define (cond? exp) (tagged-list? exp 'cond))
(define (clauses exp) (cdr exp))

; (lambda <params...> <body...>)
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (mklambda params body)
  (cons 'lambda (cons params body)))
(define (lambda-params exp) (cadr exp))
(define (lambda-body exp) (cddr exp))

; (let ((<var_1> <val_1>) ... (<var_n> <val_n>)) <body...>)
(define (let? exp) (tagged-list? exp 'let))
(define (let*? exp) (tagged-list? exp 'let*))
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (let->combination exp)
  (cons (mklambda (let-vars exp) (let-body exp))
        (let-vals exp)))
(define (let*->nested-lets exp)
  (define (iter bindings)
    (cond ((null? bindings) (error "Bad let* syntax" exp))
          ((null? (cdr bindings)) (cons 'let
                                        (cons (list (car bindings))
                                              (let-body exp))))
          (else (list 'let
                      (list (car bindings))
                      (iter (cdr bindings))))))
  (iter (let-bindings exp)))
(define (letrec->let-simscope exp)
  (let* ((vars (let-vars exp))
         (vals (let-vals exp))
         (decs (map (lambda (v) (list v ''*unassigned*)) vars))
         (sets (map (lambda (var val) (list 'set! var val)) vars vals)))
    (cons 'let (cons decs (append sets (let-body exp))))))
(define (let-vars exp) (map car (let-bindings exp)))
(define (let-vals exp) (map cadr (let-bindings exp)))
(define (let-bindings exp) (cadr exp))
(define (let-body exp) (cddr exp))

; (define <variable> <value>)
; (define (<procname> <params...>) <body...>)
; (set! <variable> <value>)
(define (define? exp) (tagged-list? exp 'define))
(define (vardef? exp) (symbol? (cadr exp)))
(define (procdef? exp) (list? (cadr exp)))
(define (assign? exp) (tagged-list? exp 'set!))
(define (var exp)
  (cond ((vardef? exp) (cadr exp))
        ((procdef? exp) (caadr exp))
        (else (error "Bad define syntax" exp))))
(define (val exp)
  (cond ((vardef? exp) (caddr exp))
        ((procdef? exp) (mklambda (cdadr exp) (cddr exp)))
        (else (error "Bad define syntax" exp))))

; application -> (<proc> <args...>)
(define (proc exp) (car exp))
(define (args exp) (cdr exp))

(define (primop? proc) (tagged-list? proc 'primitive))
(define (primop proc) (cadr proc))

(define (closure? proc) (tagged-list? proc 'closure))
(define (mkclosure params body env)
  (list 'closure params body env))
(define (proc-params proc) (cadr proc))
(define (proc-body proc) (caddr proc))
(define (proc-env proc) (cadddr proc))

(define (scan-out-defines body)
  (let ((defines (filter define? body))
        (rest (filter (negate define?) body)))
    (if (null? defines)
        body
        (let* ((vars (map var defines))
               (vals (map val defines))
               (decs (map (lambda (v) (list v ''*unassigned*)) vars))
               (sets (map (lambda (var val) (list 'set! var val)) vars vals)))
          (list (cons 'let (cons decs (append sets rest))))))))

(define (tagged-list? exp tag)
  (and (pair? exp) (eq? (car exp) tag)))

; this may seem superfluous, but we would need such a routine if implementing
; Scheme directly in C, for example...
(define (true? x)
  (not (eq? x false)))

;;; Environments

(require compatibility/mlist) ; thanks, assignment

; An environment is a mutable list of frames, where a frame is a mutable
; list of mutable { var . value } pairs.

(define (lookup var env)
  (cond ((null? env) (error "LOOKUP -- Unbound variable" var))
        (else (let ((binding (massoc var (mcar env))))
                (cond ((mpair? binding)
                       (if (eq? (mcdr binding) '*unassigned*)
                           (error "LOOKUP -- Cannot use a variable's value before assignment" var)
                           (mcdr binding)))
                      (else (lookup var (mcdr env))))))))

(define (bind vars vals env)
  (mcons (mmap mcons (list->mlist vars) (list->mlist vals)) env))

(define (defnvar! var val env)
  (if (null? env)
      (error "DEFINE -- Can't mutate the empty environment")
      (let ((binding (massoc var (mcar env)))) ; check current frame only
        (if binding
            (set-mcdr! binding val)
            (set-mcar! env (mcons (mcons var val) (mcar env))))))
  'ok)

(define (setvar! var val env)
  (if (null? env)
      (error "SET! -- Cannot set variable before its definition" var)
      (let ((binding (massoc var (mcar env))))
        (if binding
            (set-mcdr! binding val)
            (setvar! var val (mcdr env)))))
  'ok)

;;; Setup

(define (setup-environment)
  (mlist (mlist ; the 'base' frame
          (mcons '+          (list 'primitive +))
          (mcons '-          (list 'primitive -))
          (mcons '*          (list 'primitive *))
          (mcons '/          (list 'primitive /))
          (mcons '=          (list 'primitive =))
          (mcons 'zero?      (list 'primitive zero?))
          (mcons 'cons       (list 'primitive cons))
          (mcons 'car        (list 'primitive car))
          (mcons 'cdr        (list 'primitive cdr))
          (mcons 'null?      (list 'primitive null?))
          (mcons 'list       (list 'primitive list))
          (mcons 'eq?        (list 'primitive eq?))
          (mcons 'displayln  (list 'primitive displayln))
          ; additional bindings
          (mcons 'true true)
          (mcons 'false false)
         )))

;;; Driver Loop

(define (repl)
  (define the-global-environment (setup-environment))
  (define (loop)
    (displayln "\n;;; M-Eval input:")
    (let ((output (eval (read) the-global-environment)))
      (displayln "\n;;; M-Eval value:")
      (displayln output)
      (loop)))
  (loop))

;;; Tests

(require test-engine/racket-tests)

(check-expect (eval '3 (setup-environment)) 3)
(check-error  (eval 'x (setup-environment)) "LOOKUP -- Unbound variable 'x")
(check-expect (eval 'x (bind '(x) '(3) (setup-environment))) 3)
(check-expect (eval '(* 5 5) (setup-environment)) 25)
(check-expect (eval '(quote ()) (setup-environment)) '())
(check-expect (eval '(quote (1 2 3)) (setup-environment)) '(1 2 3))
(check-expect (eval '(quote x) (setup-environment)) 'x)
(check-expect (eval ''(1 2) (setup-environment)) '(1 2))
(check-expect (eval '(cond ((zero? 0) 1) (else 2)) (setup-environment)) 1)
(check-expect (eval '(cond ((zero? 1) 1) (else 2)) (setup-environment)) 2)
(check-expect (eval '(((lambda (x)
                         (lambda (y)
                           (+ x y)))
                       3)
                      4)
                    (setup-environment))
              7)
(check-expect (eval '(((lambda (f) (f f))
                       (lambda (mkfact)
                         (lambda (n)
                           (cond ((zero? n) 1)
                                 (else (* n ((mkfact mkfact) (- n 1))))))))
                      6)
                    (setup-environment))
              720)
(check-expect (eval '(((lambda (f) (f f))
                       (lambda (mkexpt)
                         (lambda (x n)
                           (cond ((zero? n) 1)
                                 (else (* x ((mkexpt mkexpt) x (- n 1))))))))
                      3 4)
                    (setup-environment))
              81)
(check-expect (eval '(begin (+ 1 2) (+ 3 4)) (setup-environment)) 7)
(check-expect (eval '((lambda () (+ 1 2) (+ 3 4))) (setup-environment)) 7)
(check-expect (eval '(if (zero? 1) true false) (setup-environment)) false)
(check-expect (eval '(((lambda (x) (x x))
                       (lambda (mkmap)
                         (lambda (proc seq)
                           (if (null? seq)
                               '()
                               (cons (proc (car seq))
                                     ((mkmap mkmap) proc (cdr seq)))))))
                      (lambda (x) (* x 2))
                      '(1 2 3))
                    (setup-environment))
              '(2 4 6))
(check-expect (eval '(let () 42) (setup-environment)) 42)
(check-expect (eval '(let ((x 3) (y 4)) (+ x y)) (setup-environment)) 7)
(check-expect (eval '(let ((x 3) (y 4)) (+ x y)) (setup-environment))
              (eval '(((lambda (x)
                         (lambda (y)
                           (+ x y)))
                       3)
                      4)
                    (setup-environment)))
(check-expect (eval '(begin (define x 4) x) (setup-environment)) 4)
(check-expect (eval '(begin (define x 4) (define x 3) x) (setup-environment)) 3)
(check-expect (eval '(begin (define x 4)
                            (define y ((lambda () (define x 3) x)))
                            (cons x (cons y '())))
                    (setup-environment))
              '(4 3))
(check-expect (eval '(begin (define x 3) (set! x 1) x) (setup-environment)) 1)
(check-expect (eval '(and 1 2 3) (setup-environment)) 3)
(check-expect (eval '(or 1 2 3) (setup-environment)) 1)
(check-expect (eval '(and true 1 "asdf") (setup-environment)) "asdf")
(check-expect (eval '(begin (define x 2)
                            (cons (and false 1 (define x 3))
                                  (cons x '())))
                    (setup-environment))
              '(#f 2))
(check-expect (eval '(begin (define x 2)
                            (cons (or true false (define x 3))
                                  (cons x '())))
                    (setup-environment))
              '(#t 2))
(check-expect (eval '(and) (setup-environment)) true)
(check-expect (eval '(or) (setup-environment)) false)
(check-expect (eval '(let* ((x 1) (y (+ x 1))) (+ x y)) (setup-environment)) 3)
(check-expect (eval '(let* ((x 1) (x (+ x 1))) (+ x x)) (setup-environment)) 4)
(check-expect (eval '(begin (define x 10)
                            (list x (let ((x (* x 2))) (+ x 1))))
                    (setup-environment))
              '(10 21))
(check-expect (eval '(let* ((x 3)
                            (y (+ x 2))
                            (z (+ x y 5)))
                       (* x z))
                    (setup-environment))
              39)
(check-expect (eval '(begin
                       (define (map f xs)
                         (if (null? xs)
                             '()
                             (cons (f (car xs)) (map f (cdr xs)))))
                       (map (lambda (x) (* x x)) '(1 2 3 4)))
                    (setup-environment))
              '(1 4 9 16))
(check-expect (eval '(begin
                       (define (say-hello) "hello, world!")
                       (say-hello))
                    (setup-environment))
              "hello, world!")
(check-expect (let-body '(let ((x 5) (y 6)) (define z 7) (+ x y z)))
              '((define z 7) (+ x y z)))
(check-expect (let*->nested-lets '(let* ((x 5)
                                         (y (+ x 1)))
                                    (define z 7)
                                    (+ x y z)))
              '(let ((x 5))
                 (let ((y (+ x 1)))
                   (define z 7)
                   (+ x y z))))
(check-expect (eval '(let ((x 7)) (define y -5) (+ x y)) (setup-environment)) 2)
(check-expect (scan-out-defines (lambda-body '(lambda (x y)
                                                (define u (* x x))
                                                (define v (* y y))
                                                (set! badvar '?)
                                                (/ u v))))
              '((let ((u '*unassigned*)
                      (v '*unassigned*))
                 (set! u (* x x))
                 (set! v (* y y))
                 (set! badvar '?)
                 (/ u v))))
(check-expect (var '(define (f x)
                      (define b (+ a x))
                      (define a 5)
                      (+ a b)))
              'f)
(check-expect (val '(define (f x)
                      (define b (+ a x))
                      (define a 5)
                      (+ a b)))
              '(lambda (x)
                 (define b (+ a x))
                 (define a 5)
                 (+ a b)))
(check-error (eval '(let ((a 1))
                      (define (f x)
                        (define b (+ a x))
                        (define a 5)
                        (+ a b))
                      (f 10))
                   (setup-environment))
             "LOOKUP -- Cannot use a variable's value before assignment 'a")
(check-expect (eval '(let* ((x (list "Burroughs"))
                            (y (cons "Rice" x))
                            (z (cons "Edgar" y)))
                       (list x y z))
                    (setup-environment))
              '(("Burroughs")
                ("Rice" "Burroughs")
                ("Edgar" "Rice" "Burroughs")))
(check-expect (eval '(let* ((name (list "Burroughs"))
                            (name (cons "Rice" name))
                            (name (cons "Edgar" name)))
                       name)
                    (setup-environment))
              '("Edgar" "Rice" "Burroughs"))
(check-error (eval '(let ((tick (lambda (n)
                                  (if (zero? n)
                                      'done
                                      (tick (- n 1))))))
                      (tick 10))
                   (setup-environment))
             "LOOKUP -- Unbound variable 'tick")
(check-expect (eval '(letrec ((tick (lambda (n)
                                      (if (zero? n)
                                          'done
                                          (tick (- n 1))))))
                       (tick 10))
                    (setup-environment))
              'done)

;;; Debug Sandbox -- Temporary Defines

;;; *AUTOGENERATED*

(require racket/trace)