diff --git a/src/ikarus.boot b/src/ikarus.boot index 269c7c8..f675f23 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libtoplevel.ss b/src/libtoplevel.ss index 2043091..e826532 100644 --- a/src/libtoplevel.ss +++ b/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>=? 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>=? 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) diff --git a/src/syntax.ss b/src/syntax.ss index 6afc4ff..ffcb74e 100644 --- a/src/syntax.ss +++ b/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) - (eq? #'import 'import) - (eq? #'scheme 'scheme) - (symbol? #'name) - (andmap symbol? #'(name* ...)) - (andmap symbol? #'(exp* ...))) - (values #'(name name* ...) #'(exp* ...) #'(b* ...))] + (if (and (eq? export 'export) + (eq? import 'import) + (eq? scheme 'scheme) + (symbol? name) + (andmap symbol? name*) + (andmap symbol? exp*)) + (values (cons name name*) exp* b*) + (error who "malformed library ~s" e))] [_ (error who "malformed library ~s" e)]))) - (define stx-error - (lambda (stx . args) - (error 'chi "invalid syntax ~s" (strip stx '())))) + (define-syntax stx-error + (syntax-rules () + [(_ 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)]) - (extend-rib! rib id label) + [lab (gen-label id)]) + (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*) - (values init* r mr (reverse lhs*) (reverse rhs*)))) - (let f ([e* e*] [r r] [mr r] [lhs* '()] [rhs* '()] [kwd* '()]) + (lambda (init* r mr lhs* lex* rhs*) + (values init* r mr (reverse lhs*) (reverse lex*) (reverse rhs*)))) + (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))] - [label (gen-label)]) - (extend-rib! rib id label) - (f (cdr e*) r mr (cons id lhs*) (cons rhs rhs*) + (let ([lex (gen-lexical id)] + [lab (gen-label id)]) + (extend-rib! rib id lab) + (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*) - (error who "cannot handle definitions yet")) - (if (null? init*) - (chi-void) - (build-sequence no-source - (chi-expr* init* r mr))))))))) + (build-letrec no-source + lex* + (chi-rhs* rhs* r mr) + (if (null? init*) + (chi-void) + (build-sequence no-source + (chi-expr* init* r mr)))))))))) (lambda (x) (let ([x (chi-top-library x)]) ; (pretty-print x)