Desugaring combines adjacent top-level defines into one letrec

scmvm/language/scheme.scm

@@ -31,7 +31,7 @@
       (boolean? x)))
 
 (define primitives
-  '(#t #f () cons car cdr = + - / *))
+  '(#t #f () cons car cdr = + - / * < >))
 
 (define (primitive? x)
   (memq x primitives))
@@ -41,6 +41,9 @@
       (boolean? x)
       (and (pair? x) (eq? 'quote (car x)))))
 
+(define (define? x)
+  (and (pair? x) (eq? 'define (car x))))
+
  ;; Environment Records
 ;; The idea of an hierarchy of environments comes across often in lexical variable definition
 (define-record-type <environment>
@@ -78,28 +81,36 @@
 ;; Transforms to simplify the language
 ;; - lambdas, lets and letrecs can only have 1 expression in body position
 ;; - defines are decomposed to letrecs that bind their values and wrap their continuations
+;; - adjacent top-level defines are combined into a single top-level letrec
 ;; <prgm> ::= <exp> ...
 ;; <exp>  ::= (lambda (<var> ...) <exp>)
 ;;          | (if <exp> <exp> <exp>)
 ;;          | (<exp> <exp> ...)
 ;;          | (let ((<var> <exp>) ...) <exp>)
-;;          | (letrec ((<var> <exp>)) <exp> ...)
+;;          | (letrec ((<var> <exp>) ...) <exp>)
 ;;          | (begin <exp> ...)
 ;;          | <num> | <sym> | <var> | #t | #f
 
-(define (desugar-top prgm)
-  (match prgm
-    [() '()]
-    [(('define . _) cont ...) (desugar-define (car prgm) cont)]
-    [_ (cons (desugar-exp (car prgm))
-             (desugar-top (cdr prgm)))]))
-
-(define (desugar-define def cont)
-  (match def
+(define (collect-bindings prgm)
+  ;; Collect the bindings of adjacent defines
+  (match (car prgm)
     [`(define ,(name params ...) . ,e*)
-     `(letrec ([,name ,(desugar-exp `(lambda ,params ,@e*))]) (begin ,@(desugar-top cont)))]
+     (let-values ([(bindings cont) (collect-bindings (cdr prgm))])
+      (values (cons `(,name ,(desugar-exp `(lambda ,params ,@e*))) bindings)
+              cont))]
     [`(define ,name ,exp)
-     `(letrec ([,name ,(desugar-exp exp)]) (begin ,@(desugar-top cont)))]))
+     (let-values ([(bindings cont) (collect-bindings (cdr prgm))])
+       (values (cons `(,name ,(desugar-exp exp)) bindings)
+               cont))]
+    [_ (values '() prgm)]))
+
+(define (desugar-top prgm)
+  (cond
+   [(null? prgm) '()]
+   [(define? (car prgm))
+    (let-values ([(bindings cont) (collect-bindings prgm)])
+      `(letrec ,bindings ,(desugar-body cont)))]
+   [else (cons (desugar-exp (car prgm)) (desugar-top (cdr exp)))]))
 
 (define (desugar-exp exp)
   (match exp
@@ -180,10 +191,10 @@
     [ ('quote e) `(,c ,expr)]
     [`(lambda . ,_) `(,c ,(M expr r))]
     [ (? atomic?)   `(,c ,(M expr r))]
-    [ ('letrec ([v e]) body)
-      (let-values ([(r0 v0) (uniq-name r v)])
-        (T-k e (lambda ($e)
-                 (T-k body (lambda ($body) `(letrec ([,v0 ,$e]) (,c ,$body))) r0))
+    [ ('letrec ([v* e*] ...) body)
+      (let-values ([(r0 v*0) (uniq-names r v*)])
+        (T*-k e* (lambda ($e*)
+                   (T-k body (lambda ($body) `(letrec ,(zip v*0 $e*) (,c ,$body))) r0))
              r0))]
     [ ('begin e) (T-c e c r)]
     [ ('begin e e* ...)
@@ -217,12 +228,12 @@
     [ ('quote e) (k expr)]
     [`(lambda . ,_) (k (M expr r))]
     [(? atomic?)   (k (M expr r))]
-    [('letrec ([v e]) body)
-     (let-values ([(r0 v0) (uniq-name r v)])
-       (T-k e
-            (lambda ($e)
+    [('letrec ([v* e*] ...) body)
+     (let-values ([(r0 v*0) (uniq-names r v*)])
+       (T*-k e*
+            (lambda ($e*)
               (T-k body
-                   (lambda ($body) `(letrec ([,v ,$e]) ,(k $body)))
+                   (lambda ($body) `(letrec ,(zip v*0 $e*) ,(k $body)))
                    r0))
             r0))]
     [('begin e) (T-k e k r)]