(primitive-load (string-append (dirname (current-filename)) "/metacircular.scm"))

(define examples (quote ((factorial ((define (factorial n) (if (= n 0) 1 (* n (factorial (- n 1))))) (factorial 6)) 720) (lexical ((define x 10) (define add-x (lambda (y) (+ x y))) ((lambda (x) (add-x 2)) 100)) 12) (closure ((define (make-adder x) (lambda (y) (+ x y))) (define add-three (make-adder 3)) (add-three 4)) 7) (lazy-if ((if #t 7 missing)) 7) (truth ((if 0 1 2)) 1) (mapping ((map (lambda (x) (* x x)) (quote (1 2 3 4)))) (1 4 9 16)) (application ((apply + (quote (1 2 3)))) 6) (named-let ((let loop ((n 5) (total 0)) (if (= n 0) total (loop (- n 1) (+ total n))))) 15) (let-star ((let* ((x 3) (y (+ x 4))) (* x y))) 21) (short-circuit ((list (and #f missing) (or 9 missing))) (#f 9)) (conditional ((cond ((= 1 2) missing) ((= 2 2) 8) (else 0))) 8))))

(define errors (quote ((missing (missing) mce-unbound) (arity (((lambda (x) x) 1 2)) mce-arity) (call ((1 2)) mce-not-procedure) (syntax ((if #t 1)) mce-syntax) (parameters ((lambda (x x) x)) mce-syntax))))

(define source-definitions (quote ((define (initial-environment) (let ((bindings (list (cons (quote +) +) (cons (quote -) -) (cons (quote *) *) (cons (quote =) =) (cons (quote <) <) (cons (quote cons) cons) (cons (quote car) car) (cons (quote cdr) cdr) (cons (quote null?) null?) (cons (quote list) list) (cons (quote cadr) cadr) (cons (quote caddr) caddr) (cons (quote cddr) cddr) (cons (quote caar) caar) (cons (quote length) length) (cons (quote >=) >=) (cons (quote number?) number?) (cons (quote boolean?) boolean?) (cons (quote string?) string?) (cons (quote symbol?) symbol?) (cons (quote pair?) pair?) (cons (quote list?) list?) (cons (quote not) not) (cons (quote eq?) eq?) (cons (quote equal?) equal?) (cons (quote memq) memq) (cons (quote vector) vector) (cons (quote vector?) vector?) (cons (quote vector-ref) vector-ref) (cons (quote vector-set!) vector-set!) (cons (quote assq) assq) (cons (quote set-cdr!) set-cdr!) (cons (quote throw) throw) (cons (quote map) (quote map)) (cons (quote apply) (quote apply))))) (extend-environment (map car bindings) (map (lambda (binding) (vector (quote primitive) (cdr binding))) bindings) (quote ())))) (define (extend-environment names values outer) (unless (= (length names) (length values)) (throw (quote mce-arity) names values)) (cons (vector (map cons names values)) outer)) (define (lookup name environment) (if (null? environment) (throw (quote mce-unbound) name) (let ((binding (assq name (vector-ref (car environment) 0)))) (if binding (cdr binding) (lookup name (cdr environment)))))) (define (define-value! name value environment) (let* ((frame (car environment)) (binding (assq name (vector-ref frame 0)))) (if binding (set-cdr! binding value) (vector-set! frame 0 (cons (cons name value) (vector-ref frame 0)))))) (define (apply-value procedure arguments) (cond ((and (vector? procedure) (eq? (vector-ref procedure 0) (quote primitive))) (let ((implementation (vector-ref procedure 1))) (cond ((eq? implementation (quote map)) (map-values (car arguments) (cdr arguments))) ((eq? implementation (quote apply)) (unless (= (length arguments) 2) (throw (quote mce-arity) (quote apply) arguments)) (apply-value (car arguments) (cadr arguments))) (else (apply implementation arguments))))) ((and (vector? procedure) (eq? (vector-ref procedure 0) (quote closure))) (evaluate-sequence (vector-ref procedure 2) (extend-environment (vector-ref procedure 1) arguments (vector-ref procedure 3)))) (else (throw (quote mce-not-procedure) procedure)))) (define (map-values procedure lists) (unless (and (pair? lists) (all-lists? lists)) (throw (quote mce-arity) (quote map) lists)) (if (null? (car lists)) (if (all-empty? lists) (quote ()) (throw (quote mce-arity) (quote map) lists)) (begin (when (any-empty? lists) (throw (quote mce-arity) (quote map) lists)) (let ((value (apply-value procedure (map car lists)))) (cons value (map-values procedure (map cdr lists))))))) (define (all-lists? xs) (or (null? xs) (and (list? (car xs)) (all-lists? (cdr xs))))) (define (all-empty? xs) (or (null? xs) (and (null? (car xs)) (all-empty? (cdr xs))))) (define (any-empty? xs) (and (pair? xs) (or (null? (car xs)) (any-empty? (cdr xs))))) (define (syntax-check condition expression) (unless condition (throw (quote mce-syntax) expression))) (define (evaluate-sequence expressions environment) (syntax-check (and (list? expressions) (pair? expressions)) expressions) (let loop ((remaining expressions)) (let ((value (evaluate (car remaining) environment))) (if (null? (cdr remaining)) value (loop (cdr remaining)))))) (define (evaluate-arguments expressions environment) (if (null? expressions) (quote ()) (let ((value (evaluate (car expressions) environment))) (cons value (evaluate-arguments (cdr expressions) environment))))) (define (evaluate expression environment) (cond ((or (number? expression) (boolean? expression) (string? expression)) expression) ((symbol? expression) (lookup expression environment)) ((not (and (list? expression) (pair? expression))) (throw (quote mce-syntax) expression)) (else (let ((head (car expression)) (arguments (cdr expression))) (cond ((eq? head (quote quote)) (syntax-check (= (length arguments) 1) expression) (car arguments)) ((eq? head (quote if)) (syntax-check (= (length arguments) 3) expression) (evaluate (if (eq? (evaluate (car arguments) environment) #f) (caddr arguments) (cadr arguments)) environment)) ((eq? head (quote lambda)) (syntax-check (and (>= (length arguments) 2) (list? (car arguments)) (every-symbol? (car arguments)) (unique-symbols? (car arguments))) expression) (vector (quote closure) (car arguments) (cdr arguments) environment)) ((eq? head (quote begin)) (evaluate-sequence arguments environment)) ((eq? head (quote let)) (evaluate (expand-let arguments) environment)) ((eq? head (quote let*)) (syntax-check (and (>= (length arguments) 2) (valid-bindings? (car arguments))) expression) (evaluate (expand-let-star (car arguments) (cdr arguments)) environment)) ((eq? head (quote cond)) (evaluate-cond arguments environment)) ((eq? head (quote and)) (evaluate-and arguments environment)) ((eq? head (quote or)) (evaluate-or arguments environment)) ((or (eq? head (quote unless)) (eq? head (quote when))) (syntax-check (>= (length arguments) 2) expression) (let ((truth (not (eq? (evaluate (car arguments) environment) #f)))) (if (eq? truth (eq? head (quote when))) (evaluate-sequence (cdr arguments) environment) #f))) ((eq? head (quote define)) (syntax-check (>= (length arguments) 2) expression) (let ((target (car arguments))) (cond ((symbol? target) (syntax-check (= (length arguments) 2) expression) (define-value! target (evaluate (cadr arguments) environment) environment) target) ((and (pair? target) (symbol? (car target))) (define-value! (car target) (evaluate (cons (quote lambda) (cons (cdr target) (cdr arguments))) environment) environment) (car target)) (else (throw (quote mce-syntax) expression))))) (else (let ((procedure (evaluate head environment))) (apply-value procedure (evaluate-arguments arguments environment))))))))) (define (valid-bindings? bindings) (and (list? bindings) (let loop ((remaining bindings)) (or (null? remaining) (and (list? (car remaining)) (= (length (car remaining)) 2) (symbol? (caar remaining)) (loop (cdr remaining))))))) (define (expand-let arguments) (syntax-check (>= (length arguments) 2) arguments) (let* ((named? (symbol? (car arguments))) (bindings (if named? (cadr arguments) (car arguments))) (body (if named? (cddr arguments) (cdr arguments)))) (syntax-check (and (valid-bindings? bindings) (pair? body) (unique-symbols? (map car bindings))) arguments) (let ((names (map car bindings)) (values (map cadr bindings))) (if named? (cons (list (quote lambda) names (list (quote define) (car arguments) (cons (quote lambda) (cons names body))) (cons (car arguments) names)) values) (cons (cons (quote lambda) (cons names body)) values))))) (define (expand-let-star bindings body) (if (null? bindings) (cons (quote begin) body) (list (quote let) (list (car bindings)) (expand-let-star (cdr bindings) body)))) (define (evaluate-cond clauses environment) (if (null? clauses) #f (let ((clause (car clauses))) (syntax-check (and (list? clause) (pair? clause)) clause) (if (eq? (car clause) (quote else)) (begin (syntax-check (and (null? (cdr clauses)) (pair? (cdr clause))) clause) (evaluate-sequence (cdr clause) environment)) (let ((value (evaluate (car clause) environment))) (if (eq? value #f) (evaluate-cond (cdr clauses) environment) (if (null? (cdr clause)) value (evaluate-sequence (cdr clause) environment)))))))) (define (evaluate-and expressions environment) (if (null? expressions) #t (let ((value (evaluate (car expressions) environment))) (if (or (eq? value #f) (null? (cdr expressions))) value (evaluate-and (cdr expressions) environment))))) (define (evaluate-or expressions environment) (if (null? expressions) #f (let ((value (evaluate (car expressions) environment))) (if (eq? value #f) (evaluate-or (cdr expressions) environment) value)))) (define (every-symbol? xs) (or (null? xs) (and (symbol? (car xs)) (every-symbol? (cdr xs))))) (define (unique-symbols? xs) (or (null? xs) (and (not (memq (car xs) (cdr xs))) (unique-symbols? (cdr xs))))) (define (run expressions) (evaluate-sequence expressions (initial-environment))))))

(define (run-inside program) (run (append source-definitions (list (list (quote run) (list (quote quote) program))))))

(define (run-host program) (eval (cons (quote begin) program) (make-fresh-user-module)))

(define (error-key thunk) (catch #t (lambda () (thunk) (quote returned)) (lambda (key . args) key)))

(for-each (lambda (example) (let ((program (cadr example)) (expected (caddr example))) (unless (and (equal? (run-host program) expected) (equal? (run program) expected) (equal? (run-inside program) expected)) (error "Three-level result mismatch" (car example))))) examples)

(for-each (lambda (example) (let ((program (cadr example)) (expected (caddr example))) (unless (and (eq? (error-key (lambda () (run program))) expected) (eq? (error-key (lambda () (run-inside program))) expected)) (error "Self-interpretation error mismatch" (car example))))) errors)

(display "11 three-level cases and 5 error cases passed.")

(newline)