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

- 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 2008-06-28 02:25:44 -07:00
parent 7d9ed176ac
commit 45346ef865
20 changed files with 756 additions and 975 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
benchmarks/bench.ss
View File

@ -1,7 +1,10 @@
#!../src/ikarus -b ../scheme/ikarus.boot --r6rs-script #!../src/ikarus -b ../scheme/ikarus.boot --r6rs-script
(import (ikarus)) (import (ikarus))
(optimize-level 2)
;(cp0-effort-limit 1000)
;(cp0-size-limit 100)
;(debug-optimizer #t)
(define (run name) (define (run name)
(let ([proc (time-it (format "compile-~a" name) (let ([proc (time-it (format "compile-~a" name)
(lambda () (lambda ()

20
benchmarks/benchall.ss
View File

@ -2,17 +2,17 @@
(import (ikarus)) (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 (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 (define cmd

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

7
scheme/ikarus.bytevectors.ss
View File

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

9
scheme/ikarus.chars.ss
View File

@ -226,6 +226,11 @@
(err ($car c*)))))) (err ($car c*))))))
(err c2))))) (err c2)))))
(err c1))]))) (err c1))])))
) )
(library (ikarus system chars)
(export $char->fixnum $fixnum->char)
(import (ikarus))
(define $char->fixnum char->integer)
(define $fixnum->char integer->char))

2
scheme/ikarus.compiler.altcogen.ss
View File

@ -638,7 +638,7 @@
(S* rands (S* rands
(lambda (s*) (lambda (s*)
(make-asm-instr op (make-asm-instr op
(make-disp (car s*) (cadr s*)) (make-disp (car s*) (cadr s*))
(caddr s*))))] (caddr s*))))]
[(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! [(fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
fl:from-int fl:shuffle bswap! fl:from-int fl:shuffle bswap!

1239
scheme/ikarus.compiler.source-optimizer.ss
View File

File diff suppressed because it is too large Load Diff

62
scheme/ikarus.compiler.ss
View File

@ -19,7 +19,7 @@
assembler-output scc-letrec optimize-cp assembler-output scc-letrec optimize-cp
current-primitive-locations eval-core current-primitive-locations eval-core
compile-core-expr compile-core-expr
cp0-effort-limit cp0-size-limit) cp0-effort-limit cp0-size-limit optimize-level)
(import (import
(rnrs hashtables) (rnrs hashtables)
(ikarus system $fx) (ikarus system $fx)
@ -27,7 +27,7 @@
(only (ikarus system $codes) $code->closure) (only (ikarus system $codes) $code->closure)
(only (ikarus system $structs) $struct-ref $struct/rtd?) (only (ikarus system $structs) $struct-ref $struct/rtd?)
(except (ikarus) (except (ikarus)
optimize-level optimize-level debug-optimizer
fasl-write scc-letrec optimize-cp fasl-write scc-letrec optimize-cp
compile-core-expr-to-port assembler-output compile-core-expr-to-port assembler-output
current-primitive-locations eval-core current-primitive-locations eval-core
@ -433,7 +433,7 @@
[else (cons (E x) ac)])) [else (cons (E x) ac)]))
(cons 'begin (f e0 (f e1 '()))))] (cons 'begin (f e0 (f e1 '()))))]
[(clambda-case info body) [(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-args (case-info-proper info) (case-info-args info))
,(E body))] ,(E body))]
[(clambda g cls* cp free) [(clambda g cls* cp free)
@ -1100,34 +1100,6 @@
x) 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 ;;; FIXME URGENT: should handle (+ x k), (- x k) where k is a fixnum
;;; also fx+, fx- ;;; also fx+, fx-
@ -1524,6 +1496,12 @@
(giveup)] (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) (define (mk-mvcall p c)
(struct-case p (struct-case p
@ -1819,10 +1797,13 @@
[(mvcall p c) [(mvcall p c)
(mk-mvcall (Value p) (Value c))] (mk-mvcall (Value p) (Value c))]
[else (error who "invalid value expression" (unparse x))])) [else (error who "invalid value expression" (unparse x))]))
(let ([x (Value x)]) (case (optimize-level)
;;; since we messed up the references and assignments here, we [(1)
;;; redo them (let ([x (Value x)])
(uncover-assigned/referenced x))) ;;; since we messed up the references and assignments here, we
;;; redo them
(uncover-assigned/referenced x))]
[else x]))
(define (rewrite-assignments x) (define (rewrite-assignments x)
@ -2998,9 +2979,6 @@
[else [else
(printf " ~s\n" x)])) (printf " ~s\n" x)]))
(define optimizer 'old)
(define (compile-core-expr->code p) (define (compile-core-expr->code p)
(let* ([p (recordize p)] (let* ([p (recordize p)]
[p (parameterize ([open-mvcalls #f]) [p (parameterize ([open-mvcalls #f])
@ -3008,13 +2986,9 @@
[p (if (scc-letrec) [p (if (scc-letrec)
(optimize-letrec/scc p) (optimize-letrec/scc p)
(optimize-letrec p))] (optimize-letrec p))]
[p (if (eq? optimizer 'new) [p (source-optimize p)]
(source-optimize p)
p)]
[p (uncover-assigned/referenced p)] [p (uncover-assigned/referenced p)]
[p (if (eq? optimizer 'old) [p (copy-propagate p)] ;;; old optimizer
(copy-propagate p)
p)]
[p (rewrite-assignments p)] [p (rewrite-assignments p)]
[p (sanitize-bindings p)] [p (sanitize-bindings p)]
[p (optimize-for-direct-jumps p)] [p (optimize-for-direct-jumps p)]

27
scheme/ikarus.fixnums.ss
View File

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

9
scheme/ikarus.main.ss
View File

@ -74,6 +74,15 @@
(let f ([args (command-line-arguments)]) (let f ([args (command-line-arguments)])
(cond (cond
[(null? args) (values '() #f #f '())] [(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) "--") [(string=? (car args) "--")
(values '() #f #f (cdr args))] (values '() #f #f (cdr args))]
[(string=? (car args) "--script") [(string=? (car args) "--script")

5
scheme/ikarus.numerics.ss
View File

@ -3699,3 +3699,8 @@
[else [else
(die 'imag-part "not a number" x)]))) (die 'imag-part "not a number" x)])))
) )
(library (ikarus system flonums)
(export $fixnum->flonum)
(import (ikarus))
(define $fixnum->flonum fixnum->flonum))

8
scheme/ikarus.pairs.ss
View File

@ -102,3 +102,11 @@
[cdaddr $cdr $car $cdr $cdr] [cdaddr $cdr $car $cdr $cdr]
[cadddr $car $cdr $cdr $cdr] [cadddr $car $cdr $cdr $cdr]
[cddddr $cdr $cdr $cdr $cdr])) [cddddr $cdr $cdr $cdr $cdr]))
(library (ikarus system pairs)
(export $car $cdr)
(import (ikarus))
(define $car car)
(define $cdr cdr))

10
scheme/ikarus.structs.ss
View File

@ -286,3 +286,13 @@
(display (rtd-name x) p) (display (rtd-name x) p)
(display " rtd>" 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)))

22
scheme/ikarus.symbols.ss
View File

@ -14,19 +14,19 @@
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; 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 (export gensym gensym? gensym->unique-string gensym-prefix
gensym-count print-gensym string->symbol symbol->string gensym-count print-gensym string->symbol symbol->string
getprop putprop remprop property-list getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value! top-level-value top-level-bound? set-top-level-value!
symbol-value symbol-bound? set-symbol-value! symbol-value symbol-bound? set-symbol-value!
reset-symbol-proc!) reset-symbol-proc! system-value system-value-gensym)
(import (import
(ikarus system $symbols) (ikarus system $symbols)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $fx) (ikarus system $fx)
(except (ikarus) gensym gensym? gensym->unique-string (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 string->symbol symbol->string
getprop putprop remprop property-list getprop putprop remprop property-list
top-level-value top-level-bound? set-top-level-value! top-level-value top-level-bound? set-top-level-value!
@ -223,5 +223,21 @@
(die 'print-gensym "not in #t|#f|pretty" x)) (die 'print-gensym "not in #t|#f|pretty" x))
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)]))
) )

8
scheme/ikarus.vectors.ss
View File

@ -279,3 +279,11 @@
(f v ($fxadd1 i) n fill)))) (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))

2
scheme/last-revision
View File

@ -1 +1 @@
1521 1522

21
scheme/makefile.ss
View File

@ -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. ;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum ;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;; ;;;
@ -17,7 +17,7 @@
;;; vim:syntax=scheme ;;; vim:syntax=scheme
(import (only (ikarus) import)) (import (only (ikarus) import))
(import (except (ikarus) (import (except (ikarus)
assembler-output scc-letrec optimize-cp assembler-output scc-letrec optimize-cp optimize-level
cp0-size-limit cp0-effort-limit)) cp0-size-limit cp0-effort-limit))
(import (ikarus.compiler)) (import (ikarus.compiler))
(import (except (psyntax system $bootstrap) (import (except (psyntax system $bootstrap)
@ -25,6 +25,7 @@
current-primitive-locations current-primitive-locations
compile-core-expr-to-port)) compile-core-expr-to-port))
(import (ikarus.compiler)) ; just for fun (import (ikarus.compiler)) ; just for fun
(optimize-level 2)
(pretty-width 160) (pretty-width 160)
((pretty-format 'fix) ((pretty-format 'letrec))) ((pretty-format 'fix) ((pretty-format 'letrec)))
@ -1311,6 +1312,7 @@
[void i $boot] [void i $boot]
[gensym i symbols $boot] [gensym i symbols $boot]
[symbol-value i symbols $boot] [symbol-value i symbols $boot]
[system-value i]
[set-symbol-value! i symbols $boot] [set-symbol-value! i symbols $boot]
[eval-core $boot] [eval-core $boot]
[pretty-print i $boot] [pretty-print i $boot]
@ -1432,6 +1434,7 @@
[ellipsis-map ] [ellipsis-map ]
[scc-letrec i] [scc-letrec i]
[optimize-cp i] [optimize-cp i]
[optimize-level i]
[cp0-size-limit i] [cp0-size-limit i]
[cp0-effort-limit i] [cp0-effort-limit i]
)) ))
@ -1589,16 +1592,19 @@
(let ([code `(library (ikarus primlocs) (let ([code `(library (ikarus primlocs)
(export) ;;; must be empty (export) ;;; must be empty
(import (import
(only (ikarus.symbols) system-value-gensym)
(only (psyntax library-manager) (only (psyntax library-manager)
install-library) install-library)
(only (ikarus.compiler) (only (ikarus.compiler)
current-primitive-locations) current-primitive-locations)
(ikarus)) (ikarus))
(current-primitive-locations (let ([g system-value-gensym])
(lambda (x) (for-each
(cond (lambda (x) (putprop (car x) g (cdr x)))
[(assq x ',primlocs) => cdr] ',primlocs)
[else #f]))) (let ([proc
(lambda (x) (getprop x g))])
(current-primitive-locations proc)))
,@(map build-library library-legend))]) ,@(map build-library library-legend))])
(let-values ([(name code empty-subst empty-env) (let-values ([(name code empty-subst empty-env)
(boot-library-expand code)]) (boot-library-expand code)])
@ -1699,6 +1705,7 @@
(debugf "\n"))) (debugf "\n")))
(close-output-port p))))) (close-output-port p)))))
;(print-missing-prims)
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")

51
scheme/pass-specify-rep-primops.ss
View File

@ -108,6 +108,19 @@
[(P x y) (prm '= (T x) (T y))] [(P x y) (prm '= (T x) (T y))]
[(E x y) (nop)]) [(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 (define-primop null? safe
[(P x) (prm '= (T x) (K nil))] [(P x) (prm '= (T x) (K nil))]
[(E x) (nop)]) [(E x) (nop)])
@ -201,6 +214,44 @@
[else (interrupt)])] [else (interrupt)])]
[(E x ls) (nop)]) [(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) /section)

202
scheme/psyntax.expander.ss
View File

@ -764,118 +764,83 @@
;;; not to special pattern variables. ;;; not to special pattern variables.
(define-syntax syntax-match (define-syntax syntax-match
(lambda (ctx) (lambda (ctx)
(define dots? (define convert-pattern
(lambda (x) ; returns syntax-dispatch pattern & ids
(and (sys.identifier? x) (lambda (pattern keys)
(sys.free-identifier=? x (syntax (... ...)))))) (define cvt*
(define free-identifier-member? (lambda (p* n ids)
(lambda (x ls) (if (null? p*)
(and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t))) (values '() ids)
(define (parse-clause lits cls) (let-values (((y ids) (cvt* (cdr p*) n ids)))
(define (parse-pat pat) (let-values (((x ids) (cvt (car p*) n ids)))
(syntax-case pat () (values (cons x y) ids))))))
(id (sys.identifier? (syntax id)) (define free-identifier-member?
(cond (lambda (x ls)
((free-identifier-member? (syntax id) lits) (and (exists (lambda (y) (sys.free-identifier=? x y)) ls) #t)))
(values '() (define (bound-id-member? x ls)
(syntax (and (pair? ls)
(lambda (x) (or (sys.bound-identifier=? x (car ls))
(and (id? x) (bound-id-member? x (cdr ls)))))
(free-id=? x (scheme-stx 'id)) (define ellipsis?
'()))))) (lambda (x)
((sys.free-identifier=? (syntax id) (syntax _)) (and (sys.identifier? x)
(values '() (syntax (lambda (x) '())))) (sys.free-identifier=? x (syntax (... ...))))))
(else (define cvt
(values (list (syntax id)) (syntax (lambda (x) (list x))))))) (lambda (p n ids)
((pat dots) (dots? (syntax dots)) (syntax-case p ()
(let-values (((pvars decon) (parse-pat (syntax pat)))) (id (sys.identifier? #'id)
(with-syntax (((v* ...) pvars) (decon decon)) (cond
(values pvars ((bound-id-member? p keys)
(syntax (letrec ((f (lambda (x) (values `#(scheme-id ,(sys.syntax->datum p)) ids))
(cond ((sys.free-identifier=? p #'_)
((syntax-pair? x) (values '_ ids))
(let ((cars/f (decon (syntax-car x)))) (else (values 'any (cons (cons p n) ids)))))
(and cars/f ((p dots) (ellipsis? #'dots)
(let ((cdrs/f (f (syntax-cdr x)))) (let-values (((p ids) (cvt #'p (+ n 1) ids)))
(and cdrs/f (values
(map cons cars/f cdrs/f)))))) (if (eq? p 'any) 'each-any `#(each ,p))
((syntax-null? x) ids)))
(list (begin 'v* '()) ...)) ((x dots ys ... . z) (ellipsis? #'dots)
(else #f))))) (let-values (((z ids) (cvt #'z n ids)))
f)))))) (let-values (((ys ids) (cvt* #'(ys ...) n ids)))
((pat dots . last) (dots? (syntax dots)) (let-values (((x ids) (cvt #'x (+ n 1) ids)))
(let-values (((p1 d1) (parse-pat (syntax pat))) (values `#(each+ ,x ,(reverse ys) ,z) ids)))))
((p2 d2) (parse-pat (syntax last)))) ((x . y)
(with-syntax (((v* ...) (append p1 p2)) (let-values (((y ids) (cvt #'y n ids)))
((v1* ...) p1) (let-values (((x ids) (cvt #'x n ids)))
((v2* ...) p2) (values (cons x y) ids))))
(d1 d1) (d2 d2)) (() (values '() ids))
(values (append p1 p2) (#(p ...)
(syntax (letrec ((f (lambda (x) (let-values (((p ids) (cvt #'(p ...) n ids)))
(cond (values `#(vector ,p) ids)))
((syntax-pair? x) (datum
(let ((cars/f (d1 (syntax-car x)))) (values `#(atom ,(sys.syntax->datum #'datum)) ids)))))
(and cars/f (cvt pattern 0 '())))
(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 () (syntax-case ctx ()
((_ expr (lits ...)) (for-all sys.identifier? (syntax (lits ...))) ((_ expr (lits ...)) (for-all sys.identifier? (syntax (lits ...)))
(syntax (stx-error expr "invalid syntax"))) (syntax (stx-error expr "invalid syntax")))
((_ expr (lits ...) cls cls* ...) (for-all sys.identifier? ((_ expr (lits ...) [pat fender body] cls* ...)
(syntax (lits ...))) (for-all sys.identifier? (syntax (lits ...)))
(let-values (((decon guard body) (let-values ([(pattern ids/levels) (convert-pattern #'pat #'(lits ...))])
(parse-clause (syntax (lits ...)) (syntax cls)))) (with-syntax ([pattern (sys.datum->syntax #'here pattern)]
(with-syntax ((decon decon) (guard guard) (body body)) [([ids . levels] ...) ids/levels])
(syntax (let ((t expr)) #'(let ([t expr])
(let ((ls/false (decon t))) (let ([ls/false (syntax-dispatch t 'pattern)])
(if (and ls/false (apply guard ls/false)) (if (and ls/false (apply (lambda (ids ...) fender) ls/false))
(apply body ls/false) (apply (lambda (ids ...) body) ls/false)
(syntax-match t (lits ...) cls* ...))))))))))) (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 (define parse-define
@ -906,7 +871,7 @@
(let* ((subst (let* ((subst
(library-subst (library-subst
(find-library-by-name '(psyntax system $all)))) (find-library-by-name '(psyntax system $all))))
(stx (mkstx sym top-mark* '() '())) (stx (make-stx sym top-mark* '() '()))
(stx (stx
(cond (cond
((assq sym subst) => ((assq sym subst) =>
@ -2157,7 +2122,7 @@
(lambda (e p) (lambda (e p)
(define stx^ (define stx^
(lambda (e m* s* ae*) (lambda (e m* s* ae*)
(if (and (null? m*) (null? s*)) (if (and (null? m*) (null? s*) (null? ae*))
e e
(mkstx e m* s* ae*)))) (mkstx e m* s* ae*))))
(define match-each (define match-each
@ -2233,6 +2198,7 @@
(reverse (vector-ref p 2)) (reverse (vector-ref p 2))
(match-empty (vector-ref p 3) r)))) (match-empty (vector-ref p 3) r))))
((free-id atom) r) ((free-id atom) r)
((scheme-id atom) r)
((vector) (match-empty (vector-ref p 1) r)) ((vector) (match-empty (vector-ref p 1) r))
(else (assertion-violation 'syntax-dispatch "invalid pattern" p))))))) (else (assertion-violation 'syntax-dispatch "invalid pattern" p)))))))
(define combine (define combine
@ -2262,6 +2228,12 @@
(top-marked? m*) (top-marked? m*)
(free-id=? (stx^ e m* s* ae*) (vector-ref p 1)) (free-id=? (stx^ e m* s* ae*) (vector-ref p 1))
r)) r))
((scheme-id)
(and (symbol? e)
(top-marked? m*)
(free-id=? (stx^ e m* s* ae*)
(scheme-stx (vector-ref p 1)))
r))
((each+) ((each+)
(let-values (((xr* y-pat r) (let-values (((xr* y-pat r)
(match-each+ e (vector-ref p 1) (match-each+ e (vector-ref p 1)
@ -2992,7 +2964,7 @@
(vector-map (vector-map
(lambda (x) (lambda (x)
(or (id->label (or (id->label
(mkstx (id->sym x) (stx-mark* x) (make-stx (id->sym x) (stx-mark* x)
(list rib) (list rib)
'())) '()))
(stx-error x "cannot find module export"))) (stx-error x "cannot find module export")))
@ -3503,7 +3475,7 @@
(parse-import-spec* imp*))) (parse-import-spec* imp*)))
(let ((rib (make-top-rib subst-names subst-labels))) (let ((rib (make-top-rib subst-names subst-labels)))
(let ((b* (map (lambda (x) (let ((b* (map (lambda (x)
(mkstx x top-mark* (list rib) '())) (make-stx x top-mark* (list rib) '()))
b*)) b*))
(rtc (make-collector)) (rtc (make-collector))
(vtc (make-collector))) (vtc (make-collector)))
@ -3628,7 +3600,7 @@
(cond (cond
[(env? env) [(env? env)
(let ((rib (make-top-rib (env-names env) (env-labels 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)) (itc (env-itc env))
(rtc (make-collector)) (rtc (make-collector))
(vtc (make-collector))) (vtc (make-collector)))
@ -3741,7 +3713,7 @@
(define (make-export-subst int* ext* rib) (define (make-export-subst int* ext* rib)
(map (map
(lambda (int ext) (lambda (int ext)
(let* ((id (mkstx int top-mark* (list rib) '())) (let* ((id (make-stx int top-mark* (list rib) '()))
(label (id->label id))) (label (id->label id)))
(unless label (unless label
(stx-error id "cannot export unbound identifier")) (stx-error id "cannot export unbound identifier"))

22
src/ikarus-fasl.c
View File

@ -557,6 +557,28 @@ static ikptr do_read(ikpcb* pcb, fasl_port* p){
} }
return x; 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 { else {
fprintf(stderr, "invalid type '%c' (0x%02x) found in fasl file\n", c, c); fprintf(stderr, "invalid type '%c' (0x%02x) found in fasl file\n", c, c);
exit(-1); exit(-1);