diff --git a/src/ikarus.boot b/src/ikarus.boot index dc4bebd..b32f2e2 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.cafe.ss b/src/ikarus.cafe.ss index a744e67..d2cef9f 100644 --- a/src/ikarus.cafe.ss +++ b/src/ikarus.cafe.ss @@ -25,7 +25,7 @@ description: (library (ikarus cafe) (export new-cafe) (import - (only (ikarus syntax) eval-top-level) + (only (psyntax expander) eval-top-level) (except (ikarus) new-cafe)) (define with-error-handler diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index f0065ab..83f8e65 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -153,6 +153,8 @@ (define (Var x) (or (getprop x *cookie*) (error 'recordize "unbound ~s" x))) + (define (lexical x) + (getprop x *cookie*)) (define (E x) (cond [(pair? x) @@ -165,7 +167,14 @@ (E (cadddr x)))] [(set!) (let ([lhs (cadr x)] [rhs (caddr x)]) - (make-assign (Var lhs) (E rhs)))] + (cond + [(lexical lhs) => + (lambda (lhs) + (make-assign lhs (E rhs)))] + [else + (make-funcall (make-primref '$init-symbol-value!) + (list (make-constant lhs) + (E rhs)))]))] [(begin) (let f ([a (E (cadr x))] [d (cddr x)]) (cond @@ -210,6 +219,9 @@ [(|#primitive|) (let ([var (cadr x)]) (make-primref var))] + [(primitive) + (let ([var (cadr x)]) + (make-primref var))] [(top-level-value) (let ([var (quoted-sym (cadr x))]) (make-funcall @@ -222,7 +234,11 @@ (make-constant (void))] [else (make-funcall (E (car x)) (map E (cdr x)))])] - [(symbol? x) (Var x)] + [(symbol? x) + (or (lexical x) + (make-funcall + (make-primref 'top-level-value) + (list (make-constant x))))] [else (error 'recordize "invalid expression ~s" x)])) (E x)) diff --git a/src/ikarus.load.ss b/src/ikarus.load.ss index 854868b..e164131 100644 --- a/src/ikarus.load.ss +++ b/src/ikarus.load.ss @@ -3,7 +3,7 @@ (export load load-r6rs-top-level) (import (except (ikarus) load) - (only (ikarus syntax) eval-top-level eval-r6rs-top-level) + (only (psyntax expander) eval-top-level eval-r6rs-top-level) (only (ikarus reader) read-initial)) (define load-handler diff --git a/src/makefile.ss b/src/makefile.ss index c67682d..ac940d2 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -63,8 +63,13 @@ "ikarus.fasl.write.ss" "ikarus.fasl.ss" "ikarus.compiler.ss" + "psyntax.compat.ss" "psyntax.library-manager.ss" - "ikarus.syntax.ss" + ;"ikarus.syntax.ss" + "psyntax.internal.ss" + "psyntax.config.ss" + "psyntax.builders.ss" + "psyntax.expander.ss" "ikarus.load.ss" "ikarus.pretty-print.ss" "ikarus.cafe.ss" @@ -189,6 +194,7 @@ [$stack (ikarus system $stack) #f #t] [$interrupts (ikarus system $interrupts) #f #t] [$all (ikarus system $all) #f #t] + [$all2 (psyntax system $all) #f #t] [$boot (ikarus system $bootstrap) #f #t] )) @@ -423,6 +429,7 @@ [$set-symbol-string! $symbols] [$set-symbol-unique-string! $symbols] [$set-symbol-plist! $symbols] + [$init-symbol-value! ] [$unbound-object? $symbols] [base-rtd $records] [$record-set! $records] @@ -1216,715 +1223,6 @@ [syntax-error i sc] )) -#; -(define identifier->library-map - '([define i r ne] - [define-syntax i r ne] - [let-syntax i r ne] - [letrec-syntax i r ne] - [module i cm] - [begin i r ne] - [import i] - [set! i r ne] - [foreign-call i] - [quote i r ne] - [syntax-case i sc] - [syntax i sc] - [lambda i r ne] - [case-lambda i r] - [type-descriptor i ] - [letrec i r ne] - [letrec* i r] - [if i r ne] - [when i r] - [unless i r] - [parameterize i parameters] - [case i r ne] - [let-values i r] - [define-record i r] - [include i r] - [syntax-rules i r ne] - [quasiquote i r ne] - [quasisyntax i sc] - [with-syntax i sc] - [let i r ne] - [identifier-syntax i r] - [let* i r ne] - [cond i r ne] - [do i r ne] - [and i r ne] - [or i r ne] - [time i] - [delay i ne] - [endianness i ] - [assert i r] - [... i r ne] - [=> i r ne] - [else i r ne] - [_ i r ne] - [unquote i r ne] - [unquote-splicing i r ne] - [unsyntax i r] - [unsyntax-splicing i r] - [trace-lambda i] - [trace-define i] - [void i] - [not i r] - [boolean? i r] - [boolean=? i r] - [null? i r] - [procedure? i r] - [eof-object? i r] - [eof-object i] - [eq? i r] - [eqv? i r] - [equal? i r] - [cons i r] - [pair? i r] - [car i r] - [cdr i r] - [set-car! i mp] - [set-cdr! i mp] - [caar i r] - [cdar i r] - [cadr i r] - [cddr i r] - [caaar i r] - [cdaar i r] - [cadar i r] - [cddar i r] - [caadr i r] - [cdadr i r] - [caddr i r] - [cdddr i r] - [caaaar i r] - [cdaaar i r] - [cadaar i r] - [cddaar i r] - [caadar i r] - [cdadar i r] - [caddar i r] - [cdddar i r] - [caaadr i r] - [cdaadr i r] - [cadadr i r] - [cddadr i r] - [caaddr i r] - [cdaddr i r] - [cadddr i r] - [cddddr i r] - [list i r] - [list-ref i r] - [list-tail i r] - [make-list i r] - [cons* i r] - [list? i r] - [append i r] - [last-pair i r] - [reverse i r] - [length i r] - [assq i r] - [assp i r] - [assv i r] - [assoc i r] - [memq i r] - [memp i r] - [memv i r] - [member i r] - [remq i] - [remp i] - [remv i] - [remove i] - [filter i] - [find i] - [partition i] - [list-sort i] - [vector-sort i] - [vector-sort! i] - [bwp-object? i] - [weak-cons i] - [weak-pair? i] - [char? i r] - [char=? i r] - [char? i r] - [char<=? i r] - [char>=? i r] - [integer->char i r] - [char->integer i r] - [char-downcase i uc] - [char-upcase i uc] - [char-titlecase i uc] - [char-foldcase i uc] - [char-ci=? i uc] - [char-ci? i uc] - [char-ci>=? i uc] - [char-alphabetic? i uc] - [char-numeric? i uc] - [char-whitespace? i r uc] - [char-upper-case? i uc] - [char-lower-case? i uc] - [char-title-case? i uc] - [string? i r] - [string i r] - [make-string i r] - [string-ref i r] - [string-set! i r] - [string-fill! i r] - [string-length i r] - [string=? i r] - [string? i r] - [string>=? i r] - [string-ci=? i uc] - [string-ci? i uc] - [string-ci>=? i uc] - [substring i r] - [string-copy i r] - [string-append i r] - [string->list i r] - [list->string i r] - [string-foldcase i uc] - [string-for-each i r] - [uuid i] - [date-string i] - [vector i r] - [make-vector i r] - [vector-ref i r] - [vector-set! i r] - [vector-fill! i r] - [vector? i r] - [vector-length i r] - [list->vector i r] - [vector->list i r] - [vector-map i r] - [vector-for-each i r] - [make-bytevector i] - [bytevector-length i] - [bytevector-s8-ref i] - [bytevector-u8-ref i] - [bytevector-s8-set! i] - [bytevector-u8-set! i] - [bytevector-u16-ref i] - [bytevector-u16-set! i] - [bytevector-u32-ref i] - [bytevector-u32-set! i] - [bytevector-s32-ref i] - [bytevector-s32-set! i] - [bytevector-s16-ref i] - [bytevector-s16-set! i] - [bytevector-u16-native-ref i] - [bytevector-u16-native-set! i] - [bytevector-s16-native-ref i] - [bytevector-s16-native-set! i] - [bytevector-u32-native-ref i] - [bytevector-u32-native-set! i] - [bytevector-s32-native-ref i] - [bytevector-s32-native-set! i] - [bytevector->u8-list i] - [u8-list->bytevector i] - [bytevector-copy! i] - [bytevector-copy i] - [bytevector-fill! i] - [bytevector=? i] - [bytevector-uint-ref i] - [bytevector-sint-ref i] - [bytevector-uint-set! i] - [bytevector-sint-set! i] - [bytevector->uint-list i] - [bytevector->sint-list i] - [uint-list->bytevector i] - [sint-list->bytevector i] - [string->utf8-bytevector i] - [utf8-bytevector->string i] - [native-endianness i] - [$two-bignums i] - [fxior i] - [fxand i] - [fxxor i] - [fxnot i] - [fxif i] - [fxeven? i] - [fxodd? i] - [fxpositive? i] - [fxnegative? i] - [fxarithmetic-shift-left i] - [fxarithmetic-shift-right i] - [fxarithmetic-shift i] - [fxmin i] - [fxmax i] - [fixnum-width i] - [least-fixnum i] - [greatest-fixnum i] - [fx+/carry i] - [fx*/carry i] - [fx-/carry i] - [for-each i r] - [map i r] - [andmap i] - [ormap i] - [fixnum? i] - [fx< i] - [fx<= i] - [fx> i] - [fx>= i] - [fx= i] - [fx? i] - [fx>=? i] - [fx=? i] - [fx- i] - [fx+ i] - [fx* i] - [fxzero? i] - [fxadd1 i] - [fxsub1 i] - [fxquotient i] - [fxremainder i] - [fxmodulo i] - [fxsll i] - [fxsra i] - [sra i] - [sll i] - [fxlogand i] - [logand i] - [fxlogxor i] - [fxlogor i] - [fxlognot i] - [bitwise-arithmetic-shift-right i] - [bitwise-arithmetic-shift-left i] - [bitwise-arithmetic-shift i] - [fl=? i fl] - [fl? i fl] - [fl>=? i fl] - [fl+ i fl] - [fl* i fl] - [fl- i fl] - [fl/ i fl] - [flmin i fl] - [flsqrt i fl] - [flzero? i fl] - [flnegative? i fl] - [flpositive? i fl] - [flabs i fl] - [flmax i fl] - [flsin i fl] - [flcos i fl] - [fltan i fl] - [flasin i fl] - [flacos i fl] - [flatan i fl] - [flfloor i fl] - [flround i fl] - [flceiling i fl] - [fltruncate i fl] - [flnumerator i fl] - [fldenominator i fl] - [flexp i fl] - [fllog i fl] - [fixnum->string i] - [string->flonum i] - [- i r] - [= i r] - [< i r] - [> i r] - [<= i r] - [>= i r] - [zero? i r] - [* i r] - [/ i r] - [+ i r] - [add1 i] - [sub1 i] - [expt i r] - [exp i r] - [flexpt i] - [sin i r] - [cos i r] - [tan i r] - [asin i r] - [acos i r] - [atan i r] - [sqrt i r] - [number? i r] - [bignum? i] - [ratnum? i] - [integer? i r] - [real? i r] - [integer-valued? i] - [real-valued? i] - [rational-valued? i] - [flinteger? i] - [flfinite? i] - [flinfinite? i] - [flnan? i] - [fleven? i] - [flodd? i] - [exact? i r] - [inexact? i r] - [rational? i r] - [flonum? i] - [flonum-parts i] - [flonum-bytes i] - [positive? i r] - [negative? i r] - [even? i r] - [odd? i r] - [quotient i r] - [modulo i r] - [remainder i r] - [quotient+remainder i r] - [div i] - [mod i] - [div-and-mod i] - [div0 i] - [mod0 i] - [div0-and-mod0 i] - [number->string i r] - [string->number i r] - [flonum->string i] - [finite? i] - [infinite? i] - [nan? i] - [gcd i r] - [lcm i r] - [max i r] - [min i r] - [abs i r] - [log i r] - [numerator i r] - [denominator i r] - [floor i r] - [ceiling i r] - [round i r] - [truncate i r] - [exact-integer-sqrt i r] - [exact->inexact i r] - [inexact->exact i r] - [fixnum->flonum i r] - [exact i r] - [inexact i r] - [rationalize i] - [random i] - [symbol? i r symbols] - [symbol=? i r symbols] - [gensym? i symbols] - [gensym i symbols] - [getprop i symbols] - [putprop i symbols] - [remprop i symbols] - [property-list i symbols] - [string->symbol i r symbols] - [symbol->string i r symbols] - [gensym->unique-string i symbols] - [symbol-bound? i symbols] - [symbol-value i symbols] - [top-level-value i symbols] - [set-symbol-value! i symbols] - [reset-symbol-proc! i symbols] - [make-guardian i] - [make-input-port i] - [make-output-port i] - [port-output-index i] - [port-output-size i] - [port-output-buffer i] - [set-port-output-index! i] - [set-port-output-size! i] - [port-input-buffer i] - [port-input-index i] - [port-input-size i] - [set-port-input-index! i] - [set-port-input-size! i] - [output-port? i r] - [input-port? i r] - [port? i r] - [port-name i] - [input-port-name i] - [output-port-name i] - [open-input-file i r] - [with-input-from-file i r] - [call-with-input-file i r] - [call-with-output-file i r] - [with-input-from-string i] - [with-output-to-file i r] - [open-output-file i r] - [open-output-string i] - [open-input-string i r] ; r6rs? - [get-output-string i] - [with-output-to-string i] - [close-input-port i r] - [close-output-port i r] - [console-input-port i] - [console-output-port i] - [current-input-port i] - [current-output-port i] - [standard-input-port i] - [standard-output-port i] - [standard-error-port i] - [flush-output-port i] - [reset-input-port! i] - [file-exists? i] - [delete-file i] - [display i r] - [write i r] - [write-char i r] - [write-byte i] - [read i r] - [read-char i r] - [read-token i] - [peek-char i is] - [unread-char i] - [newline i r] - [printf i] - [format i] - [pretty-print i] - [comment-handler i] - [print-gensym i symbols] - [print-graph i] - [print-unicode i] - [char-general-category i] - [gensym-count i symbols] - [gensym-prefix i symbols] - [make-hash-table i] - [hash-table? i] - [get-hash-table i] - [put-hash-table! i] - [make-parameter i parameters] - [apply i r] - [values i r] - [call-with-values i r] - [call/cc i r] - [call-with-current-continuation i r] - [call/cf i] - [dynamic-wind i r] - [error i] - [print-error i] - [error-handler i] - [interrupt-handler i] - [exit i] - [load i] - [assembler-output i] - [new-cafe i] - [eval i ev] - [expand i] - [environment i ev] - [null-environment i] - [environment? i] - [time-it i] - [command-line-arguments i] - [command-line i r] - [record? i] - [make-record-type i] - [record-type-descriptor i] - [record-type-field-names i] - [record-type-symbol i] - [record-type-name i] - [set-rtd-printer! i] - [record-name i] - [record-constructor i] - [record-predicate i] - [record-length i] - [record-printer i] - [record-ref i] - [record-set! i] - [record-field-accessor i] - [record-field-mutator i] - [identifier? i sc] - [syntax-error i sc] - [generate-temporaries i sc] - [free-identifier=? i sc] - [bound-identifier=? i sc] - [syntax->datum i sc] - [datum->syntax i sc] - [make-variable-transformer i sc] - [code? i] - [immediate? i] - [pointer-value i] - [system i] - [installed-libraries i] - [current-primitive-locations $boot] - [boot-library-expand $boot] - [eval-core $boot] - [current-library-collection $boot] - [library-name $boot] - [find-library-by-name $boot] - [$car $pairs] - [$cdr $pairs] - [$set-car! $pairs] - [$set-cdr! $pairs] - [$memq $lists] - [$memv $lists] - [$char? $chars] - [$char= $chars] - [$char< $chars] - [$char> $chars] - [$char<= $chars] - [$char>= $chars] - [$char->fixnum $chars] - [$fixnum->char $chars] - [$make-string $strings] - [$string-ref $strings] - [$string-set! $strings] - [$string-length $strings] - [bytevector? i] - [$make-bytevector $bytes] - [$bytevector-length $bytes] - [$bytevector-s8-ref $bytes] - [$bytevector-u8-ref $bytes] - [$bytevector-set! $bytes] - [$flonum-u8-ref $flonums] - [$make-flonum $flonums] - [$flonum-set! $flonums] - [$flonum-signed-biased-exponent $flonums] - [$flonum-rational? $flonums] - [$flonum-integer? $flonums] - [$fl+ $flonums] - [$fl- $flonums] - [$fl* $flonums] - [$fl/ $flonums] - [$fl= $flonums] - [$fl< $flonums] - [$fl<= $flonums] - [$fl> $flonums] - [$fl>= $flonums] - [$fixnum->flonum $flonums] - [$make-bignum $bignums] - [$bignum-positive? $bignums] - [$bignum-size $bignums] - [$bignum-byte-ref $bignums] - [$bignum-byte-set! $bignums] - [$make-ratnum $rat] - [$ratnum-n $rat] - [$ratnum-d $rat] - [$make-vector $vectors] - [$vector-length $vectors] - [$vector-ref $vectors] - [$vector-set! $vectors] - [$fxzero? $fx] - [$fxadd1 $fx] - [$fxsub1 $fx] - [$fx>= $fx] - [$fx<= $fx] - [$fx> $fx] - [$fx< $fx] - [$fx= $fx] - [$fxsll $fx] - [$fxsra $fx] - [$fxquotient $fx] - [$fxmodulo $fx] - [$fxlogxor $fx] - [$fxlogor $fx] - [$fxlognot $fx] - [$fxlogand $fx] - [$fx+ $fx] - [$fx* $fx] - [$fx- $fx] - [$fxinthash $fx] - [$make-symbol $symbols] - [$symbol-unique-string $symbols] - [$symbol-value $symbols] - [$symbol-string $symbols] - [$symbol-plist $symbols] - [$set-symbol-value! $symbols] - [$set-symbol-proc! $symbols] - [$set-symbol-string! $symbols] - [$set-symbol-unique-string! $symbols] - [$set-symbol-plist! $symbols] - [$unbound-object? $symbols] - [base-rtd $records] - [$record-set! $records] - [$record-ref $records] - [$record-rtd $records] - [$record $records] - [$make-record $records] - [$record? $records] - [$record/rtd? $records] - [$make-port/input $ports] - [$make-port/output $ports] - [$port-handler $ports] - [$port-buffer $ports] - [$port-index $ports] - [$port-size $ports] - [$set-port-index! $ports] - [$set-port-size! $ports] - [$closure-code $codes] - [$code->closure $codes] - [$code-reloc-vector $codes] - [$code-freevars $codes] - [$code-size $codes] - [$code-annotation $codes] - [$code-ref $codes] - [$code-set! $codes] - [$set-code-annotation! $codes] - [procedure-annotation i] - [$make-tcbucket $tcbuckets] - [$tcbucket-key $tcbuckets] - [$tcbucket-val $tcbuckets] - [$tcbucket-next $tcbuckets] - [$set-tcbucket-val! $tcbuckets] - [$set-tcbucket-next! $tcbuckets] - [$set-tcbucket-tconc! $tcbuckets] - [$flush-output-port $io] - [$reset-input-port! $io] - [$close-input-port $io] - [$close-output-port $io] - [$write-char $io] - [$write-byte $io] - [$read-char $io] - [$peek-char $io] - [$unread-char $io] - [$arg-list $arg-list] - [$collect-key $arg-list] - [$$apply $stack] - [$fp-at-base $stack] - [$primitive-call/cc $stack] - [$frame->continuation $stack] - [$current-frame $stack] - [$seal-frame-and-call $stack] - [$make-call-with-values-procedure $stack] - [$make-values-procedure $stack] - [$interrupted? $interrupts] - [$unset-interrupted! $interrupts] - ;;; the following must be defined but they don't have - ;;; to reside in any library since they're here so that - ;;; the compiler can target them. They're not usable - ;;; by the end user. - [$apply-nonprocedure-error-handler ] - [$incorrect-args-error-handler ] - [$multiple-values-error ] - [$debug ] - [$underflow-misaligned-error ] - [top-level-value-error ] - [car-error ] - [cdr-error ] - [fxadd1-error ] - [fxsub1-error ] - [cadr-error ] - [fx+-type-error ] - [fx+-types-error ] - [fx+-overflow-error ] - [$do-event ] - [do-overflow ] - [do-overflow-words ] - [do-vararg-overflow ] - [collect i] - [collect-key i] - [do-stack-overflow ] - [syntax-dispatch ] - [make-promise ] - [force i] - [make-traced-procedure i] - [error@fx+ ] - [fasl-write i] - )) (define (verify-map) (define (f x) @@ -1974,7 +1272,8 @@ (export-primlocs (cons x (cdr binding)))] [else (error #f "invalid binding ~s for ~s" p x)])))] - [else (error #f "cannot find binding for ~s" x)])))] + [else (error #f "cannot find binding for ~s ~s" x + label)])))] [else ;;; core primitive with no backing definition, assumed to ;;; be defined in other strata of the system @@ -2015,7 +1314,7 @@ [visit-libs '()] [invoke-libs '()]) (let-values ([(subst env) - (if (equal? name '(ikarus system $all)) + (if (equal? name '(psyntax system $all)) (values export-subst export-env) (values (get-export-subset key export-subst) @@ -2041,10 +1340,40 @@ (boot-library-expand code)]) code))) +(define (make-init-code) + (define proc (gensym)) + (define loc (gensym)) + (define label (gensym)) + (define sym (gensym)) + (define val (gensym)) + (define args (gensym)) + (values + (list + `((case-lambda + [(,proc) (,proc ',loc ,proc)]) + (case-lambda + [(,sym ,val) + (begin + ((primitive $set-symbol-value!) ,sym ,val) + (if ((primitive procedure?) ,val) + ((primitive $set-symbol-proc!) ,sym ,val) + ((primitive $set-symbol-proc!) ,sym + (case-lambda + [,args + ((primitive error) + 'apply + '"~s is not a procedure" + ((primitive $symbol-value) ,sym))]))))]))) + `([$init-symbol-value! . ,label]) + `([,label . (global . ,loc)]))) + (define (expand-all files) - (let ([code* '()] - [subst '()] - [env '()]) + (define (prune-subst subst env) + (cond + ((null? subst) '()) + ((not (assq (cdar subst) env)) (prune-subst (cdr subst) env)) + (else (cons (car subst) (prune-subst (cdr subst) env))))) + (let-values (((code* subst env) (make-init-code))) (for-each (lambda (file) (printf "expanding ~s\n" file) @@ -2057,7 +1386,7 @@ (set! env (append export-env env)))))) files) (let-values ([(export-subst export-env export-locs) - (make-system-data subst env)]) + (make-system-data (prune-subst subst env) env)]) (let ([code (build-system-library export-subst export-env export-locs)]) (values (reverse (cons* (car code*) code (cdr code*))) diff --git a/src/psyntax.builders.ss b/src/psyntax.builders.ss new file mode 100644 index 0000000..c133838 --- /dev/null +++ b/src/psyntax.builders.ss @@ -0,0 +1,145 @@ +;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(library (psyntax builders) + (export build-lexical-assignment build-global-reference + build-application build-conditional build-lexical-reference + build-global-assignment build-global-definition build-lambda + build-case-lambda build-let build-primref build-foreign-call + build-data build-sequence build-void build-letrec build-letrec* + build-global-define) + (import (rnrs) (psyntax compat) (psyntax config)) + + (define (build-global-define x) + (if-wants-global-defines + `(define ,x '#f) + (build-void))) + (define-syntax build-application + (syntax-rules () + ((_ ae fun-exp arg-exps) + `(,fun-exp . ,arg-exps)))) + (define-syntax build-conditional + (syntax-rules () + ((_ ae test-exp then-exp else-exp) + `(if ,test-exp ,then-exp ,else-exp)))) + (define-syntax build-lexical-reference + (syntax-rules () + ((_ ae var) var))) + (define-syntax build-lexical-assignment + (syntax-rules () + ((_ ae var exp) `(set! ,var ,exp)))) + (define-syntax build-global-reference + (syntax-rules () + ((_ ae var) var))) + (define-syntax build-global-assignment + (syntax-rules () + ((_ ae var exp) `(set! ,var ,exp)))) + (define-syntax build-global-definition + (syntax-rules () + ((_ ae var exp) (build-global-assignment ae var exp)))) + (define build-lambda + (lambda (ae vars exp) + (if-wants-case-lambda + `(case-lambda (,vars ,exp)) + `(lambda ,vars ,exp)))) + (define build-case-lambda + (if-wants-case-lambda + (lambda (ae vars* exp*) + `(case-lambda . ,(map list vars* exp*))) + (lambda (ae vars* exp*) + (define (build-error ae) + (build-application ae + (build-primref ae 'error) + (list (build-data ae 'apply) + (build-data ae "invalid arg count")))) + (define (build-pred ae n vars) + (let-values (((count pred) + (let f ((vars vars) (count 0)) + (cond + ((pair? vars) (f (cdr vars) (+ count 1))) + ((null? vars) (values count '=)) + (else (values count '>=)))))) + (build-application ae (build-primref ae pred) + (list (build-lexical-reference ae n) + (build-data ae count))))) + (define (build-apply ae g vars exp) + (build-application ae (build-primref ae 'apply) + (list (build-lambda ae vars exp) + (build-lexical-reference ae g)))) + (define (expand-case-lambda ae vars exp*) + (let ((g (gensym)) (n (gensym))) + `(lambda ,g + ,(build-let ae + (list n) (list (build-application ae + (build-primref ae 'length) + (list (build-lexical-reference ae g)))) + (let f ((vars* vars*) (exp* exp*)) + (if (null? vars*) + (build-error ae) + (build-conditional ae + (build-pred ae n (car vars*)) + (build-apply ae g (car vars*) (car exp*)) + (f (cdr vars*) (cdr exp*))))))))) + (if (= (length exp*) 1) + (build-lambda ae (car vars*) (car exp*)) + (expand-case-lambda ae vars* exp*))))) + (define build-let + (lambda (ae lhs* rhs* body) + (build-application ae (build-lambda ae lhs* body) rhs*))) + (define-syntax build-primref + (syntax-rules () + ((_ ae name) (build-primref ae 1 name)) + ((_ ae level name) `(primitive ,name)))) + (define-syntax build-foreign-call + (syntax-rules () + ((_ ae name arg*) `(foreign-call ,name . ,arg*)))) + (define-syntax build-data + (syntax-rules () + ((_ ae exp) `',exp))) + (define build-sequence + (lambda (ae exps) + (let loop ((exps exps)) + (if (null? (cdr exps)) + (car exps) + (if (equal? (car exps) (build-void)) + (loop (cdr exps)) + `(begin ,@exps)))))) + (define build-void + (lambda () '((primitive void)))) + (define build-letrec + (lambda (ae vars val-exps body-exp) + (if (null? vars) body-exp `(letrec ,(map list vars val-exps) ,body-exp)))) + (define build-letrec* + (lambda (ae vars val-exps body-exp) + (cond + ((null? vars) body-exp) + (else + (if-wants-letrec* + `(letrec* ,(map list vars val-exps) ,body-exp) + (build-let ae vars (map (lambda (x) (build-data ae #f)) vars) + (build-sequence ae + (append + (map (lambda (lhs rhs) + (build-lexical-assignment ae lhs rhs)) + vars val-exps) + (list body-exp))))))))) + ) + + diff --git a/src/psyntax/compat.ss b/src/psyntax.compat.ss similarity index 70% rename from src/psyntax/compat.ss rename to src/psyntax.compat.ss index 2e08255..cafed60 100644 --- a/src/psyntax/compat.ss +++ b/src/psyntax.compat.ss @@ -1,7 +1,9 @@ (library (psyntax compat) - (export define-record make-parameter parameterize format) + (export define-record make-parameter parameterize format gensym + eval-core make-record-type symbol-value set-symbol-value!) (import + (only (ikarus compiler) eval-core) (rename (ikarus) (define-record sys.define-record))) (define-syntax define-record diff --git a/src/psyntax.config.ss b/src/psyntax.config.ss new file mode 100644 index 0000000..5d3bf25 --- /dev/null +++ b/src/psyntax.config.ss @@ -0,0 +1,64 @@ +;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(library (psyntax config) + (export if-wants-define-record if-wants-case-lambda + if-wants-letrec* if-wants-global-defines) + (import (rnrs)) + (define-syntax define-option + (syntax-rules () + ((_ name #t) + (define-syntax name + (syntax-rules () + ((_ sk fk) sk)))) + ((_ name #f) + (define-syntax name + (syntax-rules () + ((_ sk fk) fk)))))) + + (define-option if-wants-define-record #t) + ;;; define-record is an ikarus-specific extension. + ;;; should be disabled for all other implementations + ;;; the source is included to illustrate how + ;;; implementation-specific extensions can be added + ;;; to the expander + + (define-option if-wants-global-defines #f) + ;;; If the implementation requires that all global + ;;; variables be defined before they're set!ed, + ;;; then enabling this option causes the expander + ;;; to produce (define '#f) for every + ;;; exported identifiers. If the option is disabled, + ;;; then the global definitions are suppressed. + + (define-option if-wants-case-lambda #t) + ;;; Implementations that support case-lambda natively + ;;; should have the next option enabled. Disabling + ;;; wants-case-lambda causes the expander to produce + ;;; ugly, inefficient, but correct code by expanding + ;;; case-lambda into explicit dispatch code. + + (define-option if-wants-letrec* #t) + ;;; If the implementation has built-in support for + ;;; efficient letrec* (ikarus, chez), then this option + ;;; should be enabled. Disabling the option expands + ;;; (letrec* ([lhs* rhs*] ...) body) into + ;;; (let ([lhs* #f] ...) (set! lhs* rhs*) ... body) +) diff --git a/src/psyntax.expander.ss b/src/psyntax.expander.ss new file mode 100644 index 0000000..a26eb25 --- /dev/null +++ b/src/psyntax.expander.ss @@ -0,0 +1,2885 @@ +;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(library (psyntax expander) + (export identifier? syntax-dispatch environment environment? + eval expand generate-temporaries free-identifier=? + bound-identifier=? datum->syntax syntax-error + syntax->datum make-variable-transformer + eval-r6rs-top-level boot-library-expand eval-top-level + null-environment) + (import + (except (rnrs) + environment environment? identifier? + eval generate-temporaries free-identifier=? + bound-identifier=? datum->syntax + syntax->datum make-variable-transformer + null-environment) + (rnrs base) + (rnrs lists) + (rnrs control) + (rnrs io simple) + (psyntax library-manager) + (psyntax builders) + (psyntax compat) + (psyntax config) + (psyntax internal) + (only (rnrs syntax-case) syntax-case syntax with-syntax) + (prefix (rnrs syntax-case) sys.)) + + (define (set-cons x ls) + (cond + ((memq x ls) ls) + (else (cons x ls)))) + + (define (set-union ls1 ls2) + (cond + ((null? ls1) ls2) + ((memq (car ls1) ls2) (set-union (cdr ls1) ls2)) + (else (cons (car ls1) (set-union (cdr ls1) ls2))))) + + (define-syntax no-source + (lambda (x) #f)) + + ;;; the body of a library, when it's first processed, gets this + ;;; set of marks. + (define top-mark* '(top)) + + ;;; consequently, every syntax object that has a top in its marks + ;;; set was present in the program source. + (define top-marked? + (lambda (m*) (memq 'top m*))) + + ;;; This procedure generates a fresh lexical name for renaming. + ;;; It's also use it to generate temporaries. + (define gen-lexical + (lambda (sym) + (cond + ((symbol? sym) (gensym sym)) + ((stx? sym) (gen-lexical (id->sym sym))) + (else (error 'gen-lexical "BUG: invalid arg ~s" sym))))) + + ;;; gen-global is used to generate global names (e.g. locations + ;;; for library exports). We use gen-lexical since it works just + ;;; fine. + (define (gen-global x) (gen-lexical x)) + + ;;; every identifier in the program would have a label associated + ;;; with it in its substitution. gen-label generates such labels. + ;;; the labels have to have read/write eq? invariance to support + ;;; separate compilation. + (define gen-label + (lambda (_) (gensym))) + + ;;; A rib is a record constructed at every lexical contour in the + ;;; program to hold information about the variables introduced in that + ;;; contour. Adding an identifier->label mapping to an extensible rib + ;;; is achieved by consing the identifier's name to the list of + ;;; symbols, consing the identifier's list of marks to the rib's + ;;; mark**, and consing the label to the rib's labels. + + (define-record rib (sym* mark** label* sealed/freq)) + + (define make-empty-rib + (lambda () + (make-rib '() '() '() #f))) + + ;;; For example, when processing a lambda's internal define, a new rib + ;;; is created and is added to the body of the lambda expression. + ;;; When an internal definition is encountered, a new entry for the + ;;; identifier is added (via side effect) to the rib. A rib may be + ;;; extensible, or sealed. An extensible rib looks like: + ;;; # + + (define (extend-rib! rib id label) + (define (find sym mark* sym* mark**) + (and (pair? sym*) + (or (and (eq? sym (car sym*)) + (same-marks? mark* (car mark**))) + (find sym mark* (cdr sym*) (cdr mark**))))) + (when (rib-sealed/freq rib) + (error 'extend-rib! "rib ~s is sealed" rib)) + (let ((sym (id->sym id)) (mark* (stx-mark* id))) + (let ((sym* (rib-sym* rib))) + (when (and (memq sym (rib-sym* rib)) + (find sym mark* sym* (rib-mark** rib))) + ;;; signal an error if the identifier was already + ;;; in the rib. + (stx-error id "cannot redefine")) + (set-rib-sym*! rib (cons sym sym*)) + (set-rib-mark**! rib (cons mark* (rib-mark** rib))) + (set-rib-label*! rib (cons label (rib-label* rib)))))) + + ;;; A rib can be sealed once all bindings are inserted. To seal + ;;; a rib, we convert the lists sym*, mark**, and label* to vectors + ;;; and insert a frequency vector in the sealed/freq field. + ;;; The frequency vector is an optimization that allows the rib to + ;;; reorganize itself by bubbling frequently used mappings to the + ;;; top of the rib. The vector is maintained in non-descending + ;;; order and an identifier's entry in the rib is incremented at + ;;; every access. If an identifier's frequency exceeds the + ;;; preceeding one, the identifier's position is promoted to the + ;;; top of its class (or the bottom of the previous class). + + (define (seal-rib! rib) + (let ((sym* (rib-sym* rib))) + (unless (null? sym*) + ;;; only seal if rib is not empty. + (let ((sym* (list->vector sym*))) + (set-rib-sym*! rib sym*) + (set-rib-mark**! rib + (list->vector (rib-mark** rib))) + (set-rib-label*! rib + (list->vector (rib-label* rib))) + (set-rib-sealed/freq! rib + (make-vector (vector-length sym*) 0)))))) + + (define (unseal-rib! rib) + (when (rib-sealed/freq rib) + (set-rib-sealed/freq! rib #f) + (set-rib-sym*! rib (vector->list (rib-sym* rib))) + (set-rib-mark**! rib (vector->list (rib-mark** rib))) + (set-rib-label*! rib (vector->list (rib-label* rib))))) + + (define (increment-rib-frequency! rib idx) + (let ((freq* (rib-sealed/freq rib))) + (let ((freq (vector-ref freq* idx))) + (let ((i + (let f ((i idx)) + (cond + ((zero? i) 0) + (else + (let ((j (- i 1))) + (cond + ((= freq (vector-ref freq* j)) (f j)) + (else i)))))))) + (vector-set! freq* i (+ freq 1)) + (unless (= i idx) + (let ((sym* (rib-sym* rib)) + (mark** (rib-mark** rib)) + (label* (rib-label* rib))) + (let ((sym (vector-ref sym* idx))) + (vector-set! sym* idx (vector-ref sym* i)) + (vector-set! sym* i sym)) + (let ((mark* (vector-ref mark** idx))) + (vector-set! mark** idx (vector-ref mark** i)) + (vector-set! mark** i mark*)) + (let ((label (vector-ref label* idx))) + (vector-set! label* idx (vector-ref label* i)) + (vector-set! label* i label)))))))) + + (define make-full-rib ;;; it may be a good idea to seal this rib + (lambda (id* label*) + (make-rib (map id->sym id*) (map stx-mark* id*) label* #f))) + + ;;; Now to syntax objects which are records defined like: + (define-record stx (expr mark* subst*) + (lambda (x p) + (display "#datum x) p) + (display ">" p))) + + ;;; First, let's look at identifiers, since they're the real + ;;; reason why syntax objects are here to begin with. + ;;; An identifier is an stx whose expr is a symbol. + ;;; In addition to the symbol naming the identifier, the identifer + ;;; has a list of marks and a list of substitutions. + ;;; The idea is that to get the label of an identifier, we look up + ;;; the identifier's substitutions for a mapping with the same + ;;; name and same marks (see same-marks? below). + + ;;; Since all the identifier->label bindings are encapsulated + ;;; within the identifier, converting a datum to a syntax object + ;;; (non-hygienically) is done simply by creating an stx that has + ;;; the same marks and substitutions as the identifier. + (define datum->stx + (lambda (id datum) + (make-stx datum (stx-mark* id) (stx-subst* id)))) + + ;;; A syntax object may be wrapped or unwrapped, so what does that + ;;; mean exactly? + ;;; + ;;; A wrapped syntax object is just a way of saying it's an stx + ;;; record. All identifiers are stx records (with a symbol in + ;;; their expr field). Other objects such as pairs and vectors + ;;; may be wrapped or unwrapped. A wrapped pair is an stx whos + ;;; expr is a pair. An unwrapped pair is a pair whos car and cdr + ;;; fields are themselves syntax objects (wrapped or unwrapped). + ;;; + ;;; We always maintain the invariant that we don't double wrap + ;;; syntax objects. The only way to get a doubly-wrapped syntax + ;;; object is by doing datum->stx (above) where the datum is + ;;; itself a wrapped syntax object (r6rs may not even consider + ;;; wrapped syntax objects as datum, but let's not worry now). + + ;;; Syntax objects have, in addition to the expr, a + ;;; substitution field (stx-subst*). The subst* is a list + ;;; where each element is either a rib or the symbol "shift". + ;;; Normally, a new rib is added to an stx at evert lexical + ;;; contour of the program in order to capture the bindings + ;;; inctroduced in that contour. + + ;;; The mark* field of an stx is, well, a list of marks. + ;;; Each of these marks can be either a generated mark + ;;; or an antimark. + ;;; (two marks must be eq?-comparable, so we use a string + ;;; of one char (this assumes that strings are mutable)). + + ;;; gen-mark generates a new unique mark + (define (gen-mark) ;;; faster + (string #\m)) + + ;(define gen-mark ;;; useful for debugging + ; (let ((i 0)) + ; (lambda () + ; (set! i (+ i 1)) + ; (string-append "m." (number->string i))))) + + ;;; We use #f as the anti-mark. + (define anti-mark #f) + (define anti-mark? not) + + ;;; So, what's an anti-mark and why is it there. + ;;; The theory goes like this: when a macro call is encountered, + ;;; the input stx to the macro transformer gets an extra anti-mark, + ;;; and the output of the transformer gets a fresh mark. + ;;; When a mark collides with an anti-mark, they cancel one + ;;; another. Therefore, any part of the input transformer that + ;;; gets copied to the output would have a mark followed + ;;; immediately by an anti-mark, resulting in the same syntax + ;;; object (no extra marks). Parts of the output that were not + ;;; present in the input (e.g. inserted by the macro transformer) + ;;; would have no anti-mark and, therefore, the mark would stick + ;;; to them. + ;;; + ;;; Every time a mark is pushed to an stx-mark* list, a + ;;; corresponding 'shift is pushed to the stx-subst* list. + ;;; Every time a mark is cancelled by an anti-mark, the + ;;; corresponding shifts are also cancelled. + + ;;; The procedure join-wraps, here, is used to compute the new + ;;; mark* and subst* that would result when the m1* and s1* are + ;;; added to an stx's mark* and subst*. + ;;; The only tricky part here is that e may have an anti-mark + ;;; that should cancel with the last mark in m1*. + ;;; So, if m1* is (mx* ... mx) + ;;; and m2* is (#f my* ...) + ;;; then the resulting marks should be (mx* ... my* ...) + ;;; since mx would cancel with the anti-mark. + ;;; The substs would have to also cancel since + ;;; s1* is (sx* ... sx) + ;;; and s2* is (sy sy* ...) + ;;; then the resulting substs should be (sx* ... sy* ...) + ;;; Notice that both sx and sy would be shift marks. + (define join-wraps + (lambda (m1* s1* e) + (define cancel + (lambda (ls1 ls2) + (let f ((x (car ls1)) (ls1 (cdr ls1))) + (if (null? ls1) + (cdr ls2) + (cons x (f (car ls1) (cdr ls1))))))) + (let ((m2* (stx-mark* e)) (s2* (stx-subst* e))) + (if (and (not (null? m1*)) + (not (null? m2*)) + (anti-mark? (car m2*))) + ; cancel mark, anti-mark, and corresponding shifts + (values (cancel m1* m2*) (cancel s1* s2*)) + (values (append m1* m2*) (append s1* s2*)))))) + + ;;; The procedure mkstx is then the proper constructor for + ;;; wrapped syntax objects. It takes a syntax object, a list + ;;; of marks, and a list of substs. It joins the two wraps + ;;; making sure that marks and anti-marks and corresponding + ;;; shifts cancel properly. + (define mkstx + (lambda (e m* s*) + (if (stx? e) + (let-values (((m* s*) (join-wraps m* s* e))) + (make-stx (stx-expr e) m* s*)) + (make-stx e m* s*)))) + + ;;; to add a mark, we always add a corresponding shift. + (define add-mark + (lambda (m e) + (mkstx e (list m) '(shift)))) + + (define add-subst + (lambda (subst e) + (mkstx e '() (list subst)))) + + ;;; now are some deconstructors and predicates for syntax objects. + (define syntax-kind? + (lambda (x p?) + (if (stx? x) + (syntax-kind? (stx-expr x) p?) + (p? x)))) + (define syntax-vector->list + (lambda (x) + (cond + ((stx? x) + (let ((ls (syntax-vector->list (stx-expr x))) + (m* (stx-mark* x)) (s* (stx-subst* x))) + (map (lambda (x) (mkstx x m* s*)) ls))) + ((vector? x) (vector->list x)) + (else (error 'syntax-vector->list "not a syntax vector ~s" x))))) + (define syntax-pair? + (lambda (x) (syntax-kind? x pair?))) + (define syntax-vector? + (lambda (x) (syntax-kind? x vector?))) + (define syntax-null? + (lambda (x) (syntax-kind? x null?))) + (define syntax-list? ;;; FIXME: should terminate on cyclic input. + (lambda (x) + (or (syntax-null? x) + (and (syntax-pair? x) (syntax-list? (syntax-cdr x)))))) + (define syntax-car + (lambda (x) + (if (stx? x) + (mkstx (syntax-car (stx-expr x)) (stx-mark* x) (stx-subst* x)) + (if (pair? x) + (car x) + (error 'syntax-car "~s is not a pair" x))))) + (define syntax->list + (lambda (x) + (if (syntax-pair? x) + (cons (syntax-car x) (syntax->list (syntax-cdr x))) + (if (syntax-null? x) + '() + (error 'syntax->list "invalid ~s" x))))) + (define syntax-cdr + (lambda (x) + (if (stx? x) + (mkstx (syntax-cdr (stx-expr x)) (stx-mark* x) (stx-subst* x)) + (if (pair? x) + (cdr x) + (error 'syntax-cdr "~s is not a pair" x))))) + (define id? + (lambda (x) (syntax-kind? x symbol?))) + + (define id->sym + (lambda (x) + (if (stx? x) + (id->sym (stx-expr x)) + (if (symbol? x) + x + (error 'id->sym "~s is not an id" x))))) + + ;;; Two lists of marks are considered the same if they have the + ;;; same length and the corresponding marks on each are eq?. + (define same-marks? + (lambda (x y) + (or (and (null? x) (null? y)) ;(eq? x y) + (and (pair? x) (pair? y) + (eq? (car x) (car y)) + (same-marks? (cdr x) (cdr y)))))) + + ;;; Two identifiers are bound-id=? if they have the same name and + ;;; the same set of marks. + (define bound-id=? + (lambda (x y) + (and (eq? (id->sym x) (id->sym y)) + (same-marks? (stx-mark* x) (stx-mark* y))))) + + ;;; Two identifiers are free-id=? if either both are bound to the + ;;; same label or if both are unbound and they have the same name. + (define free-id=? + (lambda (i j) + (let ((t0 (id->label i)) (t1 (id->label j))) + (if (or t0 t1) + (eq? t0 t1) + (eq? (id->sym i) (id->sym j)))))) + + ;;; valid-bound-ids? takes checks if a list is made of identifers + ;;; none of which is bound-id=? to another. + (define valid-bound-ids? + (lambda (id*) + (and (for-all id? id*) + (distinct-bound-ids? id*)))) + + (define distinct-bound-ids? + (lambda (id*) + (or (null? id*) + (and (not (bound-id-member? (car id*) (cdr id*))) + (distinct-bound-ids? (cdr id*)))))) + + (define bound-id-member? + (lambda (id id*) + (and (pair? id*) + (or (bound-id=? id (car id*)) + (bound-id-member? id (cdr id*)))))) + + (define self-evaluating? + (lambda (x) ;;; am I missing something here? + (or (number? x) (string? x) (char? x) (boolean? x)))) + + ;;; strip is used to remove the wrap of a syntax object. + ;;; It takes an stx's expr and marks. If the marks contain + ;;; a top-mark, then the expr is returned. + (define strip + (lambda (x m*) + (if (top-marked? m*) + x + (let f ((x x)) + (cond + ((stx? x) (strip (stx-expr x) (stx-mark* x))) + ((pair? x) + (let ((a (f (car x))) (d (f (cdr x)))) + (if (and (eq? a (car x)) (eq? d (cdr x))) + x + (cons a d)))) + ((vector? x) + (let ((old (vector->list x))) + (let ((new (map f old))) + (if (for-all eq? old new) + x + (list->vector new))))) + (else x)))))) + + (define stx->datum + (lambda (x) + (strip x '()))) + + ;;; id->label takes an id (that's a sym x marks x substs) and + ;;; searches the substs for a label associated with the same sym + ;;; and marks. + (define id->label + (lambda (id) + (let ((sym (id->sym id))) + (let search ((subst* (stx-subst* id)) (mark* (stx-mark* id))) + (cond + ((null? subst*) + ;;; try to hook up the symbol from the interaction + ;;; environment if there is one. + (interaction-sym->label sym)) + ((eq? (car subst*) 'shift) + ;;; a shift is inserted when a mark is added. + ;;; so, we search the rest of the substitution + ;;; without the mark. + (search (cdr subst*) (cdr mark*))) + (else + (let ((rib (car subst*))) + (cond + ((rib-sealed/freq rib) + (let ((sym* (rib-sym* rib))) + (let f ((i 0) (j (vector-length sym*))) + (cond + ((= i j) (search (cdr subst*) mark*)) + ((and (eq? (vector-ref sym* i) sym) + (same-marks? mark* + (vector-ref (rib-mark** rib) i))) + (let ((label (vector-ref (rib-label* rib) i))) + (increment-rib-frequency! rib i) + label)) + (else (f (+ i 1) j)))))) + (else + (let f ((sym* (rib-sym* rib)) + (mark** (rib-mark** rib)) + (label* (rib-label* rib))) + (cond + ((null? sym*) (search (cdr subst*) mark*)) + ((and (eq? (car sym*) sym) + (same-marks? (car mark**) mark*)) + (car label*)) + (else (f (cdr sym*) (cdr mark**) (cdr label*)))))))))))))) + + ;;; label->binding looks up the label in the environment r as + ;;; well as in the global environment. Since all labels are + ;;; unique, it doesn't matter which environment we consult first. + ;;; we lookup the global environment first because it's faster + ;;; (uses a hash table) while the lexical environment is an alist. + ;;; If we don't find the binding of a label, we return the binding + ;;; (displaced-lexical . #f) to indicate such. + (define label->binding + (lambda (x r) + (cond + ((imported-label->binding x)) + ((assq x r) => cdr) + (else '(displaced-lexical . #f))))) + + (define make-binding cons) + (define binding-type car) + (define binding-value cdr) + + ;;; the type of an expression is determined by two things: + ;;; - the shape of the expression (identifier, pair, or datum) + ;;; - the binding of the identifier (for id-stx) or the type of + ;;; car of the pair. + (define syntax-type + (lambda (e r) + (cond + ((id? e) + (let ((id e)) + (let* ((label (id->label id)) + (b (label->binding label r)) + (type (binding-type b))) + (unless label ;;; fail early. + (stx-error e "unbound identifier")) + (case type + ((lexical core-prim macro macro! global local-macro + local-macro! global-macro global-macro! + displaced-lexical syntax import $module) + (values type (binding-value b) id)) + (else (values 'other #f #f)))))) + ((syntax-pair? e) + (let ((id (syntax-car e))) + (if (id? id) + (let* ((label (id->label id)) + (b (label->binding label r)) + (type (binding-type b))) + (unless label ;;; fail early. + (stx-error e "unbound identifier")) + (case type + ((define define-syntax core-macro begin macro + macro! local-macro local-macro! global-macro + global-macro! module set! let-syntax + letrec-syntax import) + (values type (binding-value b) id)) + (else + (values 'call #f #f)))) + (values 'call #f #f)))) + (else (let ((d (stx->datum e))) + (if (self-evaluating? d) + (values 'constant d #f) + (values 'other #f #f))))))) + + (define-syntax stx-error + (lambda (x) + (syntax-case x () + ((_ stx) + (syntax (error 'expander "invalid syntax ~s" (stx->datum stx)))) + ((_ stx msg) (syntax (error 'expander "~a ~s" msg (strip stx '()))))))) + + ;;; when the rhs of a syntax definition is evaluated, it should be + ;;; either a procedure, an identifier-syntax transformer or an + ;;; ($rtd . #) form (ikarus/chez). sanitize-binding converts + ;;; the output to one of: + ;;; (lacal-macro . procedure) + ;;; (local-macro! . procedure) + ;;; ($rtd . $rtd) + ;;; and signals an error otherwise. + (define sanitize-binding + (lambda (x src) + (cond + ((procedure? x) + (cons* 'local-macro x src)) + ((and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x))) + (cons* 'local-macro! (cdr x) src)) + ((and (pair? x) (eq? (car x) '$rtd)) x) + (else (error 'expand "invalid transformer ~s" x))))) + + ;;; r6rs's make-variable-transformer: + (define make-variable-transformer + (lambda (x) + (if (procedure? x) + (cons 'macro! x) + (error 'make-variable-transformer + "~s is not a procedure" x)))) + + ;;; make-eval-transformer takes an expanded expression, + ;;; evaluates it and returns a proper syntactic binding + ;;; for the resulting object. + (define make-eval-transformer + (lambda (x) + (sanitize-binding (eval-core (expanded->core x)) x))) + + ;;; The syntax-match macro is almost like syntax-case macro. + ;;; Except that: + ;;; The syntax objects matched are OUR stx objects, not + ;;; the host systems syntax objects (whatever they may be + ;;; we don't care). + ;;; The literals are matched against those in the system + ;;; library (psyntax system $all). -- see scheme-stx + ;;; The variables in the patters are bound to ordinary variables + ;;; not to special pattern variables. + (define-syntax syntax-match + (lambda (ctx) + (define dots? + (lambda (x) + (and (sys.identifier? x) + (sys.free-identifier=? x (syntax (... ...)))))) + (define free-identifier-member? + (lambda (x ls) + (and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t))) + (define (parse-clause lits cls) + (define (parse-pat pat) + (syntax-case pat () + (id (sys.identifier? (syntax id)) + (cond + ((free-identifier-member? (syntax id) lits) + (values '() + (syntax + (lambda (x) + (and (id? x) + (free-id=? x (scheme-stx 'id)) + '()))))) + ((sys.free-identifier=? (syntax id) (syntax _)) + (values '() (syntax (lambda (x) '())))) + (else + (values (list (syntax id)) (syntax (lambda (x) (list x))))))) + ((pat dots) (dots? (syntax dots)) + (let-values (((pvars decon) (parse-pat (syntax pat)))) + (with-syntax (((v* ...) pvars) (decon decon)) + (values pvars + (syntax (letrec ((f (lambda (x) + (cond + ((syntax-pair? x) + (let ((cars/f (decon (syntax-car x)))) + (and cars/f + (let ((cdrs/f (f (syntax-cdr x)))) + (and cdrs/f + (map cons cars/f cdrs/f)))))) + ((syntax-null? x) + (list (begin 'v* '()) ...)) + (else #f))))) + f)))))) + ((pat dots . last) (dots? (syntax dots)) + (let-values (((p1 d1) (parse-pat (syntax pat))) + ((p2 d2) (parse-pat (syntax last)))) + (with-syntax (((v* ...) (append p1 p2)) + ((v1* ...) p1) + ((v2* ...) p2) + (d1 d1) (d2 d2)) + (values (append p1 p2) + (syntax (letrec ((f (lambda (x) + (cond + ((syntax-pair? x) + (let ((cars/f (d1 (syntax-car x)))) + (and cars/f + (let ((d/f (f (syntax-cdr x)))) + (and d/f + (cons (map cons cars/f (car d/f)) + (cdr d/f))))))) + (else + (let ((d (d2 x))) + (and d + (cons (list (begin 'v1* '()) ...) + d)))))))) + (lambda (x) + (let ((x (f x))) + (and x (append (car x) (cdr x))))))))))) + ((pat1 . pat2) + (let-values (((p1 d1) (parse-pat (syntax pat1))) + ((p2 d2) (parse-pat (syntax pat2)))) + (with-syntax ((d1 d1) (d2 d2)) + (values (append p1 p2) + (syntax (lambda (x) + (and (syntax-pair? x) + (let ((q (d1 (syntax-car x)))) + (and q + (let ((r (d2 (syntax-cdr x)))) + (and r (append q r)))))))))))) + (#(pats ...) + (let-values (((pvars d) (parse-pat (syntax (pats ...))))) + (with-syntax ((d d)) + (values pvars + (syntax (lambda (x) + (and (syntax-vector? x) + (d (syntax-vector->list x))))))))) + (datum + (values '() + (syntax (lambda (x) + (and (equal? (stx->datum x) 'datum) '()))))))) + (syntax-case cls () + ((pat body) + (let-values (((pvars decon) (parse-pat (syntax pat)))) + (with-syntax (((v* ...) pvars)) + (values decon + (syntax (lambda (v* ...) #t)) + (syntax (lambda (v* ...) body)))))) + ((pat guard body) + (let-values (((pvars decon) (parse-pat (syntax pat)))) + (with-syntax (((v* ...) pvars)) + (values decon + (syntax (lambda (v* ...) guard)) + (syntax (lambda (v* ...) body)))))))) + (syntax-case ctx () + ((_ expr (lits ...)) (for-all sys.identifier? (syntax (lits ...))) + (syntax (stx-error expr "invalid syntax"))) + ((_ expr (lits ...) cls cls* ...) (for-all sys.identifier? + (syntax (lits ...))) + (let-values (((decon guard body) + (parse-clause (syntax (lits ...)) (syntax cls)))) + (with-syntax ((decon decon) (guard guard) (body body)) + (syntax (let ((t expr)) + (let ((ls/false (decon t))) + (if (and ls/false (apply guard ls/false)) + (apply body ls/false) + (syntax-match t (lits ...) cls* ...))))))))))) + + (define parse-define + (lambda (x) + ;;; FIXME: (define f) is not supported yet + (syntax-match x () + ((_ (id . fmls) b b* ...) (id? id) + (values id (cons 'defun (cons fmls (cons b b*))))) + ((_ id val) (id? id) + (values id (cons 'expr val)))))) + + (define parse-define-syntax + (lambda (x) + ;;; FIXME: (define-syntax (f stx) ---) is not supported yet + (syntax-match x () + ((_ id val) (id? id) (values id val))))) + + ;;; scheme-stx takes a symbol and if it's in the + ;;; (psyntax system $all) library, it creates a fresh identifier + ;;; that maps only the symbol to its label in that library. + ;;; Symbols not in that library become fresh. + (define scheme-stx + (lambda (sym) + (let ((subst + (library-subst + (find-library-by-name '(psyntax system $all))))) + (cond + ((assq sym subst) => + (lambda (x) + (let ((name (car x)) (label (cdr x))) + (add-subst + (make-rib (list name) (list top-mark*) (list label) #f) + (mkstx sym top-mark* '()))))) + (else (mkstx sym top-mark* '())))))) + + ;;; macros + (define add-lexical + (lambda (lab lex r) + (cons (cons* lab 'lexical lex) r))) + ;;; + (define add-lexicals + (lambda (lab* lex* r) + (cond + ((null? lab*) r) + (else + (add-lexicals (cdr lab*) (cdr lex*) + (add-lexical (car lab*) (car lex*) r)))))) + ;;; + (define let-values-transformer ;;; go away + (lambda (e r mr) + (syntax-match e () + ((_ (((fml** ...) rhs*) ...) b b* ...) + (let ((rhs* (chi-expr* rhs* r mr))) + (let ((lex** (map (lambda (ls) (map gen-lexical ls)) fml**)) + (lab** (map (lambda (ls) (map gen-label ls)) fml**))) + (let ((fml* (apply append fml**)) + (lab* (apply append lab**)) + (lex* (apply append lex**))) + (let f ((lex** lex**) (rhs* rhs*)) + (cond + ((null? lex**) + (chi-internal + (add-subst + (make-full-rib fml* lab*) + (cons b b*)) + (add-lexicals lab* lex* r) + mr)) + (else + (build-application no-source + (build-primref no-source 'call-with-values) + (list + (build-lambda no-source '() (car rhs*)) + (build-lambda no-source (car lex**) + (f (cdr lex**) (cdr rhs*))))))))))))))) + + (define letrec-helper + (lambda (e r mr build) + (syntax-match e () + ((_ ((lhs* rhs*) ...) b b* ...) + (if (not (valid-bound-ids? lhs*)) + (stx-error e "invalid identifiers") + (let ((lex* (map gen-lexical lhs*)) + (lab* (map gen-label lhs*))) + (let ((rib (make-full-rib lhs* lab*)) + (r (add-lexicals lab* lex* r))) + (let ((body (chi-internal (add-subst rib (cons b b*)) r mr)) + (rhs* (chi-expr* (map (lambda (x) (add-subst rib x)) rhs*) r mr))) + (build no-source lex* rhs* body))))))))) + + (define letrec-transformer + (lambda (e r mr) (letrec-helper e r mr build-letrec))) + + (define letrec*-transformer + (lambda (e r mr) (letrec-helper e r mr build-letrec*))) + + (define type-descriptor-transformer + (lambda (e r mr) + (syntax-match e () + ((_ id) (id? id) + (let* ((lab (id->label id)) + (b (label->binding lab r)) + (type (binding-type b))) + (unless lab (stx-error e "unbound identifier")) + (case type + (($rtd) (build-data no-source (binding-value b))) + (else (stx-error e "invalid type")))))))) + + (define when-transformer ;;; go away + (lambda (e r mr) + (syntax-match e () + ((_ test e e* ...) + (build-conditional no-source + (chi-expr test r mr) + (build-sequence no-source + (chi-expr* (cons e e*) r mr)) + (build-void)))))) + + (define unless-transformer ;;; go away + (lambda (e r mr) + (syntax-match e () + ((_ test e e* ...) + (build-conditional no-source + (chi-expr test r mr) + (build-void) + (build-sequence no-source + (chi-expr* (cons e e*) r mr))))))) + + (define if-transformer + (lambda (e r mr) + (syntax-match e () + ((_ e0 e1 e2) + (build-conditional no-source + (chi-expr e0 r mr) + (chi-expr e1 r mr) + (chi-expr e2 r mr))) + ((_ e0 e1) + (build-conditional no-source + (chi-expr e0 r mr) + (chi-expr e1 r mr) + (build-void)))))) + + (define case-transformer ;;; go away + (lambda (e r mr) + (define build-one + (lambda (t cls rest) + (syntax-match cls () + (((d* ...) e e* ...) + (build-conditional no-source + (build-application no-source + (build-primref no-source 'memv) + (list t (build-data no-source (stx->datum d*)))) + (build-sequence no-source + (chi-expr* (cons e e*) r mr)) + rest)) + (else (stx-error e))))) + (define build-last + (lambda (t cls) + (syntax-match cls () + (((d* ...) e e* ...) + (build-one t cls (build-void))) + ((else-kwd x x* ...) + (if (and (id? else-kwd) + (free-id=? else-kwd (scheme-stx 'else))) + (build-sequence no-source + (chi-expr* (cons x x*) r mr)) + (stx-error e))) + (else (stx-error e))))) + (syntax-match e () + ((_ expr) + (build-sequence no-source + (list (chi-expr expr r mr) (build-void)))) + ((_ expr cls cls* ...) + (let ((t (gen-lexical 't))) + (build-let no-source + (list t) (list (chi-expr expr r mr)) + (let f ((cls cls) (cls* cls*)) + (cond + ((null? cls*) (build-last t cls)) + (else + (build-one t cls + (f (car cls*) (cdr cls*)))))))))))) + + (define quote-transformer + (lambda (e r mr) + (syntax-match e () + ((_ datum) (build-data no-source (stx->datum datum)))))) + + (define case-lambda-transformer + (lambda (e r mr) + (syntax-match e () + ((_ (fmls* b* b** ...) ...) + (let-values (((fmls* body*) + (chi-lambda-clause* fmls* + (map cons b* b**) r mr))) + (build-case-lambda no-source fmls* body*)))))) + + (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 bless + (lambda (x) + (mkstx + (let f ((x x)) + (cond + ((stx? x) x) + ((pair? x) (cons (f (car x)) (f (cdr x)))) + ((symbol? x) (scheme-stx x)) + ((vector? x) + (list->vector (map f (vector->list x)))) + (else x))) + '() '()))) + + (define with-syntax-macro + (lambda (e) + (syntax-match e () + ((_ ((fml* expr*) ...) b b* ...) + (bless + `(syntax-case (list . ,expr*) () + (,fml* (begin ,b . ,b*)))))))) + + (define let-macro + (lambda (stx) + (syntax-match stx () + ((_ ((lhs* rhs*) ...) b b* ...) + (if (valid-bound-ids? lhs*) + (bless `((lambda ,lhs* ,b . ,b*) . ,rhs*)) + (stx-error stx "invalid bindings"))) + ((_ f ((lhs* rhs*) ...) b b* ...) (id? f) + (if (valid-bound-ids? lhs*) + (bless `(letrec ((,f (lambda ,lhs* ,b . ,b*))) + (,f . ,rhs*))) + (stx-error stx "invalid syntax")))))) + + (define trace-lambda-macro + (lambda (stx) + (syntax-match stx () + ((_ who (fmls ...) b b* ...) + (if (valid-bound-ids? fmls) + (bless `(make-traced-procedure ',who + (lambda ,fmls ,b . ,b*))) + (stx-error stx "invalid formals"))) + ((_ who (fmls ... . last) b b* ...) + (if (valid-bound-ids? (cons last fmls)) + (bless `(make-traced-procedure ',who + (lambda (,@fmls . ,last) ,b . ,b*))) + (stx-error stx "invalid formals")))))) + + (define trace-define-macro + (lambda (stx) + (syntax-match stx () + ((_ (who fmls ...) b b* ...) + (if (valid-bound-ids? fmls) + (bless `(define ,who + (make-traced-procedure ',who + (lambda ,fmls ,b . ,b*)))) + (stx-error stx "invalid formals"))) + ((_ (who fmls ... . last) b b* ...) + (if (valid-bound-ids? (cons last fmls)) + (bless `(define ,who + (make-traced-procedure ',who + (lambda (,@fmls . ,last) ,b . ,b*)))) + (stx-error stx "invalid formals"))) + ((_ who expr) + (if (id? who) + (bless `(define ,who + (let ((v ,expr)) + (if (procedure? v) + (make-traced-procedure ',who v) + (error 'trace-define + "~s is not a procedure" v))))) + (stx-error stx "invalid formals")))))) + + (define time-macro + (lambda (stx) + (syntax-match stx () + ((_ expr) + (bless `(time-it ',expr (lambda () ,expr))))))) + + (define delay-macro + (lambda (stx) + (syntax-match stx () + ((_ expr) + (bless `(make-promise (lambda () ,expr))))))) + + (define assert-macro + (lambda (stx) + (syntax-match stx () + ((_ expr) + (bless `(unless ,expr + (error 'assert "~s failed" ',expr))))))) + + (define endianness-macro + (lambda (stx) + (syntax-match stx () + ((_ e) + (case (syntax->datum e) + ((little) (bless `'little)) + ((big) (bless `'big)) + (else (stx-error stx "endianness must be big or little"))))))) + + (define identifier-syntax-macro + (lambda (stx) + (syntax-match stx (set!) + ((_ expr) + (bless `(lambda (x) + (syntax-case x () + (id (identifier? (syntax id)) (syntax ,expr)) + ((id e* ...) (identifier? (syntax id)) + (cons (syntax ,expr) (syntax (e* ...)))))))) + ((_ (id1 expr1) ((set! id2 expr2) expr3)) + (and (id? id1) (id? id2) (id? expr2)) + (bless `(cons 'macro! + (lambda (x) + (syntax-case x (set!) + (id (identifier? (syntax id)) (syntax ,expr1)) + ((set! id ,expr2) (syntax ,expr3)) + ((id e* ...) (identifier? (syntax id)) (syntax (,expr1 e* ...))))))))))) + + (define do-macro + (lambda (stx) + (define bind + (lambda (x) + (syntax-match x () + ((x init) `(,x ,init ,x)) + ((x init step) `(,x ,init ,step)) + (_ (stx-error stx "invalid binding"))))) + (syntax-match stx () + ((_ (binding* ...) + (test expr* ...) + command* ...) + (syntax-match (map bind binding*) () + (((x* init* step*) ...) + (if (valid-bound-ids? x*) + (bless + `(letrec ((loop + (lambda ,x* + (if ,test + (begin (if #f #f) ,@expr*) + (begin + ,@command* + (loop ,@step*)))))) + (loop ,@init*))) + (stx-error stx "invalid bindings")))))))) + + (define let*-macro + (lambda (stx) + (syntax-match stx () + ((_ ((lhs* rhs*) ...) b b* ...) (for-all id? lhs*) + (bless + (let f ((x* (map list lhs* rhs*))) + (cond + ((null? x*) `(let () ,b . ,b*)) + (else `(let (,(car x*)) ,(f (cdr x*))))))))))) + + (define or-macro + (lambda (stx) + (syntax-match stx () + ((_) #f) + ((_ e e* ...) + (bless + (let f ((e e) (e* e*)) + (cond + ((null? e*) `(begin #f ,e)) + (else + `(let ((t ,e)) + (if t t ,(f (car e*) (cdr e*)))))))))))) + + (define and-macro + (lambda (stx) + (syntax-match stx () + ((_) #t) + ((_ e e* ...) + (bless + (let f ((e e) (e* e*)) + (cond + ((null? e*) `(begin #f ,e)) + (else `(if ,e ,(f (car e*) (cdr e*)) #f))))))))) + + (define cond-macro + (lambda (stx) + (syntax-match stx () + ((_ cls cls* ...) + (bless + (let f ((cls cls) (cls* cls*)) + (cond + ((null? cls*) + (syntax-match cls (else =>) + ((else e e* ...) `(begin ,e . ,e*)) + ((e => p) `(let ((t ,e)) (if t (,p t)))) + ((e) `(or ,e (if #f #f))) + ((e e* ...) `(if ,e (begin . ,e*))) + (_ (stx-error stx "invalid last clause")))) + (else + (syntax-match cls (else =>) + ((else e e* ...) (stx-error stx "incorrect position of keyword else")) + ((e => p) `(let ((t ,e)) (if t (,p t) ,(f (car cls*) (cdr cls*))))) + ((e) `(or ,e ,(f (car cls*) (cdr cls*)))) + ((e e* ...) `(if ,e (begin . ,e*) ,(f (car cls*) (cdr cls*)))) + (_ (stx-error stx "invalid last clause"))))))))))) + + (define include-macro + (lambda (e) + (syntax-match e () + ((id filename) + (let ((filename (stx->datum filename))) + (unless (string? filename) (stx-error e)) + (with-input-from-file filename + (lambda () + (let f ((ls '())) + (let ((x (read))) + (cond + ((eof-object? x) + (cons (bless 'begin) + (datum->stx id (reverse ls)))) + (else (f (cons x ls))))))))))))) + + (define syntax-rules-macro + (lambda (e) + (syntax-match e () + ((_ (lits ...) + (pat* tmp*) ...) + (begin + (unless (for-all + (lambda (x) + (and (id? x) + (not (free-id=? x (scheme-stx '...))) + (not (free-id=? x (scheme-stx '_))))) + lits) + (stx-error e "invalid literals")) + (bless `(lambda (x) + (syntax-case x ,lits + ,@(map (lambda (pat tmp) + `(,pat (syntax ,tmp))) + pat* tmp*))))))))) + + (define quasiquote-macro + (let () + (define-syntax app + (syntax-rules (quote) + ((_ 'x arg* ...) + (list (scheme-stx 'x) arg* ...)))) + (define-syntax app* + (syntax-rules (quote) + ((_ 'x arg* ... last) + (cons* (scheme-stx 'x) arg* ... last)))) + (define quasicons* + (lambda (x y) + (let f ((x x)) + (if (null? x) y (quasicons (car x) (f (cdr x))))))) + (define quasicons + (lambda (x y) + (syntax-match y (quote list) + ((quote dy) + (syntax-match x (quote) + ((quote dx) (app 'quote (cons dx dy))) + (_ + (syntax-match dy () + (() (app 'list x)) + (_ (app 'cons x y)))))) + ((list stuff ...) + (app* 'list x stuff)) + (_ (app 'cons x y))))) + (define quasiappend + (lambda (x y) + (let ((ls (let f ((x x)) + (if (null? x) + (syntax-match y (quote) + ((quote ()) '()) + (_ (list y))) + (syntax-match (car x) (quote) + ((quote ()) (f (cdr x))) + (_ (cons (car x) (f (cdr x))))))))) + (cond + ((null? ls) (app 'quote '())) + ((null? (cdr ls)) (car ls)) + (else (app* 'append ls)))))) + (define quasivector + (lambda (x) + (let ((pat-x x)) + (syntax-match pat-x (quote) + ((quote (x* ...)) (app 'quote (list->vector x*))) + (_ (let f ((x x) (k (lambda (ls) (app* 'vector ls)))) + (syntax-match x (quote list cons) + ((quote (x* ...)) + (k (map (lambda (x) (app 'quote x)) x*))) + ((list x* ...) + (k x*)) + ((cons x y) + (f y (lambda (ls) (k (cons x ls))))) + (_ (app 'list->vector pat-x))))))))) + (define vquasi + (lambda (p lev) + (syntax-match p () + ((p . q) + (syntax-match p (unquote unquote-splicing) + ((unquote p ...) + (if (= lev 0) + (quasicons* p (vquasi q lev)) + (quasicons + (quasicons (app 'quote 'unquote) + (quasi p (- lev 1))) + (vquasi q lev)))) + ((unquote-splicing p ...) + (if (= lev 0) + (quasiappend p (vquasi q lev)) + (quasicons + (quasicons + (app 'quote 'unquote-splicing) + (quasi p (- lev 1))) + (vquasi q lev)))) + (p (quasicons (quasi p lev) (vquasi q lev))))) + (() (app 'quote '()))))) + (define quasi + (lambda (p lev) + (syntax-match p (unquote unquote-splicing quasiquote) + ((unquote p) + (if (= lev 0) + p + (quasicons (app 'quote 'unquote) (quasi (list p) (- lev 1))))) + (((unquote p ...) . q) + (if (= lev 0) + (quasicons* p (quasi q lev)) + (quasicons + (quasicons (app 'quote 'unquote) (quasi p (- lev 1))) + (quasi q lev)))) + (((unquote-splicing p ...) . q) + (if (= lev 0) + (quasiappend p (quasi q lev)) + (quasicons + (quasicons + (app 'quote 'unquote-splicing) + (quasi p (- lev 1))) + (quasi q lev)))) + ((quasiquote p) + (quasicons (app 'quote 'quasiquote) (quasi (list p) (+ lev 1)))) + ((p . q) (quasicons (quasi p lev) (quasi q lev))) + (#(x ...) (not (stx? x)) (quasivector (vquasi x lev))) + (p (app 'quote p))))) + (lambda (x) + (syntax-match x () + ((_ e) (quasi e 0)))))) + + (define quasisyntax-macro + (let () ;;; FIXME: not really correct + (define quasi + (lambda (p lev) + (syntax-match p (unsyntax unsyntax-splicing quasisyntax) + ((unsyntax p) + (if (= lev 0) + (let ((g (gensym))) + (values (list g) (list p) g)) + (let-values (((lhs* rhs* p) (quasi p (- lev 1)))) + (values lhs* rhs* (list 'unsyntax p))))) + (unsyntax (= lev 0) + (stx-error p "incorrect use of unsyntax")) + (((unsyntax-splicing p) . q) + (let-values (((lhs* rhs* q) (quasi q lev))) + (if (= lev 0) + (let ((g (gensym))) + (values (cons `(,g ...) lhs*) (cons p rhs*) + `(,g ... . ,q))) + (let-values (((lhs2* rhs2* p) (quasi p (- lev 1)))) + (values (append lhs2* lhs*) + (append rhs2* rhs*) + `((unsyntax-splicing ,p) . ,q)))))) + (unsyntax-splicing (= lev 0) + (stx-error p "incorrect use of unsyntax-splicing")) + ((quasisyntax p) + (let-values (((lhs* rhs* p) (quasi p (+ lev 1)))) + (values lhs* rhs* `(quasisyntax ,p)))) + ((p . q) + (let-values (((lhs* rhs* p) (quasi p lev)) + ((lhs2* rhs2* q) (quasi q lev))) + (values (append lhs2* lhs*) + (append rhs2* rhs*) + (cons p q)))) + (#(x ...) (not (stx? p)) + (let-values (((lhs* rhs* x*) + (let f ((x x)) + (cond + ((null? x) (values '() '() '())) + (else + (let-values (((lhs* rhs* a) (quasi (car x) lev))) + (let-values (((lhs2* rhs2* d) (f (cdr x)))) + (values (append lhs* lhs2*) + (append rhs* rhs2*) + (cons a d))))))))) + (values lhs* rhs* (list->vector x*)))) + (_ (values '() '() p))))) + (lambda (x) + (syntax-match x () + ((_ e) + (let-values (((lhs* rhs* v) (quasi e 0))) + (bless + `(syntax-case (list ,@rhs*) () + (,lhs* (syntax ,v)))))))))) + + (define define-record-macro + (if-wants-define-record + (lambda (e) + (define enumerate + (lambda (ls) + (let f ((i 0) (ls ls)) + (cond + ((null? ls) '()) + (else (cons i (f (+ i 1) (cdr ls)))))))) + (define mkid + (lambda (id str) + (datum->stx id (string->symbol str)))) + (syntax-match e () + ((_ name (field* ...)) + (let* ((namestr (symbol->string (id->sym name))) + (fields (map id->sym field*)) + (fieldstr* (map symbol->string fields)) + (rtd (datum->stx name (make-record-type namestr fields))) + (constr (mkid name (string-append "make-" namestr))) + (pred (mkid name (string-append namestr "?"))) + (i* (enumerate field*)) + (getters + (map (lambda (x) + (mkid name (string-append namestr "-" x))) + fieldstr*)) + (setters + (map (lambda (x) + (mkid name (string-append "set-" namestr "-" x "!"))) + fieldstr*))) + (bless + `(begin + (define-syntax ,name (cons '$rtd ',rtd)) + (define ,constr + (lambda ,field* + ($record ',rtd ,@field*))) + (define ,pred + (lambda (x) ($record/rtd? x ',rtd))) + ,@(map (lambda (getter i) + `(define ,getter + (lambda (x) + (if ($record/rtd? x ',rtd) + ($record-ref x ,i) + (error ',getter + "~s is not a record of type ~s" + x ',rtd))))) + getters i*) + ,@(map (lambda (setter i) + `(define ,setter + (lambda (x v) + (if ($record/rtd? x ',rtd) + ($record-set! x ,i v) + (error ',setter + "~s is not a record of type ~s" + x ',rtd))))) + setters i*))))))) + (lambda (stx) + (stx-error stx "define-record not supported")))) + + (define incorrect-usage-macro + (lambda (e) (stx-error e "incorrect usage of auxilary keyword"))) + + (define parameterize-transformer ;;; go away + (lambda (e r mr) + (syntax-match e () + ((_ () b b* ...) + (chi-internal (cons b b*) r mr)) + ((_ ((olhs* orhs*) ...) b b* ...) + (let ((lhs* (map (lambda (x) (gen-lexical 'lhs)) olhs*)) + (rhs* (map (lambda (x) (gen-lexical 'rhs)) olhs*)) + (t* (map (lambda (x) (gen-lexical 't)) olhs*)) + (swap (gen-lexical 'swap))) + (build-let no-source + (append lhs* rhs*) + (append (chi-expr* olhs* r mr) (chi-expr* orhs* r mr)) + (build-let no-source + (list swap) + (list (build-lambda no-source '() + (build-sequence no-source + (map (lambda (t lhs rhs) + (build-let no-source + (list t) + (list (build-application no-source + (build-lexical-reference no-source lhs) + '())) + (build-sequence no-source + (list (build-application no-source + (build-lexical-reference no-source lhs) + (list (build-lexical-reference no-source rhs))) + (build-lexical-assignment no-source rhs + (build-lexical-reference no-source t)))))) + t* lhs* rhs*)))) + (build-application no-source + (build-primref no-source 'dynamic-wind) + (list (build-lexical-reference no-source swap) + (build-lambda no-source '() + (chi-internal (cons b b*) r mr)) + (build-lexical-reference no-source swap)))))))))) + + (define foreign-call-transformer + (lambda (e r mr) + (syntax-match e () + ((_ name arg* ...) + (build-foreign-call no-source + (chi-expr name r mr) + (chi-expr* arg* r mr)))))) + + ;; p in pattern: matches: + ;; () empty list + ;; _ anything (no binding created) + ;; any anything + ;; (p1 . p2) pair + ;; #(free-id ) with free-identifier=? + ;; each-any any proper list + ;; #(each p) (p*) + ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) + ;; #(vector p) #(x ...) if p matches (x ...) + ;; #(atom ) with "equal?" + (define convert-pattern + ; returns syntax-dispatch pattern & ids + (lambda (pattern keys) + (define cvt* + (lambda (p* n ids) + (if (null? p*) + (values '() ids) + (let-values (((y ids) (cvt* (cdr p*) n ids))) + (let-values (((x ids) (cvt (car p*) n ids))) + (values (cons x y) ids)))))) + (define cvt + (lambda (p n ids) + (syntax-match p () + (id (id? id) + (cond + ((bound-id-member? p keys) + (values `#(free-id ,p) ids)) + ((free-id=? p (scheme-stx '_)) + (values '_ ids)) + (else (values 'any (cons (cons p n) ids))))) + ((p dots) (ellipsis? dots) + (let-values (((p ids) (cvt p (+ n 1) ids))) + (values + (if (eq? p 'any) 'each-any `#(each ,p)) + ids))) + ((x dots ys ... . z) (ellipsis? dots) + (let-values (((z ids) (cvt z n ids))) + (let-values (((ys ids) (cvt* ys n ids))) + (let-values (((x ids) (cvt x (+ n 1) ids))) + (values `#(each+ ,x ,(reverse ys) ,z) ids))))) + ((x . y) + (let-values (((y ids) (cvt y n ids))) + (let-values (((x ids) (cvt x n ids))) + (values (cons x y) ids)))) + (() (values '() ids)) + (#(p ...) (not (stx? p)) + (let-values (((p ids) (cvt p n ids))) + (values `#(vector ,p) ids))) + (datum + (values `#(atom ,(stx->datum datum)) ids))))) + (cvt pattern 0 '()))) + + (define syntax-dispatch + (lambda (e p) + (define stx^ + (lambda (e m* s*) + (if (and (null? m*) (null? s*)) + e + (mkstx e m* s*)))) + (define match-each + (lambda (e p m* s*) + (cond + ((pair? e) + (let ((first (match (car e) p m* s* '()))) + (and first + (let ((rest (match-each (cdr e) p m* s*))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((stx? e) + (let-values (((m* s*) (join-wraps m* s* e))) + (match-each (stx-expr e) p m* s*))) + (else #f)))) + (define match-each+ + (lambda (e x-pat y-pat z-pat m* s* r) + (let f ((e e) (m* m*) (s* s*)) + (cond + ((pair? e) + (let-values (((xr* y-pat r) (f (cdr e) m* s*))) + (if r + (if (null? y-pat) + (let ((xr (match (car e) x-pat m* s* '()))) + (if xr + (values (cons xr xr*) y-pat r) + (values #f #f #f))) + (values + '() + (cdr y-pat) + (match (car e) (car y-pat) m* s* r))) + (values #f #f #f)))) + ((stx? e) + (let-values (((m* s*) (join-wraps m* s* e))) + (f (stx-expr e) m* s*))) + (else (values '() y-pat (match e z-pat m* s* r))))))) + (define match-each-any + (lambda (e m* s*) + (cond + ((pair? e) + (let ((l (match-each-any (cdr e) m* s*))) + (and l (cons (stx^ (car e) m* s*) l)))) + ((null? e) '()) + ((stx? e) + (let-values (((m* s*) (join-wraps m* s* e))) + (match-each-any (stx-expr e) m* s*))) + (else #f)))) + (define match-empty + (lambda (p r) + (cond + ((null? p) r) + ((eq? p '_) r) + ((eq? p 'any) (cons '() r)) + ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) + ((eq? p 'each-any) (cons '() r)) + (else + (case (vector-ref p 0) + ((each) (match-empty (vector-ref p 1) r)) + ((each+) + (match-empty + (vector-ref p 1) + (match-empty + (reverse (vector-ref p 2)) + (match-empty (vector-ref p 3) r)))) + ((free-id atom) r) + ((vector) (match-empty (vector-ref p 1) r)) + (else (error 'syntax-dispatch "invalid pattern" p))))))) + (define combine + (lambda (r* r) + (if (null? (car r*)) + r + (cons (map car r*) (combine (map cdr r*) r))))) + (define match* + (lambda (e p m* s* r) + (cond + ((null? p) (and (null? e) r)) + ((pair? p) + (and (pair? e) + (match (car e) (car p) m* s* + (match (cdr e) (cdr p) m* s* r)))) + ((eq? p 'each-any) + (let ((l (match-each-any e m* s*))) (and l (cons l r)))) + (else + (case (vector-ref p 0) + ((each) + (if (null? e) + (match-empty (vector-ref p 1) r) + (let ((r* (match-each e (vector-ref p 1) m* s*))) + (and r* (combine r* r))))) + ((free-id) + (and (symbol? e) + (free-id=? (stx^ e m* s*) (vector-ref p 1)) + r)) + ((each+) + (let-values (((xr* y-pat r) + (match-each+ e (vector-ref p 1) + (vector-ref p 2) (vector-ref p 3) m* s* r))) + (and r + (null? y-pat) + (if (null? xr*) + (match-empty (vector-ref p 1) r) + (combine xr* r))))) + ((atom) (and (equal? (vector-ref p 1) (strip e m*)) r)) + ((vector) + (and (vector? e) + (match (vector->list e) (vector-ref p 1) m* s* r))) + (else (error 'syntax-dispatch "invalid pattern" p))))))) + (define match + (lambda (e p m* s* r) + (cond + ((not r) #f) + ((eq? p '_) r) + ((eq? p 'any) (cons (stx^ e m* s*) r)) + ((stx? e) + (let-values (((m* s*) (join-wraps m* s* e))) + (match (stx-expr e) p m* s* r))) + (else (match* e p m* s* r))))) + (match e p '() '() '()))) + + (define ellipsis? + (lambda (x) + (and (id? x) (free-id=? x (scheme-stx '...))))) + + (define syntax-case-transformer + (let () + (define build-dispatch-call + (lambda (pvars expr y r mr) + (let ((ids (map car pvars)) + (levels (map cdr pvars))) + (let ((labels (map gen-label ids)) + (new-vars (map gen-lexical ids))) + (let ((body + (chi-expr + (add-subst (make-full-rib ids labels) expr) + (append + (map (lambda (label var level) + (cons label (make-binding 'syntax (cons var level)))) + labels new-vars (map cdr pvars)) + r) + mr))) + (build-application no-source + (build-primref no-source 'apply) + (list (build-lambda no-source new-vars body) y))))))) + (define invalid-ids-error + (lambda (id* e class) + (let find ((id* id*) (ok* '())) + (if (null? id*) + (stx-error e) ; shouldn't happen + (if (id? (car id*)) + (if (bound-id-member? (car id*) ok*) + (syntax-error (car id*) "duplicate " class) + (find (cdr id*) (cons (car id*) ok*))) + (syntax-error (car id*) "invalid " class)))))) + (define gen-clause + (lambda (x keys clauses r mr pat fender expr) + (let-values (((p pvars) (convert-pattern pat keys))) + (cond + ((not (distinct-bound-ids? (map car pvars))) + (invalid-ids-error (map car pvars) pat "pattern variable")) + ((not (for-all (lambda (x) (not (ellipsis? (car x)))) pvars)) + (stx-error pat "misplaced ellipsis in syntax-case pattern")) + (else + (let ((y (gen-lexical 'tmp))) + (let ((test + (cond + ((eq? fender #t) y) + (else + (let ((call + (build-dispatch-call + pvars fender y r mr))) + (build-conditional no-source + (build-lexical-reference no-source y) + call + (build-data no-source #f))))))) + (let ((conseq + (build-dispatch-call pvars expr + (build-lexical-reference no-source y) + r mr))) + (let ((altern + (gen-syntax-case x keys clauses r mr))) + (build-application no-source + (build-lambda no-source (list y) + (build-conditional no-source test conseq altern)) + (list + (build-application no-source + (build-primref no-source 'syntax-dispatch) + (list + (build-lexical-reference no-source x) + (build-data no-source p)))))))))))))) + (define gen-syntax-case + (lambda (x keys clauses r mr) + (if (null? clauses) + (build-application no-source + (build-primref no-source 'syntax-error) + (list (build-lexical-reference no-source x))) + (syntax-match (car clauses) () + ((pat expr) + (if (and (id? pat) + (not (bound-id-member? pat keys)) + (not (ellipsis? pat))) + (if (free-id=? pat (scheme-stx '_)) + (chi-expr expr r mr) + (let ((lab (gen-label pat)) + (lex (gen-lexical pat))) + (let ((body + (chi-expr + (add-subst (make-full-rib (list pat) (list lab)) expr) + (cons (cons lab (make-binding 'syntax (cons lex 0))) r) + mr))) + (build-application no-source + (build-lambda no-source (list lex) body) + (list (build-lexical-reference no-source x)))))) + (gen-clause x keys (cdr clauses) r mr pat #t expr))) + ((pat fender expr) + (gen-clause x keys (cdr clauses) r mr pat fender expr)))))) + (lambda (e r mr) + (syntax-match e () + ((_ expr (keys ...) clauses ...) + (begin + (unless (for-all (lambda (x) (and (id? x) (not (ellipsis? x)))) keys) + (stx-error e "invalid literals")) + (let ((x (gen-lexical 'tmp))) + (let ((body (gen-syntax-case x keys clauses r mr))) + (build-application no-source + (build-lambda no-source (list x) body) + (list (chi-expr expr r mr))))))))))) + (define syntax-transformer + (let () + (define gen-syntax + (lambda (src e r maps ellipsis? vec?) + (syntax-match e () + (dots (ellipsis? dots) + (stx-error src "misplaced ellipsis in syntax form")) + (id (id? id) + (let* ((label (id->label e)) + (b (label->binding label r))) + (if (eq? (binding-type b) 'syntax) + (let-values (((var maps) + (let ((var.lev (binding-value b))) + (gen-ref src (car var.lev) (cdr var.lev) maps)))) + (values (list 'ref var) maps)) + (values (list 'quote e) maps)))) + ((dots e) (ellipsis? dots) + (if vec? + (stx-error src "misplaced ellipsis in syntax form") + (gen-syntax src e r maps (lambda (x) #f) #f))) + ((x dots . y) (ellipsis? dots) + (let f ((y y) + (k (lambda (maps) + (let-values (((x maps) + (gen-syntax src x r + (cons '() maps) ellipsis? #f))) + (if (null? (car maps)) + (stx-error src + "extra ellipsis in syntax form") + (values (gen-map x (car maps)) (cdr maps))))))) + (syntax-match y () + (() (k maps)) + ((dots . y) (ellipsis? dots) + (f y + (lambda (maps) + (let-values (((x maps) (k (cons '() maps)))) + (if (null? (car maps)) + (stx-error src "extra ellipsis in syntax form") + (values (gen-mappend x (car maps)) (cdr maps))))))) + (_ + (let-values (((y maps) + (gen-syntax src y r maps ellipsis? vec?))) + (let-values (((x maps) (k maps))) + (values (gen-append x y) maps))))))) + ((x . y) + (let-values (((xnew maps) + (gen-syntax src x r maps ellipsis? #f))) + (let-values (((ynew maps) + (gen-syntax src y r maps ellipsis? vec?))) + (values (gen-cons e x y xnew ynew) maps)))) + (#(ls ...) (not (stx? e)) + (let-values (((lsnew maps) + (gen-syntax src ls r maps ellipsis? #t))) + (values (gen-vector e ls lsnew) maps))) + (_ (values `(quote ,e) maps))))) + (define gen-ref + (lambda (src var level maps) + (if (= level 0) + (values var maps) + (if (null? maps) + (stx-error src "missing ellipsis in syntax form") + (let-values (((outer-var outer-maps) + (gen-ref src var (- level 1) (cdr maps)))) + (cond + ((assq outer-var (car maps)) => + (lambda (b) (values (cdr b) maps))) + (else + (let ((inner-var (gen-lexical 'tmp))) + (values + inner-var + (cons + (cons (cons outer-var inner-var) (car maps)) + outer-maps)))))))))) + (define gen-append + (lambda (x y) + (if (equal? y '(quote ())) x `(append ,x ,y)))) + (define gen-mappend + (lambda (e map-env) + `(apply (primitive append) ,(gen-map e map-env)))) + (define gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) `(ref ,(car x))) map-env))) + (cond + ; identity map equivalence: + ; (map (lambda (x) x) y) == y + ((eq? (car e) 'ref) + (car actuals)) + ; eta map equivalence: + ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) + ((for-all + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + (let ((args (map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e)))) + `(map (primitive ,(car e)) . ,args))) + (else (cons* 'map (list 'lambda formals e) actuals)))))) + (define gen-cons + (lambda (e x y xnew ynew) + (case (car ynew) + ((quote) + (if (eq? (car xnew) 'quote) + (let ((xnew (cadr xnew)) (ynew (cadr ynew))) + (if (and (eq? xnew x) (eq? ynew y)) + `(quote ,e) + `(quote ,(cons xnew ynew)))) + (if (null? (cadr ynew)) + `(list ,xnew) + `(cons ,xnew ,ynew)))) + ((list) `(list ,xnew . ,(cdr ynew))) + (else `(cons ,xnew ,ynew))))) + (define gen-vector + (lambda (e ls lsnew) + (cond + ((eq? (car lsnew) 'quote) + (if (eq? (cadr lsnew) ls) + `(quote ,e) + `(quote #(,@(cadr lsnew))))) + ((eq? (car lsnew) 'list) + `(vector . ,(cdr lsnew))) + (else `(list->vector ,lsnew))))) + (define regen + (lambda (x) + (case (car x) + ((ref) (build-lexical-reference no-source (cadr x))) + ((primitive) (build-primref no-source (cadr x))) + ((quote) (build-data no-source (cadr x))) + ((lambda) (build-lambda no-source (cadr x) (regen (caddr x)))) + ((map) + (let ((ls (map regen (cdr x)))) + (build-application no-source + (build-primref no-source 'map) + ls))) + (else + (build-application no-source + (build-primref no-source (car x)) + (map regen (cdr x))))))) + (lambda (e r mr) + (syntax-match e () + ((_ x) + (let-values (((e maps) (gen-syntax e x r '() ellipsis? #f))) + (regen e))))))) + + (define core-macro-transformer + (lambda (name) + (case name + ((quote) quote-transformer) + ((lambda) lambda-transformer) + ((case-lambda) case-lambda-transformer) + ((let-values) let-values-transformer) + ((letrec) letrec-transformer) + ((letrec*) letrec*-transformer) + ((case) case-transformer) + ((if) if-transformer) + ((when) when-transformer) + ((unless) unless-transformer) + ((parameterize) parameterize-transformer) + ((foreign-call) foreign-call-transformer) + ((syntax-case) syntax-case-transformer) + ((syntax) syntax-transformer) + ((type-descriptor) type-descriptor-transformer) + (else (error 'macro-transformer "cannot find ~s" name))))) + + (define macro-transformer + (lambda (x) + (cond + ((procedure? x) x) + ((symbol? x) + (case x + ((define-record) define-record-macro) + ((include) include-macro) + ((cond) cond-macro) + ((let) let-macro) + ((do) do-macro) + ((or) or-macro) + ((and) and-macro) + ((let*) let*-macro) + ((syntax-rules) syntax-rules-macro) + ((quasiquote) quasiquote-macro) + ((quasisyntax) quasisyntax-macro) + ((with-syntax) with-syntax-macro) + ((identifier-syntax) identifier-syntax-macro) + ((time) time-macro) + ((delay) delay-macro) + ((assert) assert-macro) + ((endianness) endianness-macro) + ((trace-lambda) trace-lambda-macro) + ((trace-define) trace-define-macro) + ((... => _ else unquote unquote-splicing + unsyntax unsyntax-splicing) + incorrect-usage-macro) + (else (error 'macro-transformer "invalid macro ~s" x)))) + (else (error 'core-macro-transformer "invalid macro ~s" x))))) + + (define (local-macro-transformer x) + (car x)) + + ;;; chi procedures + (define chi-macro + (lambda (p e) + (let ((s ((macro-transformer p) (add-mark anti-mark e)))) + (add-mark (gen-mark) s)))) + + (define chi-local-macro + (lambda (p e) + (let ((s ((local-macro-transformer p) (add-mark anti-mark e)))) + (add-mark (gen-mark) s)))) + + (define (chi-global-macro p e) + ;;; FIXME: does not handle macro!? + (let ((lib (car p)) + (loc (cdr p))) + (visit-library lib) + (let ((x (symbol-value loc))) + (let ((transformer + (cond + ((procedure? x) x) + (else (error 'chi-global-macro "~s is not a procedure"))))) + (let ((s (transformer (add-mark anti-mark e)))) + (add-mark (gen-mark) s)))))) + + (define chi-expr* + (lambda (e* r mr) + ;;; expand left to right + (cond + ((null? e*) '()) + (else + (let ((e (chi-expr (car e*) r mr))) + (cons e (chi-expr* (cdr e*) r mr))))))) + + (define chi-application + (lambda (e r mr) + (syntax-match e () + ((rator rands ...) + (let ((rator (chi-expr rator r mr))) + (build-application no-source + rator + (chi-expr* rands r mr))))))) + + (define chi-expr + (lambda (e r mr) + (let-values (((type value kwd) (syntax-type e r))) + (case type + ((core-macro) + (let ((transformer (core-macro-transformer value))) + (transformer e r mr))) + ((global) + (let* ((lib (car value)) + (loc (cdr value))) + ((inv-collector) lib) + (build-global-reference no-source loc))) + ((core-prim) + (let ((name value)) + (build-primref no-source name))) + ((call) (chi-application e r mr)) + ((lexical) + (let ((lex value)) + (build-lexical-reference no-source lex))) + ((global-macro global-macro!) + (chi-expr (chi-global-macro value e) r mr)) + ((local-macro local-macro!) (chi-expr (chi-local-macro value e) r mr)) + ((macro macro!) (chi-expr (chi-macro value e) r mr)) + ((constant) + (let ((datum value)) + (build-data no-source datum))) + ((set!) (chi-set! e r mr)) + ((begin) + (syntax-match e () + ((_ x x* ...) + (build-sequence no-source + (chi-expr* (cons x x*) r mr))))) + ((let-syntax letrec-syntax) + (syntax-match e () + ((_ ((xlhs* xrhs*) ...) xbody xbody* ...) + (unless (valid-bound-ids? xlhs*) + (stx-error e "invalid identifiers")) + (let* ((xlab* (map gen-label xlhs*)) + (xrib (make-full-rib xlhs* xlab*)) + (xb* (map (lambda (x) + (make-eval-transformer + (expand-transformer + (if (eq? type 'let-syntax) x (add-subst xrib x)) + mr))) + xrhs*))) + (build-sequence no-source + (chi-expr* + (map (lambda (x) (add-subst xrib x)) (cons xbody xbody*)) + (append (map cons xlab* xb*) r) + (append (map cons xlab* xb*) mr))))))) + ((displaced-lexical) + (stx-error e "identifier out of context")) + ((syntax) (stx-error e "reference to pattern variable outside a syntax form")) + ((define define-syntax module import) + (stx-error e "invalid expression")) + (else + ;(error 'chi-expr "invalid type ~s for ~s" type (strip e '())) + (stx-error e "invalid expression")))))) + + (define chi-set! + (lambda (e r mr) + (syntax-match e () + ((_ x v) (id? x) + (let-values (((type value kwd) (syntax-type x r))) + (case type + ((lexical) + (build-lexical-assignment no-source + value + (chi-expr v r mr))) + ((global core-prim) + (stx-error e "cannot modify imported identifier in")) + ((global-macro!) + (chi-expr (chi-global-macro value e) r mr)) + ((local-macro!) + (chi-expr (chi-local-macro value e) r mr)) + (else (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 (make-full-rib x* lab*) body*) + (add-lexicals lab* lex* r) + mr))) + (stx-error fmls "invalid fmls"))) + ((x* ... . x) + (if (valid-bound-ids? (cons x 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 + (make-full-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-lambda-clause* + (lambda (fmls* body** r mr) + (cond + ((null? fmls*) (values '() '())) + (else + (let-values (((a b) + (chi-lambda-clause (car fmls*) (car body**) r mr))) + (let-values (((a* b*) + (chi-lambda-clause* (cdr fmls*) (cdr body**) r mr))) + (values (cons a a*) (cons b b*)))))))) + + (define chi-rhs + (lambda (rhs r mr) + (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))) + ((top-expr) + (let ((expr (cdr rhs))) + (build-sequence no-source + (list (chi-expr expr r mr) + (build-void))))) + (else (error 'chi-rhs "invalid rhs ~s" rhs))))) + + (define chi-rhs* + (lambda (rhs* r mr) + (let f ((ls rhs*)) + (cond ;;; chi-rhs in order + ((null? ls) '()) + (else + (let ((a (chi-rhs (car ls) r mr))) + (cons a (f (cdr ls))))))))) + + (define find-bound=? + (lambda (x lhs* rhs*) + (cond + ((null? lhs*) #f) + ((bound-id=? x (car lhs*)) (car rhs*)) + (else (find-bound=? x (cdr lhs*) (cdr rhs*)))))) + + (define (find-dups ls) + (let f ((ls ls) (dups '())) + (cond + ((null? ls) dups) + ((find-bound=? (car ls) (cdr ls) (cdr ls)) => + (lambda (x) (f (cdr ls) (cons (list (car ls) x) dups)))) + (else (f (cdr ls) dups))))) + + (define chi-internal + (lambda (e* r mr) + (let ((rib (make-empty-rib))) + (let-values (((e* r mr lex* rhs* mod** kwd*) + (chi-body* (map (lambda (x) (add-subst rib x)) + (syntax->list e*)) + r mr '() '() '() '() rib #f))) + (when (null? e*) + (stx-error e* "no expression in body")) + (let ((rhs* (chi-rhs* rhs* r mr)) + (init* (chi-expr* (append (apply append (reverse mod**)) e*) r mr))) + (build-letrec* no-source + (reverse lex*) (reverse rhs*) + (build-sequence no-source init*))))))) + + (define parse-module + (lambda (e) + (syntax-match e () + ((_ (export* ...) b* ...) + (begin + (unless (for-all id? export*) + (stx-error e "module exports must be identifiers")) + (values #f export* b*))) + ((_ name (export* ...) b* ...) + (begin + (unless (id? name) + (stx-error e "module name must be an identifier")) + (unless (for-all id? export*) + (stx-error e "module exports must be identifiers")) + (values name export* b*)))))) + + (define chi-internal-module + (lambda (e r mr lex* rhs* mod** kwd*) + (let-values (((name exp-id* e*) (parse-module e))) + (let* ((rib (make-empty-rib)) + (e* (map (lambda (x) (add-subst rib x)) (syntax->list e*)))) + (let-values (((e* r mr lex* rhs* mod** kwd*) + (chi-body* e* r mr lex* rhs* mod** kwd* rib #f))) + (let ((exp-lab* + (map (lambda (x) + (or (id->label (add-subst rib x)) + (stx-error x "cannot find module export"))) + exp-id*)) + (mod** (cons e* mod**))) + (if (not name) ;;; explicit export + (values lex* rhs* exp-id* exp-lab* r mr mod** kwd*) + (let ((lab (gen-label 'module)) + (iface (cons exp-id* exp-lab*))) + (values lex* rhs* + (list name) ;;; FIXME: module cannot + (list lab) ;;; export itself yet + (cons (cons lab (cons '$module iface)) r) + (cons (cons lab (cons '$module iface)) mr) + mod** kwd*))))))))) + + (define chi-body* + (lambda (e* r mr lex* rhs* mod** kwd* rib top?) + (cond + ((null? e*) (values e* r mr lex* rhs* mod** kwd*)) + (else + (let ((e (car e*))) + (let-values (((type value kwd) (syntax-type e r))) + (let ((kwd* (if (id? kwd) (cons kwd kwd*) kwd*))) + (case type + ((define) + (let-values (((id rhs) (parse-define e))) + (when (bound-id-member? id kwd*) + (stx-error e "cannot redefine keyword")) + (let ((lex (gen-lexical id)) + (lab (gen-label id))) + (extend-rib! rib id lab) + (chi-body* (cdr e*) + (add-lexical lab lex r) mr + (cons lex lex*) (cons rhs rhs*) + mod** kwd* rib top?)))) + ((define-syntax) + (let-values (((id rhs) (parse-define-syntax e))) + (when (bound-id-member? id kwd*) + (stx-error e "cannot redefine keyword")) + (let ((lab (gen-label id)) + (expanded-rhs (expand-transformer rhs mr))) + (extend-rib! rib id lab) + (let ((b (make-eval-transformer expanded-rhs))) + (chi-body* (cdr e*) + (cons (cons lab b) r) (cons (cons lab b) mr) + lex* rhs* mod** kwd* rib top?))))) + ((let-syntax letrec-syntax) + (syntax-match e () + ((_ ((xlhs* xrhs*) ...) xbody* ...) + (unless (valid-bound-ids? xlhs*) + (stx-error e "invalid identifiers")) + (let* ((xlab* (map gen-label xlhs*)) + (xrib (make-full-rib xlhs* xlab*)) + (xb* (map (lambda (x) + (make-eval-transformer + (expand-transformer + (if (eq? type 'let-syntax) x (add-subst xrib x)) + mr))) + xrhs*))) + (chi-body* + (append (map (lambda (x) (add-subst xrib x)) xbody*) (cdr e*)) + (append (map cons xlab* xb*) r) + (append (map cons xlab* xb*) mr) + lex* rhs* mod** kwd* rib top?))))) + ((begin) + (syntax-match e () + ((_ x* ...) + (chi-body* (append x* (cdr e*)) + r mr lex* rhs* mod** kwd* rib top?)))) + ((global-macro global-macro!) + (chi-body* + (cons (add-subst rib (chi-global-macro value e)) (cdr e*)) + r mr lex* rhs* mod** kwd* rib top?)) + ((local-macro local-macro!) + (chi-body* + (cons (add-subst rib (chi-local-macro value e)) (cdr e*)) + r mr lex* rhs* mod** kwd* rib top?)) + ((macro macro!) + (chi-body* + (cons (add-subst rib (chi-macro value e)) (cdr e*)) + r mr lex* rhs* mod** kwd* rib top?)) + ((module) + (let-values (((lex* rhs* m-exp-id* m-exp-lab* r mr mod** kwd*) + (chi-internal-module e r mr lex* rhs* mod** kwd*))) + (for-each + (lambda (id lab) (extend-rib! rib id lab)) + m-exp-id* m-exp-lab*) + (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?))) + ((import) + (let () + (define (module-import e r) + (syntax-match e () + ((_ id) (id? id) + (let-values (((type value kwd) (syntax-type id r))) + (case type + (($module) + (let ((iface value)) + (let ((id* (car iface)) (lab* (cdr iface))) + (values id* lab*)))) + (else (stx-error e "invalid import"))))))) + (let-values (((id* lab*) (module-import e r))) + (for-each + (lambda (id lab) (extend-rib! rib id lab)) + id* lab*))) + (chi-body* (cdr e*) r mr lex* rhs* mod** kwd* rib top?)) + (else + (if top? + (chi-body* (cdr e*) r mr + (cons (gen-lexical 'dummy) lex*) + (cons (cons 'top-expr e) rhs*) + mod** kwd* rib top?) + (values e* r mr lex* rhs* mod** kwd*))))))))))) + + (define set-global-macro-binding! + (lambda (sym loc b) + (extend-library-subst! (interaction-library) sym loc) + (extend-library-env! (interaction-library) loc b))) + + (define gen-global-macro-binding + (lambda (id ctxt) (gen-global-var-binding id ctxt))) + + (define gen-global-var-binding + (lambda (id ctxt) + (let ((label (id->label id))) + (let ((b (imported-label->binding label))) + (case (binding-type b) + ((global) + (let ((x (binding-value b))) + (let ((lib (car x)) (loc (cdr x))) + (cond + ((eq? lib (interaction-library)) + loc) + (else + (stx-error ctxt "cannot modify imported binding")))))) + (else (stx-error ctxt "cannot modify binding in"))))))) + + (define chi-top-set! + (lambda (e) + (syntax-match e () + ((_ id rhs) (id? id) + (let ((loc (gen-global-var-binding id e))) + (let ((rhs (chi-expr rhs '() '()))) + (values loc rhs))))))) + + (define chi-top* + (lambda (e* init*) + (cond + ((null? e*) init*) + (else + (let ((e (car e*))) + (let-values (((type value kwd) (syntax-type e '()))) + (case type + ((define) + (let-values (((id rhs) (parse-define e))) + (let ((loc (gen-global-var-binding id e))) + (let ((rhs (chi-rhs rhs '() '()))) + (chi-top* (cdr e*) (cons (cons loc rhs) init*)))))) + ((set!) + (let-values (((loc rhs) (chi-top-set! e))) + (chi-top* (cdr e*) (cons (cons loc rhs) init*)))) + ((define-syntax) + (let-values (((id rhs) (parse-define-syntax e))) + (let ((loc (gen-global-macro-binding id e))) + (let ((expanded-rhs (expand-transformer rhs '()))) + (let ((b (make-eval-transformer expanded-rhs))) + (set-global-macro-binding! (id->sym id) loc b) + (chi-top* (cdr e*) init*)))))) + ((let-syntax letrec-syntax) + (error 'chi-top* "~s is not supported yet at top level" type)) + ((begin) + (syntax-match e () + ((_ x* ...) + (chi-top* (append x* (cdr e*)) init*)))) + ((global-macro global-macro!) + (chi-top* (cons (chi-global-macro value e) (cdr e*)) init*)) + ((local-macro local-macro!) + (chi-top* (cons (chi-local-macro value e) (cdr e*)) init*)) + ((macro macro!) + (chi-top* (cons (chi-macro value e) (cdr e*)) init*)) + (else + (chi-top* (cdr e*) + (cons (cons #f (chi-expr e '() '())) + init*)))))))))) + + (define (expand-transformer expr r) + (let ((rtc (make-collector))) + (let ((expanded-rhs + (parameterize ((inv-collector rtc) + (vis-collector (lambda (x) (values)))) + (chi-expr expr r r)))) + (for-each + (let ((mark-visit (vis-collector))) + (lambda (x) + (invoke-library x) + (mark-visit x))) + (rtc)) + expanded-rhs))) + + (define (parse-exports exp*) + (let f ((exp* exp*) (int* '()) (ext* '())) + (cond + ((null? exp*) + (let ((id* (map (lambda (x) (mkstx x top-mark* '())) ext*))) + (unless (valid-bound-ids? id*) + (error 'expander "invalid exports of ~s" (find-dups id*)))) + (values int* ext*)) + (else + (syntax-match (car exp*) () + ((rename (i* e*) ...) + (begin + (unless (and (eq? rename 'rename) (for-all symbol? i*) + (for-all symbol? e*)) + (error 'expander "invalid export specifier ~s" (car exp*))) + (f (cdr exp*) (append i* int*) (append e* ext*)))) + (ie + (begin + (unless (symbol? ie) (error 'expander "invalid export ~s" ie)) + (f (cdr exp*) (cons ie int*) (cons ie ext*))))))))) + + ;;; given a library name, like (foo bar (1 2 3)), + ;;; returns the identifiers and the version of the library + ;;; as (foo bar) (1 2 3). + (define (parse-library-name x) + (define (parse x) + (syntax-match x () + ((x* ... (v* ...)) + (and (for-all symbol? x*) + (for-all (lambda (x) (and (integer? x) (exact? x))) v*)) + (values x* v*)) + ((x* ...) (for-all symbol? x*) + (values x* '())) + (_ (stx-error x "invalid library name")))) + (let-values (((name* ver*) (parse x))) + (when (null? name*) (stx-error x "empty library name")) + (values name* ver*))) + + ;;; given a library form, returns the name part, the export + ;;; specs, import specs and the body of the library. + (define parse-library + (lambda (e) + (syntax-match e () + ((library (name* ...) + (export exp* ...) + (import imp* ...) + b* ...) + (and (eq? export 'export) (eq? import 'import) (eq? library 'library)) + (values name* exp* imp* b*)) + (_ (stx-error e "malformed library"))))) + + ;;; given a list of import-specs, return a subst and the list of + ;;; libraries that were imported. + ;;; Example: given ((rename (only (foo) x z) (x y)) (only (bar) q)) + ;;; returns: ((z . z$label) (y . x$label) (q . q$label)) + ;;; and (# #) + (define (parse-import-spec* imp*) + (define imp-collector (make-collector)) + (define (merge-substs s subst) + (define (insert-to-subst a subst) + (let ((name (car a)) (label (cdr a))) + (cond + ((assq name subst) => + (lambda (x) + (cond + ((eq? (cdr x) label) subst) + (else + (error 'import + "two imports of ~s with different bindings" + name))))) + (else + (cons a subst))))) + (cond + ((null? s) subst) + (else + (insert-to-subst (car s) + (merge-substs (cdr s) subst))))) + (define (exclude* sym* subst) + (define (exclude sym subst) + (cond + ((null? subst) + (error 'import "cannot rename unbound identifier ~s" sym)) + ((eq? sym (caar subst)) + (values (cdar subst) (cdr subst))) + (else + (let ((a (car subst))) + (let-values (((old subst) (exclude sym (cdr subst)))) + (values old (cons a subst))))))) + (cond + ((null? sym*) (values '() subst)) + (else + (let-values (((old subst) (exclude (car sym*) subst))) + (let-values (((old* subst) (exclude* (cdr sym*) subst))) + (values (cons old old*) subst)))))) + (define (find* sym* subst) + (map (lambda (x) + (cond + ((assq x subst) => cdr) + (else (error 'import "cannot find identifier ~s" x)))) + sym*)) + (define (rem* sym* subst) + (let f ((subst subst)) + (cond + ((null? subst) '()) + ((memq (caar subst) sym*) (f (cdr subst))) + (else (cons (car subst) (f (cdr subst))))))) + (define (remove-dups ls) + (cond + ((null? ls) '()) + ((memq (car ls) (cdr ls)) (remove-dups (cdr ls))) + (else (cons (car ls) (remove-dups (cdr ls)))))) + (define (get-import spec) + (syntax-match spec () + ((rename isp (old* new*) ...) + (and (eq? rename 'rename) (for-all symbol? old*) (for-all symbol? new*)) + (let ((subst (get-import isp))) + (let ((old-label* (find* old* subst))) + (let ((subst (rem* old* subst))) + ;;; FIXME: make sure map is valid + (merge-substs (map cons new* old-label*) subst))))) + ((except isp sym* ...) + (and (eq? except 'except) (for-all symbol? sym*)) + (let ((subst (get-import isp))) + (rem* sym* subst))) + ((only isp sym* ...) + (and (eq? only 'only) (for-all symbol? sym*)) + (let ((subst (get-import isp))) + (let ((sym* (remove-dups sym*))) + (let ((lab* (find* sym* subst))) + (map cons sym* lab*))))) + ((prefix isp p) + (and (eq? prefix 'prefix) (symbol? p)) + (let ((subst (get-import isp))) + (map + (lambda (x) + (cons + (string->symbol + (string-append + (symbol->string p) + (symbol->string (car x)))) + (cdr x))) + subst))) + ((library name) (eq? library 'library) + (let ((lib (find-library-by-name name))) + (unless lib + (error 'import "cannot find library satisfying ~s" name)) + (imp-collector lib) + (library-subst lib))) + ((x x* ...) + (not (memq x '(rename except only prefix library))) + (get-import `(library (,x . ,x*)))) + (spec (error 'import "invalid import spec ~s" spec)))) + (let f ((imp* imp*) (subst '())) + (cond + ((null? imp*) (values subst (imp-collector))) + (else + (f (cdr imp*) (merge-substs (get-import (car imp*)) subst)))))) + + ;;; a top rib is constructed as follows: + ;;; given a subst: name* -> label*, + ;;; generate a rib containing: + ;;; - name* as the rib-sym*, + ;;; - a list of top-mark* as the rib-mark** + ;;; - label* as the rib-label* + ;;; so, a name in a top rib maps to its label if and only if + ;;; its set of marks is top-mark*. + (define (make-top-rib subst) + (let ((rib (make-empty-rib))) + (for-each + (lambda (x) + (let ((name (car x)) (label (cdr x))) + (extend-rib! rib (mkstx name top-mark* '()) label))) + subst) + rib)) + + (define (make-collector) + (let ((ls '())) + (case-lambda + (() ls) + ((x) (set! ls (set-cons x ls)))))) + + (define inv-collector + (make-parameter + (lambda args + (error 'inv-collector "not initialized")) + (lambda (x) + (unless (procedure? x) + (error 'inv-collector "~s is not a procedure" x)) + x))) + + (define vis-collector + (make-parameter + (lambda args + (error 'vis-collector "not initialized")) + (lambda (x) + (unless (procedure? x) + (error 'vis-collector "~s is not a procedure" x)) + x))) + + (define chi-library-internal + (lambda (e* rib top?) + (let-values (((e* r mr lex* rhs* mod** _kwd*) + (chi-body* e* '() '() '() '() '() '() rib top?))) + (values (append (apply append (reverse mod**)) e*) + r mr (reverse lex*) (reverse rhs*))))) + + (define library-body-expander + (lambda (exp* imp* b*) + (let-values (((exp-int* exp-ext*) (parse-exports exp*)) + ((subst imp*) (parse-import-spec* imp*))) + (let ((rib (make-top-rib subst))) + (let ((b* (map (lambda (x) (mkstx x top-mark* (list rib))) b*)) + (rtc (make-collector)) + (vtc (make-collector))) + (parameterize ((inv-collector rtc) + (vis-collector vtc)) + (let-values (((init* r mr lex* rhs*) + (chi-library-internal b* rib #f))) + (seal-rib! rib) + (let ((rhs* (chi-rhs* rhs* r mr)) + (init* (chi-expr* init* r mr))) + (unseal-rib! rib) + (let ((export-subst (make-export-subst exp-int* exp-ext* rib))) + (let-values (((export-env global* macro*) + (make-export-env/macros r))) + (let ((invoke-body + (build-letrec* no-source lex* rhs* + (build-exports global* init*))) + (invoke-definitions + (map build-global-define (map cdr global*)))) + (values + imp* (rtc) (vtc) + (build-sequence no-source + (append invoke-definitions + (list invoke-body))) + macro* export-subst export-env)))))))))))) + + (define core-library-expander + (lambda (e) + (let-values (((name* exp* imp* b*) (parse-library e))) + (let-values (((name ver) (parse-library-name name*))) + (let-values (((imp* invoke-req* visit-req* invoke-code + visit-code export-subst export-env) + (library-body-expander exp* imp* b*))) + (values name imp* invoke-req* visit-req* + invoke-code visit-code export-subst + export-env)))))) + + (define (parse-top-level-program e*) + (syntax-match e* () + (((import imp* ...) b* ...) (eq? import 'import) + (values imp* b*)) + (_ (error "invalid syntax of top-level program")))) + + (define top-level-expander + (lambda (e*) + (let-values (((imp* b*) (parse-top-level-program e*))) + (let-values (((imp* invoke-req* visit-req* invoke-code + visit-code export-subst export-env) + (library-body-expander '() imp* b*))) + (values invoke-req* invoke-code))))) + + ;;; An env record encapsulates a substitution and a set of + ;;; libraries. + (define-record env (subst imp*) + (lambda (x p) + (unless (env? x) + (error 'record-type-printer "not an environment")) + (display "#" p))) + + (define environment? + (lambda (x) (env? x))) + + ;;; This is R6RS's environment. It parses the import specs + ;;; and constructs an env record that can be used later by + ;;; eval and/or expand. + (define environment + (lambda imp* + (let-values (((subst imp*) (parse-import-spec* imp*))) + (make-env subst imp*)))) + + ;;; R6RS's null-environment and scheme-report-environment are + ;;; constructed simply using the corresponding libraries. + (define (null-environment n) + (unless (eqv? n 5) + (error 'null-environment "~s is not 5" n)) + (environment '(psyntax null-environment-5))) + (define (scheme-report-environment n) + (unless (eqv? n 5) + (error 'scheme-report-environment "~s is not 5" n)) + (environment '(psyntax scheme-report-environment-5))) + + ;;; The expand procedure is the interface to the internal expression + ;;; expander (chi-expr). It takes an expression and an environment. + ;;; It returns two values: The resulting core-expression and a list of + ;;; libraries that must be invoked before evaluating the core expr. + (define expand + (lambda (x env) + (unless (env? env) + (error 'expand "~s is not an environment" env)) + (let ((subst (env-subst env))) + (let ((rib (make-top-rib subst))) + (let ((x (mkstx x top-mark* (list rib))) + (rtc (make-collector)) + (vtc (make-collector))) + (let ((x + (parameterize ((inv-collector rtc) + (vis-collector vtc)) + (chi-expr x '() '())))) + (seal-rib! rib) + (values x (rtc)))))))) + + ;;; This is R6RS's eval. It takes an expression and an environment, + ;;; expands the expression, invokes its invoke-required libraries and + ;;; evaluates its expanded core form. + (define eval + (lambda (x env) + (unless (env? env) + (error 'eval "~s is not an environment" env)) + (let-values (((x invoke-req*) (expand x env))) + (for-each invoke-library invoke-req*) + (eval-core (expanded->core x))))) + + ;;; Given a (library . _) s-expression, library-expander expands + ;;; it to core-form, registers it with the library manager, and + ;;; returns its invoke-code, visit-code, subst and env. + (define (library-expander x) + (define (build-visit-code macro*) + (if (null? macro*) + (build-void) + (build-sequence no-source + (map (lambda (x) + (let ((loc (car x)) (src (cddr x))) + (build-global-assignment no-source loc src))) + macro*)))) + (define (visit! macro*) + (for-each (lambda (x) + (let ((loc (car x)) (proc (cadr x))) + (set-symbol-value! loc proc))) + macro*)) + (let-values (((name imp* inv* vis* invoke-code macro* export-subst export-env) + (core-library-expander x))) + (let ((id (gensym)) + (name name) + (ver '()) ;;; FIXME + (imp* (map library-spec imp*)) + (vis* (map library-spec vis*)) + (inv* (map library-spec inv*))) + (install-library id name ver + imp* vis* inv* export-subst export-env + (lambda () (visit! macro*)) + (lambda () (eval-core (expanded->core invoke-code))) + #t) + (values invoke-code + (build-visit-code macro*) + export-subst export-env)))) + + ;;; when bootstrapping the system, visit-code is not (and cannot + ;;; be) be used in the "next" system. So, we drop it. + (define (boot-library-expand x) + (let-values (((invoke-code visit-code export-subst export-env) + (library-expander x))) + (values invoke-code export-subst export-env))) + + (define (rev-map-append f ls ac) + (cond + ((null? ls) ac) + (else + (rev-map-append f (cdr ls) + (cons (f (car ls)) ac))))) + + (define build-exports + (lambda (lex*+loc* init*) + (build-sequence no-source + (cons (build-void) + (rev-map-append + (lambda (x) + (build-global-assignment no-source (cdr x) (car x))) + lex*+loc* + init*))))) + + (define (make-export-subst int* ext* rib) + (map + (lambda (int ext) + (let* ((id (mkstx int top-mark* (list rib))) + (label (id->label id))) + (unless label + (stx-error id "cannot export unbound identifier")) + (cons ext label))) + int* ext*)) + + (define (make-export-env/macros r) + (let f ((r r) (env '()) (global* '()) (macro* '())) + (cond + ((null? r) (values env global* macro*)) + (else + (let ((x (car r))) + (let ((label (car x)) (b (cdr x))) + (case (binding-type b) + ((lexical) + (let ((loc (gen-global (binding-value b)))) + (f (cdr r) + (cons (cons* label 'global loc) env) + (cons (cons (binding-value b) loc) global*) + macro*))) + ((local-macro) + (let ((loc (gensym))) + (f (cdr r) + (cons (cons* label 'global-macro loc) env) + global* + (cons (cons loc (binding-value b)) macro*)))) + ((local-macro!) + (let ((loc (gensym))) + (f (cdr r) + (cons (cons* label 'global-macro! loc) env) + global* + (cons (cons loc (binding-value b)) macro*)))) + (($rtd $module) (f (cdr r) (cons x env) global* macro*)) + (else + (error 'expander "BUG: do not know how to export ~s ~s" + (binding-type b) (binding-value b)))))))))) + + (define generate-temporaries + (lambda (ls) + (syntax-match ls () + ((ls ...) + (map (lambda (x) (make-stx (gensym 't) top-mark* '())) ls)) + (_ + (error 'generate-temporaries "~s is not a list"))))) + + (define free-identifier=? + (lambda (x y) + (if (id? x) + (if (id? y) + (free-id=? x y) + (error 'free-identifier=? "~s is not an identifier" y)) + (error 'free-identifier=? "~s is not an identifier" x)))) + + (define bound-identifier=? + (lambda (x y) + (if (id? x) + (if (id? y) + (bound-id=? x y) + (error 'bound-identifier=? "~s is not an identifier" y)) + (error 'bound-identifier=? "~s is not an identifier" x)))) + + (define syntax-error + (lambda (x . args) + (unless (for-all string? args) + (error 'syntax-error "invalid argument ~s" args)) + (if (null? args) + (error 'expander "invalid syntax ~s" (stx->datum x)) + (error 'expander "~s ~a" (stx->datum x) (apply string-append args))))) + + (define identifier? (lambda (x) (id? x))) + + (define datum->syntax + (lambda (id datum) + (if (id? id) + (datum->stx id datum) + (error 'datum->syntax "~s is not an identifier" id)))) + + (define syntax->datum + (lambda (x) (stx->datum x))) + + (define eval-r6rs-top-level + (lambda (x*) + (let-values (((lib* invoke-code) (top-level-expander x*))) + (for-each invoke-library lib*) + (eval-core (expanded->core invoke-code))))) + + ;;; The interaction-library is a parameter that is either #f + ;;; (the default, for r6rs scripts) or set to an extensible library + ;;; that serves as the base for an r5rs-like top-level environment. + ;;; The identifiers in the top-level library are copied on demand from + ;;; the (ikarus) library which contains all the public bindings of the + ;;; system. + + (define interaction-library (make-parameter #f)) + + (define (interaction-sym->label sym) + (cond + ((interaction-library) => + (lambda (lib) + (cond + ((assq sym (library-subst lib)) => cdr) + (else + (let ((subst + (if (library-exists? '(ikarus)) + (library-subst (find-library-by-name '(ikarus))) + '()))) + (cond + ((assq sym subst) => + (lambda (sym/lab) + (let ((label (cdr sym/lab))) + (extend-library-subst! lib sym label) + label))) + (else + (let ((label (gen-label sym))) + (extend-library-subst! lib sym label) + (extend-library-env! lib label + (cons 'global (cons lib (gen-global sym)))) + label)))))))) + (else #f))) + + (define eval-top-level + (lambda (x) + (define (eval-binding x) + (let ((loc (car x)) (expr (cdr x))) + (cond + (loc (set-symbol-value! loc (eval-core (expanded->core expr)))) + (else (eval-core (expanded->core expr)))))) + (let ((rtc (make-collector)) + (vtc (make-collector))) + (let ((init* + (parameterize ((inv-collector rtc) + (vis-collector vtc) + (interaction-library + (find-library-by-name '(ikarus interaction)))) + (chi-top* (list (mkstx x top-mark* '())) '())))) + (for-each invoke-library (rtc)) + (unless (null? init*) + (for-each eval-binding (reverse (cdr init*))) + (eval-binding (car init*))))))) + + ;;; register the expander with the library manager + (current-library-expander library-expander)) + + + diff --git a/src/psyntax.internal.ss b/src/psyntax.internal.ss new file mode 100644 index 0000000..b7b2bd5 --- /dev/null +++ b/src/psyntax.internal.ss @@ -0,0 +1,27 @@ +;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining a +;;; copy of this software and associated documentation files (the "Software"), +;;; to deal in the Software without restriction, including without limitation +;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;;; and/or sell copies of the Software, and to permit persons to whom the +;;; Software is furnished to do so, subject to the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be included in +;;; all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;;; DEALINGS IN THE SOFTWARE. + +(library (psyntax internal) + (export current-primitive-locations compile-core-expr-to-port expanded->core) + (import (rnrs) (psyntax compat) (ikarus compiler)) + + (define (expanded->core x) x)) + +