* libtoplevel.ss is now using libraries only

src/libtoplevel.ss

@@ -1,6 +1,142 @@
 
+
+(library (flush me top-level-and-module-init)
+  (export)
+  (import (scheme))
+
+;;; this junk should all go away soon
 ;;; this file is one big hack that initializes the whole system.
 
+(define (macros)
+  '(|#primitive| lambda case-lambda set! quote begin define if letrec
+    foreign-call ;$apply
+    quasiquote unquote unquote-splicing
+    define-syntax identifier-syntax let-syntax letrec-syntax
+    fluid-let-syntax alias meta eval-when with-implicit with-syntax
+    type-descriptor
+    syntax-case syntax-rules module $module import $import import-only
+    syntax quasisyntax unsyntax unsyntax-splicing datum
+    let let* let-values cond case define-record or and when unless do
+    include parameterize trace untrace trace-lambda trace-define
+    rec library
+    time))
+
+(define (public-primitives)
+  '(
+    null? pair? char? fixnum? bignum? symbol? gensym? string? vector? list?
+    boolean? procedure?  not eof-object eof-object? bwp-object?
+    void fx= fx< fx<= fx> fx>= fxzero?  fx+ fx- fx* fxadd1 fxsub1
+    fxquotient fxremainder fxmodulo fxsll fxsra fxlognot fxlogor
+    fxlogand fxlogxor integer->char char->integer char=? char<?
+    char<=? char>? char>=?  cons car cdr set-car! set-cdr!  caar
+    cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
+    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
+    cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list list*
+    make-list length list-ref append make-vector vector-ref
+    vector-set! vector-length vector vector->list list->vector
+    make-string string-ref string-set! string-length string
+    string->list list->string uuid string-append substring string=?
+    string<?  string<=? string>? string>=? remprop putprop getprop
+    property-list $$apply apply map for-each andmap ormap memq memv assq
+    assv assoc eq? eqv? equal? reverse string->symbol symbol->string
+    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 fprintf format
+    print-error read-token read comment-handler error warning exit call/cc
+    error-handler eval current-eval compile alt-compile compile-file
+    alt-compile-file
+    new-cafe load system expand sc-expand current-expand expand-mode
+    environment? interaction-environment identifier?
+    free-identifier=? bound-identifier=? literal-identifier=?
+    datum->syntax-object syntax-object->datum syntax-error
+    syntax->list generate-temporaries record? record-set! record-ref
+    record-length record-type-descriptor make-record-type
+    record-printer record-name record-field-accessor
+    record-field-mutator record-predicate record-constructor
+    record-type-name record-type-symbol record-type-field-names
+    hash-table? make-hash-table get-hash-table put-hash-table!
+    assembler-output $make-environment features
+    command-line-arguments port? input-port? output-port?
+    make-input-port make-output-port make-input/output-port
+    port-handler port-input-buffer port-input-index port-input-size
+    port-output-buffer port-output-index port-output-size
+    set-port-input-index! set-port-input-size!
+    set-port-output-index! set-port-output-size!  port-name
+    input-port-name output-port-name write-char read-char
+    unread-char peek-char newline reset-input-port!
+    flush-output-port close-input-port close-output-port
+    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
+    open-input-string
+    with-input-from-file call-with-input-file date-string
+    file-exists? delete-file + - add1 sub1 * / expt 
+    quotient+remainder quotient remainder modulo number? positive?
+    negative? zero? number->string logand = < > <= >=
+    last-pair
+    make-guardian weak-cons collect 
+    interrupt-handler
+    time-it 
+    posix-fork fork waitpid env environ
+    pretty-print
+    even? odd? member char-whitespace? char-alphabetic?
+    char-downcase max min complex? real? rational? 
+    exact? inexact? integer?
+    string->number exact->inexact
+    flonum? flonum->string string->flonum
+    sin cos atan sqrt
+    ))
+
+(define (system-primitives)
+  '(
+    $primitive-call/cc
+    $closure-code immediate? $unbound-object? $forward-ptr?
+    pointer-value primitive-ref primitive-set!  $fx= $fx< $fx<= $fx>
+    $fx>= $fxzero?  $fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient
+    $fxremainder $fxmodulo $fxsll $fxsra $fxlognot $fxlogor
+    $fxlogand $fxlogxor $fixnum->char $char->fixnum $char= $char<
+    $char<= $char> $char>= $car $cdr $set-car! $set-cdr!
+    $make-vector $vector-ref $vector-set! $vector-length
+    $make-string $string-ref $string-set!  $string-length $string
+    $symbol-string $symbol-unique-string $symbol-value
+    $set-symbol-string! $set-symbol-unique-string!
+    $set-symbol-value! $set-symbol-function! $make-symbol $set-symbol-plist!
+    $symbol-plist $sc-put-cte $record? $record/rtd? $record-set!
+    $record-ref $record-rtd $make-record $record $base-rtd $code?
+    $code-reloc-vector $code-freevars $code-size $code-ref
+    $code-set!  $code->closure list*->code* make-code code?
+    set-code-reloc-vector!  code-reloc-vector code-freevars
+    code-size code-ref code-set!  $frame->continuation $fp-at-base
+    $current-frame $arg-list $seal-frame-and-call
+    $make-call-with-values-procedure $make-values-procedure
+    do-overflow $make-tcbucket $tcbucket-next $tcbucket-key
+    $tcbucket-val $set-tcbucket-next!  $set-tcbucket-val!
+    $set-tcbucket-tconc!  
+    call/cf
+    trace-symbol! untrace-symbol!  make-traced-procedure
+    fixnum->string 
+    $interrupted? $unset-interrupted! $do-event
+    $fasl-read
+    ;;; TODO: must open-code
+    $make-port/input $make-port/output $make-port/both
+    $make-input-port $make-output-port $make-input/output-port
+    $port-handler $port-input-buffer $port-input-index
+    $port-input-size $port-output-buffer $port-output-index
+    $port-output-size $set-port-input-index! $set-port-input-size!
+    $set-port-output-index! $set-port-output-size!
+    ;;; better open-code
+    $write-char $read-char $peek-char $unread-char
+    ;;; never open-code 
+    $reset-input-port! $close-input-port $close-output-port
+    $flush-output-port *standard-output-port* *standard-error-port*
+    *current-output-port* *standard-input-port* *current-input-port*
+    ;;; 
+    compile-core-expr-to-port
+    compiler-giveup-tally
+    ))
 
 ;;; first, it defines all public primitives to their primref values.
 ;;;       (cross your fingers they're all defined in code)
@@ -49,7 +185,7 @@
                           (vector '(top))
                           (vector (getprop x '|#system|))))))
   (define (make-module stx* name)
-    `($module . #(interface (top) ,(list->vector stx*) ,name)))
+    (cons '$module (vector 'interface '(top) (list->vector stx*) name)))
   (putprop '|#system| '|#system| gsys)
   (putprop 'scheme  '|#system| gsch)
   (putprop 'scheme '*scheme* gsch)
@@ -65,7 +201,7 @@
       (putprop gsys '*sc-expander* sysmod)
       (putprop '|#system| '*sc-expander* sysmod)
       (putprop 'scheme '*sc-expander* schmod))))
-
+)
 
 ;;; Finally, we're ready to evaluate the files and enter the cafe.
 (library (ikarus interaction)

src/syntax.ss

@@ -20,7 +20,12 @@
     ;  (syntax-rules ()
     ;    [(_ f ls ls* ...)
     ;     (my-map '(map f ls ls* ...) f ls ls* ...)]))
-
+    (define-syntax build-let
+      (syntax-rules ()
+        [(_ ae lhs* rhs* body)
+         (build-application ae
+           (build-lambda ae lhs* body)
+           rhs*)]))
     (define who 'chi-top-library)
     (define-syntax assert
       (syntax-rules ()
@@ -281,22 +286,27 @@
                       (values 'other #f #f)))])))
     (define parse-library 
       (lambda (e)
-        (syntax-case e ()
+        (syntax-match e 
           [(_ (name name* ...)
               (export exp* ...)
               (import (scheme))
               b* ...)
-           (and (eq? #'export 'export)
+           (if (and (eq? export 'export)
-                (eq? #'import 'import)
+                    (eq? import 'import)
-                (eq? #'scheme 'scheme)
+                    (eq? scheme 'scheme)
-                (symbol? #'name)
+                    (symbol? name)
-                (andmap symbol? #'(name* ...))
+                    (andmap symbol? name*)
-                (andmap symbol? #'(exp* ...)))
+                    (andmap symbol? exp*))
-           (values #'(name name* ...) #'(exp* ...) #'(b* ...))]
+               (values (cons name name*) exp* b*)
+               (error who "malformed library ~s" e))]
           [_ (error who "malformed library ~s" e)])))
-    (define stx-error
+    (define-syntax stx-error 
-      (lambda (stx . args)
+      (syntax-rules ()
-        (error 'chi "invalid syntax ~s" (strip stx '()))))
+        [(_ stx) (error 'chi "invalid syntax ~s" (strip stx '()))]
+        [(_ stx msg) (error 'chi "~a: ~s" msg (strip stx '()))]))
+    ;(define stx-error
+    ;  (lambda (stx . args)
+    ;    (error 'chi "invalid syntax ~s" (strip stx '()))))
     (define-syntax syntax-match-test
       (lambda (stx)
         (define dots?
@@ -466,11 +476,13 @@
            (if (id? id) 
                (values id (cons 'expr val))
                (stx-error x))])))
-    (define scheme-env
+    (define scheme-env ; the-env
       '([define     define-label     (define)]
         [quote      quote-label      (core-macro . quote)]
+        [lambda     lambda-label     (core-macro . lambda)]
         [let-values let-values-label (core-macro . let-values)]
         [let        let-label        (core-macro . let)]
+        [let*       let*-label       (core-macro . let*)]
         [cond       cond-label       (core-macro . cond)]
         [cons       cons-label       (core-prim . cons)]
         [values     values-label     (core-prim . values)]
@@ -482,8 +494,19 @@
         [new-cafe   new-cafe-label   (core-prim . new-cafe)]
         [load       load-label       (core-prim . load)]
         [for-each   for-each-label   (core-prim . for-each)]
+        [map        map-label        (core-prim . map)]
         [display    display-label    (core-prim . display)]
+        [gensym     gensym-label     (core-prim . gensym)]
+        [getprop    getprop-label    (core-prim . getprop)]
+        [putprop    putprop-label    (core-prim . putprop)]
+        [vector     vector-label     (core-prim . vector)]
+        [list       list-label       (core-prim . list)]
+        [append     append-label     (core-prim . append)]
+        [list->vector list->vector-label (core-prim . list->vector)]
+        [symbol->string symbol->string-label (core-prim .  symbol->string)]
         [current-eval current-eval-label (core-prim . current-eval)]
+        [primitive-ref primitive-ref-label (core-prim .  primitive-ref)]
+        [$set-symbol-value! $set-symbol-value!-label (core-prim .  $set-symbol-value!)]
         [compile    compile-label    (core-prim . compile)]
         [printf     printf-label     (core-prim . printf)]
         [string=?   string=?-label   (core-prim . string=?)]
@@ -538,6 +561,36 @@
                            (build-lambda no-source '() (car rhs*))
                            (build-lambda no-source (car lex**) 
                              (f (cdr lex**) (cdr rhs*)))))])))))])))
+    (define let*-transformer
+      (lambda (e r mr)
+        (syntax-match e
+          [(_ ([lhs* rhs*] ...) b b* ...)
+           (let f ([lhs* lhs*] [rhs* rhs*]
+                   [subst-lhs* '()] [subst-lab* '()]
+                   [r r])
+             (cond
+               [(null? lhs*) 
+                (chi-internal
+                  (add-subst 
+                    (id/label-rib subst-lhs* subst-lab*)
+                    (cons b b*))
+                  r mr)]
+               [else
+                (let ([lhs (car lhs*)]
+                      [rhs (chi-expr
+                             (add-subst
+                               (id/label-rib subst-lhs* subst-lab*)
+                               (car rhs*))
+                             r mr)])
+                  (unless (id? lhs)
+                    (stx-error lhs "invalid binding"))
+                  (let ([lex (gen-lexical lhs)]
+                        [lab (gen-label lhs)])
+                    (build-let no-source (list lex) (list rhs)
+                      (f (cdr lhs*) (cdr rhs*)
+                         (cons lhs subst-lhs*) 
+                         (cons lab subst-lab*)
+                         (add-lexicals (list lab) (list lex) r)))))]))])))
     (define let-transformer
       (lambda (e r mr)
         (syntax-match e
@@ -628,12 +681,22 @@
       (lambda (e r mr)
         (syntax-match e
           [(_ datum) (build-data no-source (strip datum '()))])))
+    (define lambda-transformer
+      (lambda (e r mr)
+        (syntax-match e
+          [(_ fmls b b* ...)
+           (let-values ([(fmls body) 
+                         (chi-lambda-clause fmls 
+                            (cons b b*) r mr)])
+             (build-lambda no-source fmls body))])))
     (define core-macro-transformer
       (lambda (name)
         (case name
           [(quote)      quote-transformer]
+          [(lambda)     lambda-transformer]
           [(let-values) let-values-transformer]
           [(let)        let-transformer]
+          [(let*)       let*-transformer]
           [(cond)       cond-transformer]
           [else (error 'macro-transformer "cannot find ~s" name)])))
     ;;; chi procedures
@@ -664,13 +727,62 @@
                (build-data no-source datum))]
             [else (error 'chi-expr "invalid type ~s for ~s" type
                          (strip e '())) (stx-error e)]))))
+    (define chi-lambda-clause
+      (lambda (fmls body* r mr)
+        (syntax-match fmls
+          [(x* ...) 
+           (if (valid-bound-ids? x*) 
+               (let ([lex* (map gen-lexical x*)]
+                     [lab* (map gen-label x*)])
+                 (values
+                   lex*
+                   (chi-internal 
+                     (add-subst 
+                       (id/label-rib x* lab*)
+                       body*)
+                     (add-lexicals lab* lex* r)
+                     mr)))
+               (stx-error fmls "invalid fmls"))]
+          [(x* ... . x)
+           (if (valid-bound-ids? (cons rest x*)) 
+               (let ([lex* (map gen-lexical x*)]
+                     [lab* (map gen-label x*)]
+                     [lex (gen-lexical x)]
+                     [lab (gen-label x)])
+                 (values
+                   (append lex* lex)
+                   (chi-internal 
+                     (add-subst 
+                       (id/label-rib (cons x x*) (cons lab lab*))
+                       body*)
+                     (add-lexicals (cons lab lab*)
+                                   (cons lex lex*)
+                                   r)
+                     mr)))
+               (stx-error fmls "invalid fmls"))]
+          [_ (stx-error fmls "invalid fmls")])))
+    (define chi-rhs*
+      (lambda (rhs* r mr)
+        (map (lambda (rhs) 
+               (case (car rhs)
+                 [(defun) 
+                  (let ([x (cdr rhs)])
+                    (let ([fmls (car x)] [body* (cdr x)])
+                      (let-values ([(fmls body) 
+                                    (chi-lambda-clause fmls body* r mr)])
+                        (build-lambda no-source fmls body))))]
+                 [(expr) 
+                  (let ([expr (cdr rhs)])
+                    (chi-expr expr r mr))]
+                 [else (error 'chi-rhs "invalid rhs ~s" rhs)]))
+             rhs*)))
     (define chi-internal
       (lambda (e* r mr)
         (define return
           (lambda (init* r mr lhs* lex* rhs*)
             (unless (valid-bound-ids? lhs*) 
               (error 'chi-internal "multiple definitions"))
-            (let ([rhs* (chi-expr* rhs* r mr)]
+            (let ([rhs* (chi-rhs* rhs* r mr)]
                   [init* (chi-expr* init* r mr)])
               (build-letrec no-source 
                  (reverse lex*) (reverse rhs*) 
@@ -691,10 +803,10 @@
                           (when (bound-id-member? id kwd*) 
                             (stx-error id "undefined identifier"))
                           (let ([lex (gen-lexical id)]
-                                [label   (gen-label)])
+                                [lab  (gen-label id)])
-                            (extend-rib! rib id label)
+                            (extend-rib! rib id lab)
                             (f (cdr e*)
-                               (cons (cons label (cons 'lexical lex)) r)
+                               (cons (cons lab (cons 'lexical lex)) r)
                                mr 
                                (cons id lhs*)
                                (cons lex lex*)
@@ -705,11 +817,11 @@
     (define chi-library-internal 
       (lambda (e* r rib)
         (define return
-          (lambda (init* r mr lhs* rhs*)
+          (lambda (init* r mr lhs* lex* rhs*)
-            (values init* r mr (reverse lhs*) (reverse rhs*))))
+            (values init* r mr (reverse lhs*) (reverse lex*) (reverse rhs*))))
-        (let f ([e* e*] [r r] [mr r] [lhs* '()] [rhs* '()] [kwd* '()])
+        (let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()])
           (cond
-            [(null? e*) (return e* r mr lhs* rhs*)]
+            [(null? e*) (return e* r mr lhs* lex* rhs*)]
             [else
              (let ([e (car e*)])
                (let-values ([(type value kwd) (syntax-type e r)])
@@ -719,27 +831,31 @@
                       (let-values ([(id rhs) (parse-define e)])
                         (when (bound-id-member? id kwd*) 
                           (stx-error id "undefined identifier"))
-                        (let ([lexical (gen-lexical (id->sym id))]
+                        (let ([lex (gen-lexical id)]
-                              [label   (gen-label)])
+                              [lab (gen-label id)])
-                          (extend-rib! rib id label)
+                          (extend-rib! rib id lab)
-                          (f (cdr e*) r mr (cons id lhs*) (cons rhs rhs*)
+                          (f (cdr e*)
+                             (cons (cons lab (cons 'lexical lex)) r)
+                             mr 
+                             (cons id lhs*) (cons lex lex*) (cons rhs rhs*)
                              kwd*)))]
                      [else 
-                      (return e* r mr lhs* rhs*)]))))]))))
+                      (return e* r mr lhs* lex* rhs*)]))))]))))
     (define chi-top-library
       (lambda (e)
         (let-values ([(name exp* b*) (parse-library e)])
           (let ([rib (make-scheme-rib)]
                 [r (make-scheme-env)])
             (let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)])
-              (let-values ([(init* r mr lhs* rhs*)
+              (let-values ([(init* r mr lhs* lex* rhs*)
                             (chi-library-internal b* r rib)])
-                (unless (null? lhs*)
+                (build-letrec no-source
-                  (error who "cannot handle definitions yet"))
+                  lex* 
-                (if (null? init*) 
+                  (chi-rhs* rhs* r mr)
-                    (chi-void)
+                  (if (null? init*) 
-                    (build-sequence no-source 
+                      (chi-void)
-                      (chi-expr* init* r mr)))))))))
+                      (build-sequence no-source 
+                        (chi-expr* init* r mr))))))))))
     (lambda (x) 
       (let ([x (chi-top-library x)])
     ;    (pretty-print x)