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

* reimplemented (quasisyntax body) by expanding it to 

(syntax-case (list expr* ...) ()
      [(var? ...) #'body])
  where expr* are the unquoted expressions and var? are the
  generated names that are simultaneously inserted in body.
This commit is contained in:
Abdulaziz Ghuloum 2007-09-09 23:08:26 -04:00
parent 8aecc96b76
commit a99c8d5461
3 changed files with 48 additions and 103 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.

8
src/ikarus.handlers.ss
View File

@ -108,9 +108,7 @@
(define $do-event (define $do-event
(lambda () (lambda ()
(if ($interrupted?) (when ($interrupted?)
(begin ($unset-interrupted!)
($unset-interrupted!) ((interrupt-handler)))))
((interrupt-handler)))
(display "Engine Expired\n" (console-output-port)))))
) )

143
src/ikarus.syntax.ss
View File

@ -771,6 +771,8 @@
(cond (cond
[(pair? x) (cons (f (car x)) (f (cdr x)))] [(pair? x) (cons (f (car x)) (f (cdr x)))]
[(symbol? x) (scheme-stx x)] [(symbol? x) (scheme-stx x)]
[(vector? x)
(list->vector (map f (vector->list x)))]
[else x])) [else x]))
'() '()))) '() '())))
(define with-syntax-macro (define with-syntax-macro
@ -1035,112 +1037,58 @@
[(_ e) (quasi e 0)])))) [(_ e) (quasi e 0)]))))
(define quasisyntax-macro (define quasisyntax-macro
(let () (let ()
(define-syntax app
(syntax-rules (quote)
[(_ 'x arg* ...)
(list (scheme-stx 'x) arg* ...)]))
(define-syntax app*
(syntax-rules (quote)
[(_ 'x arg* ... last)
(list* (scheme-stx 'x) arg* ... last)]))
(define quasilist*
(lambda (x y)
(let f ((x x))
(if (null? x) y (quasicons (car x) (f (cdr x)))))))
(define quasicons
(lambda (x y)
(syntax-match y (syntax list)
[(syntax dy)
(syntax-match x (syntax)
[(syntax dx) (app 'syntax (cons dx dy))]
[_
(syntax-match dy ()
[() (app 'list x)]
[_ (app 'cons x y)])])]
[(list stuff ...)
(app* 'list x stuff)]
[_ (app 'cons x y)])))
(define quasiappend
(lambda (x y)
(let ([ls (let f ((x x))
(if (null? x)
(syntax-match y (syntax)
[(syntax ()) '()]
[_ (list y)])
(syntax-match (car x) (syntax)
[(syntax ()) (f (cdr x))]
[_ (cons (car x) (f (cdr x)))])))])
(cond
[(null? ls) (app 'syntax '())]
[(null? (cdr ls)) (car ls)]
[else (app* 'append ls)]))))
(define quasivector
(lambda (x)
(let ((pat-x x))
(syntax-match pat-x (syntax)
[(syntax (x* ...)) (app 'syntax (list->vector x*))]
[_ (let f ((x x) (k (lambda (ls) (app* 'vector ls))))
(syntax-match x (syntax list cons)
[(syntax (x* ...))
(k (map (lambda (x) (app 'syntax x)) x*))]
[(list x* ...)
(k x*)]
[(cons x y)
(f y (lambda (ls) (k (cons x ls))))]
[_ (app 'list->vector pat-x)]))]))))
(define vquasi
(lambda (p lev)
(syntax-match p ()
[(p . q)
(syntax-match p (unsyntax unsyntax-splicing)
[(unsyntax p ...)
(if (= lev 0)
(quasilist* p (vquasi q lev))
(quasicons
(quasicons (app 'quote 'unsyntax) (quasi p (- lev 1)))
(vquasi q lev)))]
[(unsyntax-splicing p ...)
(if (= lev 0)
(quasiappend p (vquasi q lev))
(quasicons
(quasicons
(app 'quote 'unsyntax-splicing)
(quasi p (- lev 1)))
(vquasi q lev)))]
[p (quasicons (quasi p lev) (vquasi q lev))])]
[() (app 'syntax '())])))
(define quasi (define quasi
(lambda (p lev) (lambda (p lev)
(syntax-match p (unsyntax unsyntax-splicing quasisyntax) (syntax-match p (unsyntax unsyntax-splicing quasisyntax)
[(unsyntax p) [(unsyntax p)
(if (= lev 0) (if (= lev 0)
p (let ([g (gensym)])
(quasicons (app 'syntax 'unsyntax) (quasi (list p) (- lev 1))))] (values (list g) (list p) g))
[((unsyntax p ...) . q) (let-values ([(lhs* rhs* p) (quasi p (- lev 1))])
(if (= lev 0) (values lhs* rhs* (list 'unsyntax p))))]
(quasilist* p (quasi q lev)) [unsyntax (= lev 0)
(quasicons (stx-error p "incorrect use of unsyntax")]
(quasicons (app 'syntax 'unsyntax) (quasi p (- lev 1))) [((unsyntax-splicing p) . q)
(quasi q lev)))] (let-values ([(lhs* rhs* q) (quasi q lev)])
[((unsyntax-splicing p ...) . q) (if (= lev 0)
(if (= lev 0) (let ([g (gensym)])
(quasiappend p (quasi q lev)) (values (cons `(,g ...) lhs*) (cons p rhs*)
(quasicons `(,g ... . ,q)))
(quasicons (let-values ([(lhs2* rhs2* p) (quasi p (- lev 1))])
(app 'syntax 'unsyntax-splicing) (values (append lhs2* lhs*)
(quasi p (- lev 1))) (append rhs2* rhs*)
(quasi q lev)))] `((unsyntax-splicing ,p) . ,q)))))]
[unsyntax-splicing (= lev 0)
(stx-error p "incorrect use of unsyntax-splicing")]
[(quasisyntax p) [(quasisyntax p)
(quasicons (app 'syntax 'quasisyntax) (quasi (list p) (+ lev 1)))] (let-values ([(lhs* rhs* p) (quasi p (+ lev 1))])
[(p . q) (quasicons (quasi p lev) (quasi q lev))] (values lhs* rhs* `(quasisyntax ,p)))]
[#(x ...) (quasivector (vquasi x lev))] [(p . q)
[p (app 'syntax p)]))) (let-values ([(lhs* rhs* p) (quasi p lev)]
[(lhs2* rhs2* q) (quasi q lev)])
(values (append lhs2* lhs*)
(append rhs2* rhs*)
(cons p q)))]
[#(x ...)
(let-values ([(lhs* rhs* x*)
(let f ([x x])
(cond
[(null? x) (values '() '() '())]
[else
(let-values ([(lhs* rhs* a) (quasi (car x) lev)])
(let-values ([(lhs2* rhs2* d) (f (cdr x))])
(values (append lhs* lhs2*)
(append rhs* rhs2*)
(cons a d))))]))])
(values lhs* rhs* (list->vector x*)))]
[_ (values '() '() p)])))
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()
[(_ e) [(_ e)
(let ([v (quasi e 0)]) (let-values ([(lhs* rhs* v) (quasi e 0)])
;(pretty-print (syntax->datum v)) (bless
v)])))) `(syntax-case (list ,@rhs*) ()
[,lhs* #',v])))]))))
(define define-record-macro (define define-record-macro
(lambda (e) (lambda (e)
(define enumerate (define enumerate
@ -1580,7 +1528,6 @@
(let-values ([(lsnew maps) (let-values ([(lsnew maps)
(gen-syntax src ls r maps ellipsis? #t)]) (gen-syntax src ls r maps ellipsis? #t)])
(values (gen-vector e ls lsnew) maps))] (values (gen-vector e ls lsnew) maps))]
;[() (values '(quote ()) maps)]
[_ (values `(quote ,e) maps)]))) [_ (values `(quote ,e) maps)])))
(define gen-ref (define gen-ref
(lambda (src var level maps) (lambda (src var level maps)