* reintegrated the expander from the psyntax distro.
This commit is contained in:
Abdulaziz Ghuloum
parent
09fd6ff1b3
commit
687c45dd6f
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
761
src/makefile.ss
761
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]
|
||||
[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 (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*)))
|
||||
|
|
|
|||
|
|
@ -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)))))))))
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue