more tests on parsing

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)

parse.rkt

@@ -49,7 +49,7 @@
          [(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))]))]
@@ -73,11 +73,13 @@
                         cenv
                         (extend-lexical-environment/names '() (lambda-parameters exp))
                         unbound-names)])
-       (let ([lam-body (make-Seq (map (lambda (b)
+       (let ([lam-body (map (lambda (b)
                               (parse b body-cenv))
-                                      (lambda-body exp)))])
+                            (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,6 +119,8 @@
 
 ;; find-unbound-names: Any -> (Listof Symbol)
 (define (find-unbound-names exp)
+  (unique/eq?
+   (let loop ([exp exp])
      (cond
        [(self-evaluating? exp)
         '()]
@@ -128,47 +132,46 @@
         (list exp)]
        
        [(definition? exp)
-     (let ([address (find-variable (definition-variable exp))])
+        (cons (definition-variable exp)
-       (cons (definition-variable address)
+              (loop (definition-value exp)))]
-             (find-unbound-names (definition-value exp))))]
        
        [(if? exp)
-     (append (find-unbound-names (if-predicate exp))
+        (append (loop (if-predicate exp))
-             (find-unbound-names (if-consequent exp))
+                (loop (if-consequent exp))
-             (find-unbound-names (if-alternative exp)))]
+                (loop (if-alternative exp)))]
        
        [(cond? exp)
-     (find-unbound-names (desugar-cond exp))]
+        (loop (desugar-cond exp))]
        
        [(lambda? exp)
-     (list-difference (apply append (map find-unbound-names (lambda-body exp)))
+        (list-difference (apply append (map loop (lambda-body exp)))
                          (lambda-parameters exp))]
        
        [(begin? exp)
-     (apply append (map find-unbound-names (begin-actions exp)))]
+        (apply append (map loop (begin-actions exp)))]
        
        [(named-let? exp)
-     (find-unbound-names (desugar-named-let exp))]
+        (loop (desugar-named-let exp))]
        
        [(let*? exp)
-     (find-unbound-names (desugar-let* exp))]
+        (loop (desugar-let* exp))]
        
        [(let? exp)
-     (append (apply append (map find-unbound-names (let-rhss exp)))
+        (append (apply append (map loop (let-rhss exp)))
-             (list-difference (apply append (map find-unbound-names (let-body exp)))
+                (list-difference (apply append (map loop (let-body exp)))
                                  (let-variables exp)))]
        
        [(letrec? exp)
-     (list-difference (append (apply append (map find-unbound-names (let-rhss exp)))
+        (list-difference (append (apply append (map loop (let-rhss exp)))
-                              (apply append (map find-unbound-names (let-body exp))))
+                                 (apply append (map loop (let-body exp))))
                          (let-variables exp))]
        
        [(application? exp)
-     (append (find-unbound-names (operator exp))
+        (append (loop (operator exp))
-             (apply append (map find-unbound-names (operands exp))))]
+                (apply append (map loop (operands exp))))]
        
        [else
-     (error 'find-unbound-names "Unknown expression type ~e" exp)]))
+        (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)]

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)))))