conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* reintegrated the expander from the psyntax distro.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-09 08:54:28 -04:00
parent 09fd6ff1b3
commit 687c45dd6f
10 changed files with 3189 additions and 721 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

2
src/ikarus.cafe.ss
View File

@ -25,7 +25,7 @@ description:
(library (ikarus cafe) (library (ikarus cafe)
(export new-cafe) (export new-cafe)
(import (import
(only (ikarus syntax) eval-top-level) (only (psyntax expander) eval-top-level)
(except (ikarus) new-cafe)) (except (ikarus) new-cafe))
(define with-error-handler (define with-error-handler

20
src/ikarus.compiler.ss
View File

@ -153,6 +153,8 @@
(define (Var x) (define (Var x)
(or (getprop x *cookie*) (or (getprop x *cookie*)
(error 'recordize "unbound ~s" x))) (error 'recordize "unbound ~s" x)))
(define (lexical x)
(getprop x *cookie*))
(define (E x) (define (E x)
(cond (cond
[(pair? x) [(pair? x)
@ -165,7 +167,14 @@
(E (cadddr x)))] (E (cadddr x)))]
[(set!) [(set!)
(let ([lhs (cadr x)] [rhs (caddr x)]) (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) [(begin)
(let f ([a (E (cadr x))] [d (cddr x)]) (let f ([a (E (cadr x))] [d (cddr x)])
(cond (cond
@ -210,6 +219,9 @@
[(|#primitive|) [(|#primitive|)
(let ([var (cadr x)]) (let ([var (cadr x)])
(make-primref var))] (make-primref var))]
[(primitive)
(let ([var (cadr x)])
(make-primref var))]
[(top-level-value) [(top-level-value)
(let ([var (quoted-sym (cadr x))]) (let ([var (quoted-sym (cadr x))])
(make-funcall (make-funcall
@ -222,7 +234,11 @@
(make-constant (void))] (make-constant (void))]
[else [else
(make-funcall (E (car x)) (map E (cdr x)))])] (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)])) [else (error 'recordize "invalid expression ~s" x)]))
(E x)) (E x))

2
src/ikarus.load.ss
View File

@ -3,7 +3,7 @@
(export load load-r6rs-top-level) (export load load-r6rs-top-level)
(import (import
(except (ikarus) load) (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)) (only (ikarus reader) read-initial))
(define load-handler (define load-handler

761
src/makefile.ss
View File

@ -63,8 +63,13 @@
"ikarus.fasl.write.ss" "ikarus.fasl.write.ss"
"ikarus.fasl.ss" "ikarus.fasl.ss"
"ikarus.compiler.ss" "ikarus.compiler.ss"
"psyntax.compat.ss"
"psyntax.library-manager.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.load.ss"
"ikarus.pretty-print.ss" "ikarus.pretty-print.ss"
"ikarus.cafe.ss" "ikarus.cafe.ss"
@ -189,6 +194,7 @@
[$stack (ikarus system $stack) #f #t] [$stack (ikarus system $stack) #f #t]
[$interrupts (ikarus system $interrupts) #f #t] [$interrupts (ikarus system $interrupts) #f #t]
[$all (ikarus system $all) #f #t] [$all (ikarus system $all) #f #t]
[$all2 (psyntax system $all) #f #t]
[$boot (ikarus system $bootstrap) #f #t] [$boot (ikarus system $bootstrap) #f #t]
)) ))
@ -423,6 +429,7 @@
[$set-symbol-string! $symbols] [$set-symbol-string! $symbols]
[$set-symbol-unique-string! $symbols] [$set-symbol-unique-string! $symbols]
[$set-symbol-plist! $symbols] [$set-symbol-plist! $symbols]
[$init-symbol-value! ]
[$unbound-object? $symbols] [$unbound-object? $symbols]
[base-rtd $records] [base-rtd $records]
[$record-set! $records] [$record-set! $records]
@ -1216,715 +1223,6 @@
[syntax-error i sc] [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]
[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-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>? i r]
[string>=? i r]
[string-ci=? i uc]
[string-ci<? i uc]
[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]
[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]
[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 (verify-map)
(define (f x) (define (f x)
@ -1974,7 +1272,8 @@
(export-primlocs (cons x (cdr binding)))] (export-primlocs (cons x (cdr binding)))]
[else [else
(error #f "invalid binding ~s for ~s" p x)])))] (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 [else
;;; core primitive with no backing definition, assumed to ;;; core primitive with no backing definition, assumed to
;;; be defined in other strata of the system ;;; be defined in other strata of the system
@ -2015,7 +1314,7 @@
[visit-libs '()] [visit-libs '()]
[invoke-libs '()]) [invoke-libs '()])
(let-values ([(subst env) (let-values ([(subst env)
(if (equal? name '(ikarus system $all)) (if (equal? name '(psyntax system $all))
(values export-subst export-env) (values export-subst export-env)
(values (values
(get-export-subset key export-subst) (get-export-subset key export-subst)
@ -2041,10 +1340,40 @@
(boot-library-expand code)]) (boot-library-expand code)])
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) (define (expand-all files)
(let ([code* '()] (define (prune-subst subst env)
[subst '()] (cond
[env '()]) ((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 (for-each
(lambda (file) (lambda (file)
(printf "expanding ~s\n" file) (printf "expanding ~s\n" file)
@ -2057,7 +1386,7 @@
(set! env (append export-env env)))))) (set! env (append export-env env))))))
files) files)
(let-values ([(export-subst export-env export-locs) (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)]) (let ([code (build-system-library export-subst export-env export-locs)])
(values (values
(reverse (cons* (car code*) code (cdr code*))) (reverse (cons* (car code*) code (cdr code*)))

145
src/psyntax.builders.ss Normal file
View File

@ -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)))))))))
)

4
src/psyntax/compat.ss → src/psyntax.compat.ss
View File

@ -1,7 +1,9 @@
(library (psyntax compat) (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 (import
(only (ikarus compiler) eval-core)
(rename (ikarus) (define-record sys.define-record))) (rename (ikarus) (define-record sys.define-record)))
(define-syntax define-record (define-syntax define-record

64
src/psyntax.config.ss Normal file
View File

@ -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 <global> '#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)
)

2885
src/psyntax.expander.ss Normal file
View File

File diff suppressed because it is too large Load Diff

27
src/psyntax.internal.ss Normal file
View File

@ -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))