- Added cp0! including:
- (optimize-level [0,1,2]) and ikarus -O[0,1,2]
where -O0 = no optimizations
-O1 = using old optimizer
-O2 = using the new cp0 optimizer
defaults to -O1 for now.
- (cp0-size-limit n) which is the limit of the residual size for
each inlining attempt
- (cp0-effort-limit n) which is the limit on the effort expended
for each inlining attempt
- Rewrote the syntax-match macro to make use of the same technology
used in syntax-case itself resulting in reduced code size.
- Added (system-value <symbol>) which returns the system value.
E.g., (system-value 'car) => #<procedure car>
This is pretty much the same as
(eval <symbol> (environment '(ikarus)))
except that it does not involve compiling the expression or
consulting the library/expander systems.
- Fixed the fasl loader to make it understand complex numbers.
This commit is contained in:
Abdulaziz Ghuloum
parent
7d9ed176ac
commit
45346ef865
|
|
@ -1,7 +1,10 @@
|
|||
#!../src/ikarus -b ../scheme/ikarus.boot --r6rs-script
|
||||
|
||||
(import (ikarus))
|
||||
|
||||
(optimize-level 2)
|
||||
;(cp0-effort-limit 1000)
|
||||
;(cp0-size-limit 100)
|
||||
;(debug-optimizer #t)
|
||||
(define (run name)
|
||||
(let ([proc (time-it (format "compile-~a" name)
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -2,17 +2,17 @@
|
|||
|
||||
(import (ikarus))
|
||||
|
||||
;(define all-benchmarks
|
||||
; '(ack array1 bibfreq boyer browse cat compiler conform cpstak ctak dderiv
|
||||
; deriv destruc diviter divrec dynamic earley fft fib fibc fibfp
|
||||
; fpsum gcbench gcold graphs lattice matrix maze mazefun mbrot
|
||||
; nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval
|
||||
; pi pnpoly primes puzzle quicksort ray sboyer scheme simplex
|
||||
; slatex string sum sum1 sumfp sumloop tail tak takl trav1 trav2
|
||||
; triangl wc))
|
||||
|
||||
(define all-benchmarks
|
||||
'(cat tail wc slatex))
|
||||
'(ack array1 bibfreq boyer browse cat compiler conform cpstak ctak dderiv
|
||||
deriv destruc diviter divrec dynamic earley fft fib fibc fibfp
|
||||
fpsum gcbench #|gcold|# graphs lattice matrix maze mazefun mbrot
|
||||
nbody nboyer nqueens ntakl nucleic paraffins parsing perm9 peval
|
||||
pi pnpoly primes puzzle quicksort ray sboyer scheme simplex
|
||||
slatex string sum sum1 sumfp sumloop tail tak takl trav1 trav2
|
||||
triangl wc))
|
||||
|
||||
;(define all-benchmarks
|
||||
; '(cat tail wc slatex))
|
||||
|
||||
|
||||
(define cmd
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -999,4 +999,9 @@
|
|||
|
||||
)
|
||||
|
||||
|
||||
(library (ikarus system bytevectors)
|
||||
(export $bytevector-u8-ref $bytevector-length $make-bytevector)
|
||||
(import (ikarus))
|
||||
(define $bytevector-u8-ref bytevector-u8-ref)
|
||||
(define $bytevector-length bytevector-length)
|
||||
(define $make-bytevector make-bytevector))
|
||||
|
|
|
|||
|
|
@ -226,6 +226,11 @@
|
|||
(err ($car c*))))))
|
||||
(err c2)))))
|
||||
(err c1))])))
|
||||
|
||||
|
||||
)
|
||||
|
||||
(library (ikarus system chars)
|
||||
(export $char->fixnum $fixnum->char)
|
||||
(import (ikarus))
|
||||
(define $char->fixnum char->integer)
|
||||
(define $fixnum->char integer->char))
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -19,7 +19,7 @@
|
|||
assembler-output scc-letrec optimize-cp
|
||||
current-primitive-locations eval-core
|
||||
compile-core-expr
|
||||
cp0-effort-limit cp0-size-limit)
|
||||
cp0-effort-limit cp0-size-limit optimize-level)
|
||||
(import
|
||||
(rnrs hashtables)
|
||||
(ikarus system $fx)
|
||||
|
|
@ -27,7 +27,7 @@
|
|||
(only (ikarus system $codes) $code->closure)
|
||||
(only (ikarus system $structs) $struct-ref $struct/rtd?)
|
||||
(except (ikarus)
|
||||
optimize-level
|
||||
optimize-level debug-optimizer
|
||||
fasl-write scc-letrec optimize-cp
|
||||
compile-core-expr-to-port assembler-output
|
||||
current-primitive-locations eval-core
|
||||
|
|
@ -433,7 +433,7 @@
|
|||
[else (cons (E x) ac)]))
|
||||
(cons 'begin (f e0 (f e1 '()))))]
|
||||
[(clambda-case info body)
|
||||
`( label: ,(case-info-label info)
|
||||
`( ; label: ,(case-info-label info)
|
||||
,(E-args (case-info-proper info) (case-info-args info))
|
||||
,(E body))]
|
||||
[(clambda g cls* cp free)
|
||||
|
|
@ -1100,34 +1100,6 @@
|
|||
x)
|
||||
|
||||
|
||||
#|FIXME:missing-optimizations
|
||||
111 cadr
|
||||
464 $record/rtd?
|
||||
404 memq
|
||||
249 map
|
||||
114 not
|
||||
451 car
|
||||
224 syntax-error
|
||||
248 $syntax-dispatch
|
||||
237 pair?
|
||||
125 length
|
||||
165 $cdr
|
||||
137 $car
|
||||
805 $record-ref
|
||||
181 fixnum?
|
||||
328 null?
|
||||
136 fx-
|
||||
207 eq?
|
||||
153 call-with-values
|
||||
165 values
|
||||
336 apply
|
||||
384 cdr
|
||||
898 cons
|
||||
747 error
|
||||
555 void
|
||||
645 list
|
||||
|#
|
||||
|
||||
|
||||
;;; FIXME URGENT: should handle (+ x k), (- x k) where k is a fixnum
|
||||
;;; also fx+, fx-
|
||||
|
|
@ -1524,6 +1496,12 @@
|
|||
(giveup)]
|
||||
))
|
||||
|
||||
;;; $car $cdr $struct-ref $struct/rtd?
|
||||
;;; expt + * - fx+ fxadd1 fxsub1
|
||||
;;; cons cons* list vector
|
||||
;;; length memq memv eq? eqv?
|
||||
;;; not null? pair? fixnum? vector? string? char? symbol? eof-object?
|
||||
;;; cadr void car cdr
|
||||
|
||||
(define (mk-mvcall p c)
|
||||
(struct-case p
|
||||
|
|
@ -1819,10 +1797,13 @@
|
|||
[(mvcall p c)
|
||||
(mk-mvcall (Value p) (Value c))]
|
||||
[else (error who "invalid value expression" (unparse x))]))
|
||||
(let ([x (Value x)])
|
||||
;;; since we messed up the references and assignments here, we
|
||||
;;; redo them
|
||||
(uncover-assigned/referenced x)))
|
||||
(case (optimize-level)
|
||||
[(1)
|
||||
(let ([x (Value x)])
|
||||
;;; since we messed up the references and assignments here, we
|
||||
;;; redo them
|
||||
(uncover-assigned/referenced x))]
|
||||
[else x]))
|
||||
|
||||
|
||||
(define (rewrite-assignments x)
|
||||
|
|
@ -2998,9 +2979,6 @@
|
|||
[else
|
||||
(printf " ~s\n" x)]))
|
||||
|
||||
|
||||
(define optimizer 'old)
|
||||
|
||||
(define (compile-core-expr->code p)
|
||||
(let* ([p (recordize p)]
|
||||
[p (parameterize ([open-mvcalls #f])
|
||||
|
|
@ -3008,13 +2986,9 @@
|
|||
[p (if (scc-letrec)
|
||||
(optimize-letrec/scc p)
|
||||
(optimize-letrec p))]
|
||||
[p (if (eq? optimizer 'new)
|
||||
(source-optimize p)
|
||||
p)]
|
||||
[p (source-optimize p)]
|
||||
[p (uncover-assigned/referenced p)]
|
||||
[p (if (eq? optimizer 'old)
|
||||
(copy-propagate p)
|
||||
p)]
|
||||
[p (copy-propagate p)] ;;; old optimizer
|
||||
[p (rewrite-assignments p)]
|
||||
[p (sanitize-bindings p)]
|
||||
[p (optimize-for-direct-jumps p)]
|
||||
|
|
|
|||
|
|
@ -581,3 +581,30 @@
|
|||
)
|
||||
|
||||
|
||||
(library (ikarus fixnums unsafe)
|
||||
(export $fxzero? $fxadd1 $fxsub1
|
||||
$fx+ $fx* $fx- $fx= $fx< $fx<= $fx> $fx>=
|
||||
$fxsll $fxsra $fxlogor $fxlogand $fxlognot)
|
||||
(import (ikarus))
|
||||
(define $fxzero? fxzero?)
|
||||
(define $fxadd1 fxadd1)
|
||||
(define $fxsub1 fxsub1)
|
||||
(define $fx+ fx+)
|
||||
(define $fx* fx*)
|
||||
(define $fx- fx-)
|
||||
(define $fx= fx=)
|
||||
(define $fx< fx<)
|
||||
(define $fx<= fx<=)
|
||||
(define $fx> fx>)
|
||||
(define $fx>= fx>=)
|
||||
(define $fxsll fxsll)
|
||||
(define $fxsra fxsra)
|
||||
(define $fxlogor fxlogor)
|
||||
(define $fxlogand fxlogand)
|
||||
(define $fxlognot fxlognot))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -74,6 +74,15 @@
|
|||
(let f ([args (command-line-arguments)])
|
||||
(cond
|
||||
[(null? args) (values '() #f #f '())]
|
||||
[(string=? (car args) "-O2")
|
||||
(optimize-level 2)
|
||||
(f (cdr args))]
|
||||
[(string=? (car args) "-O1")
|
||||
(optimize-level 1)
|
||||
(f (cdr args))]
|
||||
[(string=? (car args) "-O0")
|
||||
(optimize-level 0)
|
||||
(f (cdr args))]
|
||||
[(string=? (car args) "--")
|
||||
(values '() #f #f (cdr args))]
|
||||
[(string=? (car args) "--script")
|
||||
|
|
|
|||
|
|
@ -3699,3 +3699,8 @@
|
|||
[else
|
||||
(die 'imag-part "not a number" x)])))
|
||||
)
|
||||
|
||||
(library (ikarus system flonums)
|
||||
(export $fixnum->flonum)
|
||||
(import (ikarus))
|
||||
(define $fixnum->flonum fixnum->flonum))
|
||||
|
|
|
|||
|
|
@ -102,3 +102,11 @@
|
|||
[cdaddr $cdr $car $cdr $cdr]
|
||||
[cadddr $car $cdr $cdr $cdr]
|
||||
[cddddr $cdr $cdr $cdr $cdr]))
|
||||
|
||||
|
||||
(library (ikarus system pairs)
|
||||
(export $car $cdr)
|
||||
(import (ikarus))
|
||||
(define $car car)
|
||||
(define $cdr cdr))
|
||||
|
||||
|
|
|
|||
|
|
@ -286,3 +286,13 @@
|
|||
(display (rtd-name x) p)
|
||||
(display " rtd>" p)))
|
||||
)
|
||||
|
||||
|
||||
(library (ikarus systems structs)
|
||||
(export $struct-ref $struct/rtd?)
|
||||
(import (ikarus))
|
||||
(define $struct-ref struct-ref)
|
||||
(define ($struct/rtd? x rtd)
|
||||
(import (ikarus system $structs))
|
||||
($struct/rtd? x rtd)))
|
||||
|
||||
|
|
|
|||
|
|
@ -14,19 +14,19 @@
|
|||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(library (ikarus base symbols)
|
||||
(library (ikarus.symbols)
|
||||
(export gensym gensym? gensym->unique-string gensym-prefix
|
||||
gensym-count print-gensym string->symbol symbol->string
|
||||
getprop putprop remprop property-list
|
||||
top-level-value top-level-bound? set-top-level-value!
|
||||
symbol-value symbol-bound? set-symbol-value!
|
||||
reset-symbol-proc!)
|
||||
reset-symbol-proc! system-value system-value-gensym)
|
||||
(import
|
||||
(ikarus system $symbols)
|
||||
(ikarus system $pairs)
|
||||
(ikarus system $fx)
|
||||
(except (ikarus) gensym gensym? gensym->unique-string
|
||||
gensym-prefix gensym-count print-gensym
|
||||
gensym-prefix gensym-count print-gensym system-value
|
||||
string->symbol symbol->string
|
||||
getprop putprop remprop property-list
|
||||
top-level-value top-level-bound? set-top-level-value!
|
||||
|
|
@ -223,5 +223,21 @@
|
|||
(die 'print-gensym "not in #t|#f|pretty" x))
|
||||
x)))
|
||||
|
||||
(define system-value-gensym (gensym))
|
||||
|
||||
(define (system-value x)
|
||||
(unless (symbol? x)
|
||||
(die 'system-value "not a symbol" x))
|
||||
(cond
|
||||
[(getprop x system-value-gensym) =>
|
||||
(lambda (g)
|
||||
(let ([v ($symbol-value g)])
|
||||
(when ($unbound-object? v)
|
||||
(die 'system-value "not a system symbol" x))
|
||||
v))]
|
||||
[else (die 'system-value "not a system symbol" x)]))
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -279,3 +279,11 @@
|
|||
(f v ($fxadd1 i) n fill))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
(library (ikarus system vectors)
|
||||
(export $vector-ref $vector-length)
|
||||
(import (ikarus))
|
||||
(define $vector-ref vector-ref)
|
||||
(define $vector-length vector-length))
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1521
|
||||
1522
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#!../src/ikarus -b ikarus.boot --r6rs-script
|
||||
#!../src/ikarus -b ikarus.boot -O2 --r6rs-script
|
||||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
|
||||
;;;
|
||||
|
|
@ -17,7 +17,7 @@
|
|||
;;; vim:syntax=scheme
|
||||
(import (only (ikarus) import))
|
||||
(import (except (ikarus)
|
||||
assembler-output scc-letrec optimize-cp
|
||||
assembler-output scc-letrec optimize-cp optimize-level
|
||||
cp0-size-limit cp0-effort-limit))
|
||||
(import (ikarus.compiler))
|
||||
(import (except (psyntax system $bootstrap)
|
||||
|
|
@ -25,6 +25,7 @@
|
|||
current-primitive-locations
|
||||
compile-core-expr-to-port))
|
||||
(import (ikarus.compiler)) ; just for fun
|
||||
(optimize-level 2)
|
||||
|
||||
(pretty-width 160)
|
||||
((pretty-format 'fix) ((pretty-format 'letrec)))
|
||||
|
|
@ -1311,6 +1312,7 @@
|
|||
[void i $boot]
|
||||
[gensym i symbols $boot]
|
||||
[symbol-value i symbols $boot]
|
||||
[system-value i]
|
||||
[set-symbol-value! i symbols $boot]
|
||||
[eval-core $boot]
|
||||
[pretty-print i $boot]
|
||||
|
|
@ -1432,6 +1434,7 @@
|
|||
[ellipsis-map ]
|
||||
[scc-letrec i]
|
||||
[optimize-cp i]
|
||||
[optimize-level i]
|
||||
[cp0-size-limit i]
|
||||
[cp0-effort-limit i]
|
||||
))
|
||||
|
|
@ -1589,16 +1592,19 @@
|
|||
(let ([code `(library (ikarus primlocs)
|
||||
(export) ;;; must be empty
|
||||
(import
|
||||
(only (ikarus.symbols) system-value-gensym)
|
||||
(only (psyntax library-manager)
|
||||
install-library)
|
||||
(only (ikarus.compiler)
|
||||
current-primitive-locations)
|
||||
(ikarus))
|
||||
(current-primitive-locations
|
||||
(lambda (x)
|
||||
(cond
|
||||
[(assq x ',primlocs) => cdr]
|
||||
[else #f])))
|
||||
(let ([g system-value-gensym])
|
||||
(for-each
|
||||
(lambda (x) (putprop (car x) g (cdr x)))
|
||||
',primlocs)
|
||||
(let ([proc
|
||||
(lambda (x) (getprop x g))])
|
||||
(current-primitive-locations proc)))
|
||||
,@(map build-library library-legend))])
|
||||
(let-values ([(name code empty-subst empty-env)
|
||||
(boot-library-expand code)])
|
||||
|
|
@ -1699,6 +1705,7 @@
|
|||
(debugf "\n")))
|
||||
(close-output-port p)))))
|
||||
|
||||
;(print-missing-prims)
|
||||
|
||||
(printf "Happy Happy Joy Joy\n")
|
||||
|
||||
|
|
|
|||
|
|
@ -108,6 +108,19 @@
|
|||
[(P x y) (prm '= (T x) (T y))]
|
||||
[(E x y) (nop)])
|
||||
|
||||
(define (equable-constant? x)
|
||||
(struct-case x
|
||||
[(constant xv) (equable? xv)]
|
||||
[else #f]))
|
||||
|
||||
(define-primop eqv? safe
|
||||
[(P x y)
|
||||
(if (or (equable-constant? x)
|
||||
(equable-constant? y))
|
||||
(prm '= (T x) (T y))
|
||||
(interrupt))]
|
||||
[(E x y) (nop)])
|
||||
|
||||
(define-primop null? safe
|
||||
[(P x) (prm '= (T x) (K nil))]
|
||||
[(E x) (nop)])
|
||||
|
|
@ -201,6 +214,44 @@
|
|||
[else (interrupt)])]
|
||||
[(E x ls) (nop)])
|
||||
|
||||
(define-primop memq safe
|
||||
[(P x ls) (cogen-pred-$memq x ls)]
|
||||
[(V x ls) (cogen-value-$memq x ls)]
|
||||
[(E x ls)
|
||||
(struct-case ls
|
||||
[(constant ls)
|
||||
(cond
|
||||
[(list? ls) (nop)]
|
||||
[else (interrupt)])]
|
||||
[else (interrupt)])])
|
||||
|
||||
(define (equable? x)
|
||||
(or (fixnum? x) (not (number? x))))
|
||||
|
||||
(define-primop memv safe
|
||||
[(V x ls)
|
||||
(struct-case ls
|
||||
[(constant lsv)
|
||||
(cond
|
||||
[(and (list? lsv) (andmap equable? lsv))
|
||||
(cogen-value-$memq x ls)]
|
||||
[else (interrupt)])]
|
||||
[else (interrupt)])]
|
||||
[(P x ls)
|
||||
(struct-case ls
|
||||
[(constant lsv)
|
||||
(cond
|
||||
[(and (list? lsv) (andmap equable? lsv))
|
||||
(cogen-pred-$memq x ls)]
|
||||
[else (interrupt)])]
|
||||
[else (interrupt)])]
|
||||
[(E x ls)
|
||||
(struct-case ls
|
||||
[(constant lsv)
|
||||
(cond
|
||||
[(list? lsv) (nop)]
|
||||
[else (interrupt)])]
|
||||
[else (interrupt)])])
|
||||
|
||||
/section)
|
||||
|
||||
|
|
|
|||
|
|
@ -764,118 +764,83 @@
|
|||
;;; 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))))))))
|
||||
(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 free-identifier-member?
|
||||
(lambda (x ls)
|
||||
(and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t)))
|
||||
(define (bound-id-member? x ls)
|
||||
(and (pair? ls)
|
||||
(or (sys.bound-identifier=? x (car ls))
|
||||
(bound-id-member? x (cdr ls)))))
|
||||
(define ellipsis?
|
||||
(lambda (x)
|
||||
(and (sys.identifier? x)
|
||||
(sys.free-identifier=? x (syntax (... ...))))))
|
||||
(define cvt
|
||||
(lambda (p n ids)
|
||||
(syntax-case p ()
|
||||
(id (sys.identifier? #'id)
|
||||
(cond
|
||||
((bound-id-member? p keys)
|
||||
(values `#(scheme-id ,(sys.syntax->datum p)) ids))
|
||||
((sys.free-identifier=? p #'_)
|
||||
(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 ...)
|
||||
(let-values (((p ids) (cvt #'(p ...) n ids)))
|
||||
(values `#(vector ,p) ids)))
|
||||
(datum
|
||||
(values `#(atom ,(sys.syntax->datum #'datum)) ids)))))
|
||||
(cvt pattern 0 '())))
|
||||
(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* ...)))))))))))
|
||||
((_ expr (lits ...) [pat fender body] cls* ...)
|
||||
(for-all sys.identifier? (syntax (lits ...)))
|
||||
(let-values ([(pattern ids/levels) (convert-pattern #'pat #'(lits ...))])
|
||||
(with-syntax ([pattern (sys.datum->syntax #'here pattern)]
|
||||
[([ids . levels] ...) ids/levels])
|
||||
#'(let ([t expr])
|
||||
(let ([ls/false (syntax-dispatch t 'pattern)])
|
||||
(if (and ls/false (apply (lambda (ids ...) fender) ls/false))
|
||||
(apply (lambda (ids ...) body) ls/false)
|
||||
(syntax-match t (lits ...) cls* ...)))))))
|
||||
((_ expr (lits ...) [pat body] cls* ...)
|
||||
(for-all sys.identifier? (syntax (lits ...)))
|
||||
(let-values ([(pattern ids/levels) (convert-pattern #'pat #'(lits ...))])
|
||||
(with-syntax ([pattern (sys.datum->syntax #'here pattern)]
|
||||
[([ids . levels] ...) ids/levels])
|
||||
#'(let ([t expr])
|
||||
(let ([ls/false (syntax-dispatch t 'pattern)])
|
||||
(if ls/false
|
||||
(apply (lambda (ids ...) body) ls/false)
|
||||
(syntax-match t (lits ...) cls* ...)))))))
|
||||
((_ expr (lits ...) [pat body] cls* ...)
|
||||
#'(syntax-match expr (lits ...) [pat #t body] cls* ...)))))
|
||||
|
||||
|
||||
(define parse-define
|
||||
|
|
@ -906,7 +871,7 @@
|
|||
(let* ((subst
|
||||
(library-subst
|
||||
(find-library-by-name '(psyntax system $all))))
|
||||
(stx (mkstx sym top-mark* '() '()))
|
||||
(stx (make-stx sym top-mark* '() '()))
|
||||
(stx
|
||||
(cond
|
||||
((assq sym subst) =>
|
||||
|
|
@ -2157,7 +2122,7 @@
|
|||
(lambda (e p)
|
||||
(define stx^
|
||||
(lambda (e m* s* ae*)
|
||||
(if (and (null? m*) (null? s*))
|
||||
(if (and (null? m*) (null? s*) (null? ae*))
|
||||
e
|
||||
(mkstx e m* s* ae*))))
|
||||
(define match-each
|
||||
|
|
@ -2233,6 +2198,7 @@
|
|||
(reverse (vector-ref p 2))
|
||||
(match-empty (vector-ref p 3) r))))
|
||||
((free-id atom) r)
|
||||
((scheme-id atom) r)
|
||||
((vector) (match-empty (vector-ref p 1) r))
|
||||
(else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
|
||||
(define combine
|
||||
|
|
@ -2262,6 +2228,12 @@
|
|||
(top-marked? m*)
|
||||
(free-id=? (stx^ e m* s* ae*) (vector-ref p 1))
|
||||
r))
|
||||
((scheme-id)
|
||||
(and (symbol? e)
|
||||
(top-marked? m*)
|
||||
(free-id=? (stx^ e m* s* ae*)
|
||||
(scheme-stx (vector-ref p 1)))
|
||||
r))
|
||||
((each+)
|
||||
(let-values (((xr* y-pat r)
|
||||
(match-each+ e (vector-ref p 1)
|
||||
|
|
@ -2992,7 +2964,7 @@
|
|||
(vector-map
|
||||
(lambda (x)
|
||||
(or (id->label
|
||||
(mkstx (id->sym x) (stx-mark* x)
|
||||
(make-stx (id->sym x) (stx-mark* x)
|
||||
(list rib)
|
||||
'()))
|
||||
(stx-error x "cannot find module export")))
|
||||
|
|
@ -3503,7 +3475,7 @@
|
|||
(parse-import-spec* imp*)))
|
||||
(let ((rib (make-top-rib subst-names subst-labels)))
|
||||
(let ((b* (map (lambda (x)
|
||||
(mkstx x top-mark* (list rib) '()))
|
||||
(make-stx x top-mark* (list rib) '()))
|
||||
b*))
|
||||
(rtc (make-collector))
|
||||
(vtc (make-collector)))
|
||||
|
|
@ -3628,7 +3600,7 @@
|
|||
(cond
|
||||
[(env? env)
|
||||
(let ((rib (make-top-rib (env-names env) (env-labels env))))
|
||||
(let ((x (mkstx x top-mark* (list rib) '()))
|
||||
(let ((x (make-stx x top-mark* (list rib) '()))
|
||||
(itc (env-itc env))
|
||||
(rtc (make-collector))
|
||||
(vtc (make-collector)))
|
||||
|
|
@ -3741,7 +3713,7 @@
|
|||
(define (make-export-subst int* ext* rib)
|
||||
(map
|
||||
(lambda (int ext)
|
||||
(let* ((id (mkstx int top-mark* (list rib) '()))
|
||||
(let* ((id (make-stx int top-mark* (list rib) '()))
|
||||
(label (id->label id)))
|
||||
(unless label
|
||||
(stx-error id "cannot export unbound identifier"))
|
||||
|
|
|
|||
|
|
@ -557,6 +557,28 @@ static ikptr do_read(ikpcb* pcb, fasl_port* p){
|
|||
}
|
||||
return x;
|
||||
}
|
||||
else if(c == 'i'){
|
||||
ikptr real = do_read(pcb, p);
|
||||
ikptr imag = do_read(pcb, p);
|
||||
ikptr x;
|
||||
if ((tagof(real) == vector_tag)
|
||||
&& (ref(real, -vector_tag) == flonum_tag)){
|
||||
x = ik_unsafe_alloc(pcb, cflonum_size);
|
||||
ref(x, 0) = cflonum_tag;;
|
||||
ref(x, disp_cflonum_real) = real;
|
||||
ref(x, disp_cflonum_imag) = imag;
|
||||
} else {
|
||||
x = ik_unsafe_alloc(pcb, compnum_size);
|
||||
ref(x, 0) = compnum_tag;
|
||||
ref(x, disp_compnum_real) = real;
|
||||
ref(x, disp_compnum_imag) = imag;
|
||||
}
|
||||
x += vector_tag;
|
||||
if(put_mark_index){
|
||||
p->marks[put_mark_index] = x;
|
||||
}
|
||||
return x;
|
||||
}
|
||||
else {
|
||||
fprintf(stderr, "invalid type '%c' (0x%02x) found in fasl file\n", c, c);
|
||||
exit(-1);
|
||||
|
|
|
|||
Loading…
Reference in New Issue