Update compiler description (now a working Scheme program).

Maps lexical variables, decodes argument lists, and flattens procedures
to simple lists of primitive operations, but does not yet convert to
CPS or perform register (gN, iN, fN) allocation, much less optimization.

doc/compiler.txt

@@ -1,24 +1,114 @@
-(let ...)
+(define (simplify-form form)
-(let* ...)
+  (if (pair? form)
-(letrec ...)
+    (case (car form)
+      [(let) (simplify-let form)]
+      [(let*) (simplify-let* form)]
+      [(letrec) (simplify-letrec form)]
+      [(if) (simplify-if form)]
+      [(lambda) (simplify-lambda form)]
+      [(begin) `(%bind () ,@(map simplify-form (cdr form)))]
+      [(set!) (simplify-set! form)]
+      [(car cdr)
+       (if (pair? (second form))
+           (let ([x (gensym)])
+             `(%bind (,x)
+                ,(simplify-form `(set! ,x ,(second form)))
+                (,(if (eq? (first form) 'car) '%car '%cdr) ,x)))
+           `(,(if (eq? (first form) 'car) '%car '%cdr) ,(second form)))]
+      [(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr) form]
+      [else (simplify-funcall form)])
+    form))
 
-; (if cond-expr true-expr false-expr)
+(define (simplify-set! form)
-;    => (let ([cond-val cond-expr])
+  (let ([value-form (simplify-form (third form))])
-;         (let ([next-fn (%if cond-val
+    (if (and (pair? value-form) (eq? (first value-form) '%bind))
-;                             (lambda () true-expr)
+        `(%bind ,(second value-form)
-;                             (lambda () false-expr))])
+           ,@(foldr (lambda (x s)
-;           (next-fn)))
+                      (if (pair? s)
+                          (cons x s)
+                          (list (simplify-set! `(set! ,(second form) ,x)))))
+                    '()
+                    (cddr value-form)))
+        `(%set! ,(second form) ,value-form))))
 
-(define (transform-if form)
+; (let ([var expr]...) bodyexpr...)  ; first eval exprs, then assign bindings in parallel
+;    => (%bind (tmp...)
+;         (%set! tmp ,(simplify-form expr))...
+;         (%bind (var...)
+;           (%set! var tmp)...
+;           bodyexpr...))
+
+(define (simplify-let form)
+   (define bindings (second form))
+   (define bodyexprs (cdr (cdr form)))
+   (define vars (map (lambda (x) (if (pair? x) (first x) x)) bindings))
+   (define temp-bindings
+     (append-map
+       (lambda (x) (if (pair? x)
+                       (let ([tmp (gensym)])
+                         `((,tmp
+                            ,(simplify-form `(set! ,tmp ,(second x)))
+                            (%set! ,(first x) ,tmp))))
+                         '()))
+       bindings))
+   (if (pair? bindings)
+       (if (pair? (cdr bindings))
+           `(%bind ,(map first temp-bindings)
+              ,@(map second temp-bindings)
+              (%bind ,vars
+                ,@(map third temp-bindings)
+                ,@(map simplify-form bodyexprs)))
+           `(%bind (,(first vars))
+              ,@(if (pair? (first bindings))
+                  `(,(simplify-form `(set! ,(first vars) ,(second (first bindings)))))
+                  '())
+              ,@(map simplify-form bodyexprs)))
+       `(%bind () ,@bodyexprs)))
+
+; (let* ...)   ; eval exprs & bind variables serially
+;    => (let ([var-0 expr-0])
+;         (let ([var-1 expr-1])
+;           (...
+;             bodyexprs...)))
+
+(define (simplify-let* form)
+   (define bindings (second form))
+   (define bodyexprs (cdr (cdr form)))
+   (define (add-binding bind bodyexpr)
+      `(let (,bind) ,bodyexpr))
+   (simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))
+
+; (letrec ...) ; init bindings to undefined, then assign values in series
+;    => (let (var...)
+;         (set! var expr)...
+;         bodyexprs)
+
+(define (simplify-letrec form)
+  (define bindings (second form))
+  (define bodyexprs (cdr (cdr form)))
+  (simplify-form
+  `(%bind (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
+     ,@(append-map
+         (lambda (x)
+           (if (pair? x)
+               `((set! ,(first x) ,(simplify-form (second x))))
+               '()))
+         bindings)
+     ,@(map simplify-form bodyexprs))))
+
+(define (simplify-if form)
   (define cond-val (gensym))
   (define next-fn (gensym))
+  (define true-fn (gensym))
+  (define false-fn (gensym))
   (define-values (cond-expr true-expr false-expr)
                  (apply values (cdr form)))
-   `(let ([,cond-val ,cond-expr])
+  (simplify-form
-      (let ([,next-fn (%if ,cond-val
+    `(let ([,cond-val ,cond-expr]
-                           (lambda () ,true-expr)
+           [,true-fn  (%lambda ,(simplify-form true-expr))]
-                           (lambda () ,false-expr))])
+           [,false-fn (%lambda ,(simplify-form false-expr))])
-        (,next-fn))))
+       (let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
+         (%apply ,next-fn %nil)))))
 
 ; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
 ;    => (lambda argv
@@ -29,12 +119,12 @@
 ;               (set! argv-temp (cdr argv-temp)))
 ;               (...
 ;                 (let (optional-0)
-;                   (if (eq? argv-temp nil)
+;                   (if (eq? argv-temp %nil)
 ;                       (set! optional-0 default-expr-0)
 ;                       (set! optional-0 (car argv-temp)))
 ;                   (set! argv-temp (cdr argv-temp))
 ;                   (let (optional-1)
-;                     (if (eq? argv-temp nil)
+;                     (if (eq? argv-temp %nil)
 ;                         (set! optional-1 default-expr-1)
 ;                         (set! optional-1 (car argv-temp)))
 ;                     (set! argv-temp (cdr argv-temp))
@@ -42,55 +132,129 @@
 ;                       (let ([rest argv-temp])
 ;                         bodyexpr...)...)))...)))
 
-(define (transform-lambda-arglist form)
+(define (simplify-lambda form)
    (define arglist (car (cdr form)))
    (define bodyexprs (cdr (cdr form)))
    (define (split-arglist arglist)
       (define (split-optional arglist)
          (if (pair? arglist)
              (let-values ([(opt rst) (split-optional (cdr arglist))])
-               (values opt rst)) 
+               (values (cons (car arglist) opt) rst)) 
-             (values nil arglist)))
+             (values '() arglist)))
-      (if (eq? arglist nil)
+      (if (pair? arglist)
-          (values nil nil #f)
           (if (pair? (car arglist))
             (let-values ([(opt rst) (split-optional arglist)])
-               (values nil opt rst))
+               (values '() opt rst))
             (let-values ([(req opt rst) (split-arglist (cdr arglist))])
-               (values (cons (car arglist) req) opt rst)))))
+               (values (cons (car arglist) req) opt rst)))
+          (values '() '() #f)))
 
    (define-values (requireds optionals rest) (split-arglist arglist))
    (define argv-temp (gensym))
+   (define k (gensym))
+   (define rval (gensym))
 
    (define (add-req req inner) `(let ([,req (car ,argv-temp)])
                                   (set! ,argv-temp (cdr ,argv-temp))
                                   ,inner))
    (define (add-opt opt-list inner) `(let (,(car opt-list))
-                                       (if (eq? ,argv-temp nil)
+                                       (if (pair? ,argv-temp)
-                                           (set! ,(car opt-list) ,(cdr opt-list))
+                                           (begin
-                                           (set! ,(car opt-list) (car ,argv-temp)))
+                                             (set! ,(first opt-list) (car ,argv-temp))
+                                             (set! ,argv-temp (cdr ,argv-temp)))
+                                           (set! ,(first opt-list) ,(second opt-list)))
                                        ,inner))
    (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
                                    `(begin ,@bodyexprs)))
-   `(lambda ,argv-temp
+   `(%lambda 
-      ,(foldr add-req (foldr add-opt rest+bodyexprs optionals) requireds)))
+      (%bind (,rval ,k)
+        (%set! ,k %k)
+        ,(simplify-form
+           `(set! ,rval (let ([,argv-temp %argv])
+                          ,(foldr add-req (foldr add-opt rest+bodyexprs optionals) requireds))))
+        (%set! ,rval (%cons ,rval %nil))
+        (%tail-call ,k ,rval))))
 
 ; (fn-expr arg-expr...)
 ;    => (let ([fn-var fn-expr] arg-var... argv)
 ;         (set! fn-var fn-expr)
 ;         (set! arg-var arg-expr)...
-;         (set! argv nil)
+;         (set! argv %nil)
 ;         (set! argv (cons arg-var argv))... [reversed]
-;         (apply fn-var argv))
+;         (%apply fn-var argv))
 
-(define (transform-funcall form)
+(define (simplify-funcall form)
   (define fn-expr (car form))
   (define arg-exprs (cdr form))
   (define fn-var (gensym))
   (define arg-vars (map (lambda (x) (gensym)) arg-exprs))
   (define argv (gensym))
-   `(let ([,fn-var ,fn-expr] ,@arg-vars ,argv)
+  (simplify-form
-      ,@(map (lambda (x y) `(set! ,x ,y)) arg-vars arg-exprs)
+    `(%bind (,fn-var ,@arg-vars ,argv)
-      (set! ,argv nil)
+       ,(simplify-form `(set! ,fn-var ,fn-expr))
-      ,@(reverse (map (lambda (x) `(set! ,argv (cons ,x ,argv))) arg-vars))
+       ,@(map (lambda (x y) (simplify-form `(set! ,x ,y))) arg-vars arg-exprs)
-      (apply ,fn-var ,argv)))
+       (%set! ,argv %nil)
+       ,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
+       (%apply ,fn-var ,argv))))
+
+(define (subst-var old-var new-var form)
+  (define (recurse form)
+    (subst-var old-var new-var form))
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (if (memq old-var (second form))
+           form
+           `(%bind ,(second form) ,@(map recurse (cddr form))))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map recurse (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    (if (eq? form old-var)
+        new-var
+        form)))
+
+(define (make-bindings-unique form)
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (let ([new-vars (map (lambda _ (gensym)) (second form))])
+         `(%bind ,new-vars
+            ,@(map (lambda (frm)
+                     (foldl (lambda (pair s)
+                              (subst-var (car pair)
+                                         (cdr pair)
+                                         s))
+                            (make-bindings-unique frm)
+                            (map cons (second form) new-vars)))
+                   (cddr form))))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map make-bindings-unique (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    form))
+
+(define (flatten-binds form)
+  ;(pretty-print form) (write-char #\Newline)
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (let* ([bound-vars (second form)]
+              [subforms (append-map (lambda (form)
+                                      (let ([new-form (flatten-binds form)])
+                                        (if (and (pair? new-form) (eq? (car new-form) '%bind))
+                                          (begin
+                                            (set! bound-vars (append bound-vars (second new-form)))
+                                            (cddr new-form))
+                                          (list new-form))))
+                                    (cddr form))])
+         `(%bind ,bound-vars ,@subforms))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map flatten-binds (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    form))
+
+(define (compile form)
+  (flatten-binds
+      (make-bindings-unique
+        (simplify-form `(lambda () ,form)))))
+
+; vim:set sw=2 expandtab: