diff --git a/expression-structs.rkt b/expression-structs.rkt index c479822..7f34250 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -7,7 +7,7 @@ (define-type ExpressionCore (U Top Constant ToplevelRef LocalRef - SetToplevel + ToplevelSet Branch Lam Seq App Let1 Let LetRec)) @@ -23,7 +23,7 @@ (define-struct: LocalRef ([depth : Natural]) #:transparent) -(define-struct: SetToplevel ([depth : Natural] +(define-struct: ToplevelSet ([depth : Natural] [pos : Natural] [name : Symbol] [value : ExpressionCore]) #:transparent) diff --git a/parse.rkt b/parse.rkt index 433dada..574e2b5 100644 --- a/parse.rkt +++ b/parse.rkt @@ -49,10 +49,10 @@ [(EnvLexicalReference? address) (error 'parse "Can't define except in toplevel context")] [(EnvPrefixReference? address) - (make-SetToplevel (EnvPrefixReference-depth address) + (make-ToplevelSet (EnvPrefixReference-depth address) (EnvPrefixReference-pos address) (EnvPrefixReference-name address) - (parse (definition-value exp) cenv))]))] + (parse (definition-value exp) cenv))]))] [(if? exp) (make-Branch (parse (if-predicate exp) cenv) @@ -73,11 +73,13 @@ cenv (extend-lexical-environment/names '() (lambda-parameters exp)) unbound-names)]) - (let ([lam-body (make-Seq (map (lambda (b) - (parse b body-cenv)) - (lambda-body exp)))]) + (let ([lam-body (map (lambda (b) + (parse b body-cenv)) + (lambda-body exp))]) (make-Lam (length (lambda-parameters exp)) - lam-body + (if (= (length lam-body) 1) + (first lam-body) + (make-Seq lam-body)) closure-references)))] [(begin? exp) @@ -117,58 +119,59 @@ ;; find-unbound-names: Any -> (Listof Symbol) (define (find-unbound-names exp) - (cond - [(self-evaluating? exp) - '()] - - [(quoted? exp) - '()] - - [(variable? exp) - (list exp)] - - [(definition? exp) - (let ([address (find-variable (definition-variable exp))]) - (cons (definition-variable address) - (find-unbound-names (definition-value exp))))] - - [(if? exp) - (append (find-unbound-names (if-predicate exp)) - (find-unbound-names (if-consequent exp)) - (find-unbound-names (if-alternative exp)))] - - [(cond? exp) - (find-unbound-names (desugar-cond exp))] - - [(lambda? exp) - (list-difference (apply append (map find-unbound-names (lambda-body exp))) - (lambda-parameters exp))] - - [(begin? exp) - (apply append (map find-unbound-names (begin-actions exp)))] - - [(named-let? exp) - (find-unbound-names (desugar-named-let exp))] - - [(let*? exp) - (find-unbound-names (desugar-let* exp))] - - [(let? exp) - (append (apply append (map find-unbound-names (let-rhss exp))) - (list-difference (apply append (map find-unbound-names (let-body exp))) - (let-variables exp)))] - - [(letrec? exp) - (list-difference (append (apply append (map find-unbound-names (let-rhss exp))) - (apply append (map find-unbound-names (let-body exp)))) - (let-variables exp))] - - [(application? exp) - (append (find-unbound-names (operator exp)) - (apply append (map find-unbound-names (operands exp))))] - - [else - (error 'find-unbound-names "Unknown expression type ~e" exp)])) + (unique/eq? + (let loop ([exp exp]) + (cond + [(self-evaluating? exp) + '()] + + [(quoted? exp) + '()] + + [(variable? exp) + (list exp)] + + [(definition? exp) + (cons (definition-variable exp) + (loop (definition-value exp)))] + + [(if? exp) + (append (loop (if-predicate exp)) + (loop (if-consequent exp)) + (loop (if-alternative exp)))] + + [(cond? exp) + (loop (desugar-cond exp))] + + [(lambda? exp) + (list-difference (apply append (map loop (lambda-body exp))) + (lambda-parameters exp))] + + [(begin? exp) + (apply append (map loop (begin-actions exp)))] + + [(named-let? exp) + (loop (desugar-named-let exp))] + + [(let*? exp) + (loop (desugar-let* exp))] + + [(let? exp) + (append (apply append (map loop (let-rhss exp))) + (list-difference (apply append (map loop (let-body exp))) + (let-variables exp)))] + + [(letrec? exp) + (list-difference (append (apply append (map loop (let-rhss exp))) + (apply append (map loop (let-body exp)))) + (let-variables exp))] + + [(application? exp) + (append (loop (operator exp)) + (apply append (map loop (operands exp))))] + + [else + (error 'find-unbound-names "Unknown expression type ~e" exp)])))) @@ -226,10 +229,11 @@ (cadr exp)) (define (if-consequent exp) (caddr exp)) + (define (if-alternative exp) (if (not (null? (cdddr exp))) (cadddr exp) - 'false)) + `',(void))) (define (begin? exp) (tagged-list? exp 'begin)) @@ -258,7 +262,7 @@ [else `(if ,question ,answer - (void))]))] + ',(void))]))] [else (let* ([clause (car clauses)] [question (car clause)] diff --git a/test-parse.rkt b/test-parse.rkt new file mode 100644 index 0000000..4870e36 --- /dev/null +++ b/test-parse.rkt @@ -0,0 +1,194 @@ +#lang racket/base + +(require "parse.rkt" + "lexical-structs.rkt" + "expression-structs.rkt" + (for-syntax racket/base)) + +; Test out the compiler, using the simulator. +(define-syntax (test stx) + (syntax-case stx () + [(_ expr expt) + (with-syntax ([stx stx]) + (syntax/loc #'stx + (begin + (printf "Running ~s ...\n" (syntax->datum #'expr)) + (let ([expected expt] + [actual + (with-handlers ([void + (lambda (exn) + (raise-syntax-error #f (format "Runtime error: got ~s" exn) + #'stx))]) + expr)]) + (unless (equal? actual expected) + (raise-syntax-error #f (format "Expected ~s, got ~s" expected actual) + #'stx)) + (printf "ok.\n\n")))))])) + + + +(test (parse '1) + (make-Top (make-Prefix '()) + (make-Constant 1))) + +(test (parse ''hello) + (make-Top (make-Prefix '()) + (make-Constant 'hello))) + +(test (parse 'hello) + (make-Top (make-Prefix '(hello)) + (make-ToplevelRef 0 0))) + +(test (parse '(begin hello world)) + (make-Top (make-Prefix '(hello world)) + (make-Seq (list (make-ToplevelRef 0 0) + (make-ToplevelRef 0 1))))) + +(test (parse '(define x y)) + (make-Top (make-Prefix '(x y)) + (make-ToplevelSet 0 0 'x (make-ToplevelRef 0 1)))) + +(test (parse '(begin (define x 42) + (define y x))) + (make-Top (make-Prefix '(x y)) + (make-Seq (list (make-ToplevelSet 0 0 'x (make-Constant 42)) + (make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0)))))) + +(test (parse '(if x y z)) + (make-Top (make-Prefix '(x y z)) + (make-Branch (make-ToplevelRef 0 0) + (make-ToplevelRef 0 1) + (make-ToplevelRef 0 2)))) + +(test (parse '(if x (if y z 1) #t)) + (make-Top (make-Prefix '(x y z)) + (make-Branch (make-ToplevelRef 0 0) + (make-Branch (make-ToplevelRef 0 1) + (make-ToplevelRef 0 2) + (make-Constant 1)) + (make-Constant #t)))) + +(test (parse '(if x y)) + (make-Top (make-Prefix '(x y)) + (make-Branch (make-ToplevelRef 0 0) + (make-ToplevelRef 0 1) + (make-Constant (void))))) + +(test (parse '(cond [x y])) + (make-Top (make-Prefix '(x y)) + (make-Branch (make-ToplevelRef 0 0) + (make-ToplevelRef 0 1) + (make-Constant (void))))) + +(test (parse '(cond [x y] [else "ok"])) + (make-Top (make-Prefix '(x y)) + (make-Branch (make-ToplevelRef 0 0) + (make-ToplevelRef 0 1) + (make-Constant "ok")))) + +(test (parse '(lambda (x y z) x)) + (make-Top (make-Prefix '()) + (make-Lam 3 (make-LocalRef 0) '()))) + +(test (parse '(lambda (x y z) y)) + (make-Top (make-Prefix '()) + (make-Lam 3 (make-LocalRef 1) '()))) + +(test (parse '(lambda (x y z) z)) + (make-Top (make-Prefix '()) + (make-Lam 3 (make-LocalRef 2) '()))) + + +(test (parse '(lambda (x y z) x y z)) + (make-Top (make-Prefix '()) + (make-Lam 3 (make-Seq (list (make-LocalRef 0) + (make-LocalRef 1) + (make-LocalRef 2))) + '()))) + +(test (parse '(lambda (x y z) k)) + (make-Top (make-Prefix '(k)) + (make-Lam 3 (make-ToplevelRef 0 0 ) + (list (make-EnvWholePrefixReference 0))))) + +(test (parse '(lambda (x y z) k x y z)) + (make-Top (make-Prefix '(k)) + (make-Lam 3 (make-Seq (list (make-ToplevelRef 0 0 ) + (make-LocalRef 1) + (make-LocalRef 2) + (make-LocalRef 3))) + (list (make-EnvWholePrefixReference 0))))) + +(test (parse '(lambda (x) + (lambda (y) + (lambda (z) + x + y + z + w)))) + (make-Top (make-Prefix '(w)) + (make-Lam 1 + (make-Lam 1 + (make-Lam 1 + (make-Seq (list + (make-LocalRef 1) + (make-LocalRef 2) + (make-LocalRef 3) + (make-ToplevelRef 0 0))) + (list (make-EnvWholePrefixReference 0) ;; w + (make-EnvLexicalReference 1 #f) ;; x + (make-EnvLexicalReference 2 #f) ;; y + )) + (list (make-EnvWholePrefixReference 0) ;; w + (make-EnvLexicalReference 1 #f) ;; x + )) + (list (make-EnvWholePrefixReference 0))))) + +(test (parse '(lambda (x) + (lambda (y) + x))) + (make-Top (make-Prefix '()) + (make-Lam 1 + (make-Lam 1 + (make-LocalRef 0) + (list (make-EnvLexicalReference 0 #f))) + (list)))) + +(test (parse '(lambda (x) + (lambda (y) + y))) + (make-Top (make-Prefix '()) + (make-Lam 1 + (make-Lam 1 + (make-LocalRef 0) + (list)) + (list)))) + +(test (parse '(+ x x)) + (make-Top (make-Prefix '(+ x)) + (make-App (make-ToplevelRef 2 0) + (list (make-ToplevelRef 2 1) + (make-ToplevelRef 2 1))))) + + +(test (parse '(lambda (x) (+ x x))) + (make-Top (make-Prefix '(+)) + (make-Lam 1 + (make-App (make-ToplevelRef 2 0) + (list (make-LocalRef 3) + (make-LocalRef 3))) + (list (make-EnvWholePrefixReference 0))))) + +(test (parse '(lambda (x) + (+ (* x x) x))) + (make-Top (make-Prefix '(* +)) + (make-Lam 1 + ;; stack layout: [???, ???, prefix, x] + (make-App (make-ToplevelRef 2 1) + (list + ;; stack layout: [???, ???, ???, ???, prefix, x] + (make-App (make-ToplevelRef 4 0) + (list (make-LocalRef 5) + (make-LocalRef 5))) + (make-LocalRef 3))) + (list (make-EnvWholePrefixReference 0)))))