* added with-output-to-string

src/libchezio.ss

@@ -695,6 +695,14 @@
             (error 'get-output-string "~s is not an output port" p))))
   )
   
+  (primitive-set! 'with-output-to-string
+    (lambda (f)
+      (unless (procedure? f)
+        (error 'with-output-to-string "~s is not a procedure" f))
+      (let ([p (open-output-string)])
+        (parameterize ([current-output-port p]) (f))
+        (get-output-string p))))
+
   (primitive-set! 'with-output-to-file
      (lambda (name proc . args)
        (unless (string? name) 

src/libcogen1.ss

@@ -115,6 +115,14 @@
   ;;;
   (Program x))
 
+
+
+
+;;; the program so far includes both primcalls and funcalls to
+;;; primrefs.  This pass removes all primcalls.  Once everything
+;;; works, we need to fix all previous passes to eliminate this 
+;;; whole primcall business.
+
 (define (remove-primcalls x)
   ;;;
   (define who 'remove-primcalls)
@@ -191,13 +199,346 @@
 
 ;;;
 ;;; So, what do we want to do here?
-;;;
+;;; 1. we eliminate all variables:
+;;;    bind should become a sequence of (setfv i <value>) statements
+;;;    variable refs should befome (fv i) where i is the index of
+;;;    the var on the stack.
+;;; 2. we need to keep track of the maximum stack size used; and
+;;;    whether we made a procedure call so that we can insert a 
+;;;    stack overflow check with an appropriate size check.
+;;; 3. as we generate code, we need to keep track of which stack
+;;;    locations contain pointers so that procedure calls can
+;;;    set an appropriate mask.
+;;; 4. primitives that allocate, as well as closures and fixes 
+;;;    should insert an appropriate alloc-check marks as well as
+;;;    keep the live masks for the later generation of trap handlers
+;;; 5. primcalls should also keep track of liveness information
+;;;    and frame size just in case the primitive needs to make a 
+;;;    procedure call.
+
+
+(define-record move (src dst))
+(define-record alloc-check (n si live))
+(define-record fvar (idx))
+(define acr '%acr)
+(define-record cpvar (idx))
+(define-record cmp (op v0 v1))
+(define false-object 'false-object)
+
+(define (new-cogen-pass1 x)
+  ;;;
+  (define who 'new-cogen-pass-1)
+  ;;;
+  (define (fxeven? x)
+    (if (fixnum? x)
+        ($fxzero? ($fxlogand x 1))
+        (error 'fxeven? "~s is not a fixnum" x)))
+  ;;;
+  (define (sum ls)
+    (let f ([ls ls] [n 0])
+      (cond
+        [(null? ls) n]
+        [else (f (cdr ls) (fx+ (car ls) n))])))
+  ;;;
+  (define fxmax
+    (case-lambda
+      [(x y) (if (fx> x y) x y)]
+      [(x y z)   (fxmax x (fxmax y z))]
+      [_ (error 'fxmax "unhandled")]))
+  ;;;
+  (define (do-seq e0 si live env e1 k)
+    (let-values ([(e0 msi0 call0?) 
+                  (Effect e0 si live env)])
+       (let-values ([(e1 msi1 call1?)
+                     (k e1 si live env)])
+         (values (make-seq e0 e1) 
+                 (fxmax msi0 msi1) 
+                 (or call0? call1?)))))
+  ;;;
+  (define (do-cond e0 si live env e1 e2 k)
+    (let-values ([(e0 msi0 call0?) 
+                  (Pred e0 si live env)])
+       (let-values ([(e1 msi1 call1?)
+                     (k e1 si live env)]
+                    [(e2 msi2 call2?)
+                     (k e2 si live env)])
+         (values (make-conditional e0 e1 e2)
+                 (fxmax msi0 msi1 msi2)
+                 (or call0? call1? call2?)))))
+  ;;;
+  (define (do-move-to-mem loc expr si live env)
+    (record-case expr
+      [(constant) 
+       (values (make-move expr loc) 0 #f)]
+      [else
+       (let-values ([(x msi call?) 
+                     (Value expr si live env)])
+         (values (make-seq x (make-move acr loc)) msi call?))]))
+  ;;;
+  (define (do-bind lhs* rhs* si live env0 env body k)
+    (cond
+      [(null? lhs*)
+       (k body si live env)]
+      [else
+       (let ([fv (make-fvar si)])
+         (let-values ([(e0 msi0 call0?)
+                       (do-move-to-mem fv (car rhs*) si live env0)])
+           (let-values ([(e1 msi1 call1?)
+                         (do-bind (cdr lhs*) (cdr rhs*) 
+                                  (fxadd1 si)
+                                  (cons si live)
+                                  env0
+                                  (cons (cons (car lhs*) fv) env)
+                                  body
+                                  k)])
+             (values (make-seq e0 e1)
+                     (fxmax msi0 msi1) 
+                     (or call0? call1?)))))]))
+  ;;;
+  (define (align n)
+    (cond
+      [(fxeven? n) n]
+      [else (fxadd1 n)]))
+  ;;;
+  (define (extend-env* lhs* si live env)
+    (let f ([lhs* lhs*] [si si] [live live] [env env] [nlhs* '()])
+      (cond
+        [(null? lhs*)
+         (values nlhs* si live env)]
+        [else
+         (let ([fv (make-fvar si)])
+           (f (cdr lhs*) (fxadd1 si) (cons si live) 
+              (cons (cons (car lhs*) fv) env)
+              (cons fv nlhs*)))])))
+  ;;;
+  (define (insert-const-alloc-check n si live rest)
+    (cond
+      [(fxzero? n) rest]
+      [else
+       (make-seq 
+         (make-alloc-check n si live)
+         rest)]))
+  ;;;
+  (define (construct-closures n* lhs* nlhs* rhs* body)
+    (cond
+      [(null? lhs*) body]
+      [else
+       (make-seq 'FIXME:construct-closures body)]))
+  ;;;
+  (define (do-fix lhs* rhs* si live env body k)
+    (define (compute-closure-size x)
+      (record-case x
+        [(closure label free*)
+         (align (fxadd1 (length free*)))]))
+    (let ([n* (map compute-closure-size rhs*)])
+      (let ([n (sum n*)])
+        (let-values ([(nlhs* si live env) 
+                      (extend-env* lhs* si live env)])
+          (let-values ([(x msi call?) 
+                        (k body si live env)])
+            (values (insert-const-alloc-check n si live
+                       (construct-closures n* lhs* nlhs* rhs* x))
+                    msi call?))))))
+  ;;;
+  (define (constant-rep x)
+    'FIXME:constant-rep)
+  ;;;
+  (define (do-closure label free* si live env)
+     'FIXME:do-closure)
+  ;;;
+  (define (do-forcall x si live env)
+    (values 'FIXME:do-forcall si #f))
+  ;;;
+  (define (do-tail-funcall x si live env)
+    (values 'FIXME:do-tail-funcall si #f))
+  ;;;
+  (define (do-tail-appcall x si live env)
+    (values 'FIXME:do-tail-appcall si #f))
+  ;;;
+  (define (do-tail-jmpcall x si live env)
+    (values 'FIXME:do-tail-jmpcall si #f))
+  ;;;
+  (define (do-effect-funcall x si live env)
+    (values 'FIXME:do-effect-funcall si #f))
+  ;;;
+  (define (do-effect-appcall x si live env)
+    (values 'FIXME:do-effect-appcall si #f))
+  ;;;
+  (define (do-effect-jmpcall x si live env)
+    (values 'FIXME:do-effect-jmpcall si #f))
+  ;;;
+  (define (do-value-funcall x si live env)
+    (values 'FIXME:do-value-funcall si #f))
+  ;;;
+  (define (do-value-appcall x si live env)
+    (values 'FIXME:do-value-appcall si #f))
+  ;;;
+  (define (do-value-jmpcall x si live env)
+    (values 'FIXME:do-value-jmpcall si #f))
+  ;;;
+  (define (do-mvcall x si live env k)
+    (values 'FIXME:do-mvcall si #t))
+  ;;;
+  (define (Var x env)
+    (cond
+      [(assq x env) => cdr]
+      [else (error who "unbound var ~s" x)]))
+  ;;;
+  (define (Primref x)
+    'FIXME:primref)
+  ;;;
+  (define (Value x si live env)
+    (record-case x
+      [(constant t) 
+       (values (make-move (constant-rep t) acr) 0 #f)]
+      [(var)      
+       (values (make-move (Var x env) acr) 0 #f)]
+      [(primref)  
+       (values (make-move (Primref x) acr) 0 #f)]
+      [(bind lhs* rhs* body)  
+       (do-bind lhs* rhs* si live env env body Value)]
+      [(fix lhs* rhs* body)
+       (do-fix lhs* rhs* si live env body Value)]
+      [(conditional e0 e1 e2)
+       (do-cond e0 si live env e1 e2 Value)]
+      [(seq e0 e1)   (do-seq e0 si live env e1 Value)]
+      [(closure label free*)
+       (values (do-closure label free* si live env) 0 #f)]
+      [(forcall)     (do-forcall x si live env)]
+      [(funcall)     (do-value-funcall x si live env)]
+      [(jmpcall)     (do-value-jmpcall x si live env)]
+      [(appcall)     (do-value-appcall x si live env)]
+      [(mvcall)      (do-mvcall x si live env Value)]
+      [else (error who "invalid value expr ~s" x)]))
+  ;;;
+  (define (Pred x si live env)
+    (record-case x
+      [(constant t) 
+       (values (if t #t #f) 0 #f)]
+      [(var) (values (make-cmp 'neq (Var x env) false-object) 0 #f)]
+      [(primref)  (values #t 0 #f)]
+      [(bind lhs* rhs* body)  
+       (do-bind lhs* rhs* si live env env body Pred)]
+      [(fix lhs* rhs* body)
+       (do-fix lhs* rhs* si live env body Pred)]
+      [(conditional e0 e1 e2)
+       (do-cond e0 si live env e1 e2 Pred)]
+      [(seq e0 e1) (do-seq e0 si live env e1 Pred)]
+      [(closure label free*)  (values #t 0 #f)]
+      [(forcall)
+       (let-values ([(x msi call?) (Value x si live env)])
+         (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
+      [(funcall)
+       (let-values ([(x msi call?) (Value x si live env)])
+         (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
+      [(jmpcall)
+       (let-values ([(x msi call?) (Value x si live env)])
+         (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
+      [(appcall)
+       (let-values ([(x msi call?) (Value x si live env)])
+         (values (make-seq x (make-cmp 'neq acr false-object)) msi call?))]
+      [(mvcall) (do-mvcall x si live env Pred)]
+      [else (error who "invalid pred expr ~s" x)]))
+  ;;;
+  (define (Effect x si live env)
+    (record-case x
+      [(constant) (values 'nop 0 #f)]
+      [(var)      (values 'nop 0 #f)]
+      [(primref)  (values 'nop 0 #f)]
+      [(bind lhs* rhs* body)  
+       (do-bind lhs* rhs* si live env env body Effect)]
+      [(fix lhs* rhs* body)
+       (do-fix lhs* rhs* si live env body Effect)]
+      [(conditional e0 e1 e2)
+       (do-cond e0 si live env e1 e2 Effect)]
+      [(seq e0 e1)   (do-seq e0 si live env e1 Effect)]
+      [(closure label free*)  (values 'nop 0 #f)]
+      [(forcall)     (do-forcall x si live env)]
+      [(funcall)     (do-effect-funcall x si live env)]
+      [(jmpcall)     (do-effect-jmpcall x si live env)]
+      [(appcall)     (do-effect-appcall x si live env)]
+      [(mvcall)      (do-mvcall x si live env Tail)]
+      [else (error who "invalid effect expr ~s" x)]))
+  ;;;
+  (define (Tail x si live env)
+    (record-case x
+      [(constant)    (values x si #f)]
+      [(var)         (values (Var x env) si #f)]
+      [(primref)     (values x si #f)]
+      [(bind lhs* rhs* body)  
+       (do-bind lhs* rhs* si live env env body Tail)]
+      [(fix lhs* rhs* body)
+       (do-fix lhs* rhs* si live env body Tail)]
+      [(conditional e0 e1 e2) 
+       (do-cond e0 si live env e1 e2 Tail)]
+      [(seq e0 e1)   (do-seq e0 si live env e1 Tail)]
+      [(closure label free*)  
+       (values (do-closure label free* si live env) si #f)]
+      [(forcall)
+       (let-values ([(x msi call?) (do-forcall x si live env)])
+         (values x msi call?))]
+      [(funcall)     (do-tail-funcall x si live env)]
+      [(jmpcall)     (do-tail-jmpcall x si live env)]
+      [(appcall)     (do-tail-appcall x si live env)]
+      [(mvcall)      (do-mvcall x si live env Tail)]
+      [else (error who "invalid tail expr ~s" x)]))
+  ;;;
+  (define (MainTail x si live env)
+    (let-values ([(x msi call?) 
+                  (Tail x si live env)])
+      (if call?
+          (make-seq 'FIXME:stack-overflow-check x)
+          x)))
+  (define (ClambdaCase free*)
+    (define (bind-free ls)
+      (let f ([ls ls] [i 0] [env '()])
+        (cond
+          [(null? ls) env]
+          [else
+           (f (cdr ls) (fxadd1 i)
+              (cons (cons (car ls) (make-cpvar i)) env))])))
+    (define (do-info x env)
+      (record-case x 
+        [(case-info label args proper)
+         (let f ([ls args] [env env] [si 0] [live '()])
+           (cond
+             [(null? ls) (values env si live)]
+             [else
+              (let ([fv (make-fvar si)])
+                (f (cdr ls)
+                   (cons (cons (car ls) fv) env)
+                   (fxadd1 si)
+                   (cons si live)))]))]))
+    (let ([env (bind-free free*)])
+      (lambda (x)
+        (record-case x
+          [(clambda-case info body)
+           (let-values ([(env si live) (do-info info env)])
+             (make-clambda-case info (MainTail body si live env)))]
+          [else (error who "invalid clambda-case ~s" x)]))))
+  ;;;
+  (define (Clambda x)
+    (record-case x
+      [(clambda label case* free*)
+       (make-clambda label (map (ClambdaCase free*) case*) free*)]
+      [else (error who "invalid clambda ~s" x)]))
+  ;;;
+  (define (Program x)
+    (record-case x 
+      [(codes code* body)
+       (make-codes (map Clambda code*) (MainTail body 0 '() '()))]
+      [else (error who "invalid program ~s" x)]))
+  ;;;
+  (Program x))
+
+
+
 
 
 (define (new-cogen x)
   (verify-new-cogen-input x)
   (let ([x (remove-primcalls x)])
-    x))
+    (new-cogen-pass1 x)))
 
 
 

src/libcompile.ss

@@ -5146,7 +5146,10 @@
 (primitive-set! 'compile
   (lambda (x)
     (let ([code 
-           (if (code? x) x (compile-expr x))])
+           (if (code? x)
+               x
+               (parameterize ([expand-mode 'eval])
+                 (compile-expr x)))])
       (let ([proc ($code->closure code)])
         (proc)))))
 

src/makefile.ss

@@ -52,7 +52,7 @@
     top-level-value set-top-level-value!  top-level-bound?
     gensym gensym-count gensym-prefix print-gensym
     gensym->unique-string call-with-values values make-parameter
-    dynamic-wind display write print-graph fasl-write printf format
+    dynamic-wind display write print-graph fasl-write printf fprintf format
     print-error read-token read comment-handler error exit call/cc
     error-handler eval current-eval compile compile-file
     new-cafe load system expand sc-expand current-expand expand-mode
@@ -78,6 +78,7 @@
     console-input-port current-input-port standard-output-port
     standard-error-port console-output-port current-output-port
     open-output-file open-input-file open-output-string
+    with-output-to-string
     get-output-string with-output-to-file call-with-output-file
     with-input-from-file call-with-input-file date-string
     file-exists? delete-file + - add1 sub1 * / expt 

src/psyntax-7.1.ss

@@ -3826,7 +3826,7 @@
 
 (primitive-set! 'expand-mode
   (make-parameter
-    'eval
+    'compile
     (lambda (x)
       (unless (memq x '(eval compile bootstrap))
         (error 'expand-mode "~s is not a valid mode" x))