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

* syntax-match now accepts a single code form only.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 03:48:42 -04:00
parent 862a8b558c
commit 65dbda85fc
2 changed files with 80 additions and 69 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.

149
src/ikarus.syntax.ss
View File

@ -456,7 +456,7 @@
#'(lambda (x) #'(lambda (x)
(equal? (strip x '()) 'datum))]))) (equal? (strip x '()) 'datum))])))
(syntax-case ctx () (syntax-case ctx ()
[(_ x (lits ...) [pat code code* ...]) [(_ x (lits ...) [pat code])
(with-syntax ([pat-code (f #'pat #'(lits ...))]) (with-syntax ([pat-code (f #'pat #'(lits ...))])
#'(pat-code x))]))) #'(pat-code x))])))
(define-syntax syntax-match-conseq (define-syntax syntax-match-conseq
@ -581,9 +581,9 @@
(f #'pat #'(lits ...))]) (f #'pat #'(lits ...))])
(with-syntax ([e extractor] [(vs ...) vars]) (with-syntax ([e extractor] [(vs ...) vars])
(case (length vars) (case (length vars)
[(0) #'(begin code code* ...)] [(0) #'(begin #f code)]
[(1) #'(let ([vs ... (e x)]) code code* ...)] [(1) #'(let ([vs ... (e x)]) #f code)]
[else #'(let-values ([(vs ...) (e x)]) code code* ...)])))]))) [else #'(let-values ([(vs ...) (e x)]) #f code)])))])))
(define-syntax syntax-match (define-syntax syntax-match
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
@ -688,15 +688,16 @@
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
[(_ id) [(_ id)
(unless (id? id) (stx-error e)) (begin
(let* ([lab (id->label id)] (unless (id? id) (stx-error e))
[b (label->binding lab r)] (let* ([lab (id->label id)]
[type (binding-type b)]) [b (label->binding lab r)]
(unless lab (stx-error e "unbound identifier")) [type (binding-type b)])
(case type (unless lab (stx-error e "unbound identifier"))
[($rtd) (case type
(build-data no-source (binding-value b))] [($rtd)
[else (stx-error e "invalid type")]))]))) (build-data no-source (binding-value b))]
[else (stx-error e "invalid type")])))])))
(define when-transformer ;;; go away (define when-transformer ;;; go away
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
@ -890,18 +891,19 @@
(syntax-match e () (syntax-match e ()
[(_ (lits ...) [(_ (lits ...)
[pat* tmp*] ...) [pat* tmp*] ...)
(unless (andmap (begin
(lambda (x) (unless (andmap
(and (id? x) (lambda (x)
(not (free-id=? x (scheme-stx '...))) (and (id? x)
(not (free-id=? x (scheme-stx '_))))) (not (free-id=? x (scheme-stx '...)))
lits) (not (free-id=? x (scheme-stx '_)))))
(stx-error e "invalid literals")) lits)
(bless `(lambda (x) (stx-error e "invalid literals"))
(syntax-case x ,lits (bless `(lambda (x)
,@(map (lambda (pat tmp) (syntax-case x ,lits
`[,pat (syntax ,tmp)]) ,@(map (lambda (pat tmp)
pat* tmp*))))]))) `[,pat (syntax ,tmp)])
pat* tmp*)))))])))
(define quasiquote-macro (define quasiquote-macro
(let () (let ()
(define-syntax app (define-syntax app
@ -1126,6 +1128,7 @@
(let-values (((y ids) (cvt* (cdr p*) n ids))) (let-values (((y ids) (cvt* (cdr p*) n ids)))
(let-values (((x ids) (cvt (car p*) n ids))) (let-values (((x ids) (cvt (car p*) n ids)))
(values (cons x y) ids)))))) (values (cons x y) ids))))))
;;; FIXME: these should go away
(define id-dots? (define id-dots?
(lambda (x) (lambda (x)
(and (syntax-pair? x) (and (syntax-pair? x)
@ -1141,7 +1144,6 @@
(let ((d (syntax-cdr x))) (let ((d (syntax-cdr x)))
(and (syntax-pair? d) (and (syntax-pair? d)
(ellipsis? (syntax-car d))))))) (ellipsis? (syntax-car d)))))))
;;; FIXME: these should go away
(define syntax-foo-z (define syntax-foo-z
(lambda (x) (lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))]) (let f ([x (syntax-cdr (syntax-cdr x))])
@ -1409,13 +1411,14 @@
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
[(_ expr (keys ...) clauses ...) [(_ expr (keys ...) clauses ...)
(unless (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) keys) (begin
(stx-error e)) (unless (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) keys)
(let ((x (gen-lexical 'tmp))) (stx-error e))
(let ([body (gen-syntax-case x keys clauses r mr)]) (let ((x (gen-lexical 'tmp)))
(build-application no-source (let ([body (gen-syntax-case x keys clauses r mr)])
(build-lambda no-source (list x) body) (build-application no-source
(list (chi-expr expr r mr)))))])))) (build-lambda no-source (list x) body)
(list (chi-expr expr r mr))))))]))))
(define syntax-transformer (define syntax-transformer
(let () (let ()
(define match2 (define match2
@ -1816,11 +1819,13 @@
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
[(_ (export* ...) b* ...) [(_ (export* ...) b* ...)
(unless (andmap id? export*) (stx-error e)) (begin
(values #f export* b*)] (unless (andmap id? export*) (stx-error e))
(values #f export* b*))]
[(_ name (export* ...) b* ...) [(_ name (export* ...) b* ...)
(unless (and (id? name) (andmap id? export*)) (stx-error e)) (begin
(values name export* b*)]))) (unless (and (id? name) (andmap id? export*)) (stx-error e))
(values name export* b*))])))
(let-values ([(name exp-id* e*) (parse-module e)]) (let-values ([(name exp-id* e*) (parse-module e)])
(let* ([rib (make-empty-rib)] (let* ([rib (make-empty-rib)]
[e* (map (lambda (x) (add-subst rib x)) [e* (map (lambda (x) (add-subst rib x))
@ -1925,12 +1930,14 @@
[else [else
(syntax-match (car exp*) () (syntax-match (car exp*) ()
[(rename (i* e*) ...) [(rename (i* e*) ...)
(unless (and (eq? rename 'rename) (andmap symbol? i*) (andmap symbol? e*)) (begin
(error #f "invalid export specifier ~s" (car exp*))) (unless (and (eq? rename 'rename) (andmap symbol? i*) (andmap symbol? e*))
(f (cdr exp*) (append i* int*) (append e* ext*))] (error #f "invalid export specifier ~s" (car exp*)))
(f (cdr exp*) (append i* int*) (append e* ext*)))]
[ie [ie
(unless (symbol? ie) (error #f "invalid export ~s" ie)) (begin
(f (cdr exp*) (cons ie int*) (cons ie ext*))])]))) (unless (symbol? ie) (error #f "invalid export ~s" ie))
(f (cdr exp*) (cons ie int*) (cons ie ext*)))])])))
(define parse-library (define parse-library
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
@ -2016,32 +2023,35 @@
[(rename) [(rename)
(syntax-match spec () (syntax-match spec ()
[(_ isp (old* new*) ...) [(_ isp (old* new*) ...)
(unless (and (andmap symbol? old*) (andmap symbol? new*)) (begin
(error 'import "invalid import spec ~s" spec)) (unless (and (andmap symbol? old*) (andmap symbol? new*))
(let-values ([(subst lib) (get-import isp)]) (error 'import "invalid import spec ~s" spec))
(let ([old-label* (find* old* subst)]) (let-values ([(subst lib) (get-import isp)])
(let ([subst (rem* old* subst)]) (let ([old-label* (find* old* subst)])
;;; FIXME: make sure map is valid (let ([subst (rem* old* subst)])
(values (merge-substs (map cons new* old-label*) subst) ;;; FIXME: make sure map is valid
lib))))] (values (merge-substs (map cons new* old-label*) subst)
lib)))))]
[_ (error 'import "invalid rename spec ~s" spec)])] [_ (error 'import "invalid rename spec ~s" spec)])]
[(except) [(except)
(syntax-match spec () (syntax-match spec ()
[(_ isp sym* ...) [(_ isp sym* ...)
(unless (andmap symbol? sym*) (begin
(error 'import "invalid import spec ~s" spec)) (unless (andmap symbol? sym*)
(let-values ([(subst lib) (get-import isp)]) (error 'import "invalid import spec ~s" spec))
(values (rem* sym* subst) lib))] (let-values ([(subst lib) (get-import isp)])
(values (rem* sym* subst) lib)))]
[_ (error 'import "invalid import spec ~s" spec)])] [_ (error 'import "invalid import spec ~s" spec)])]
[(only) [(only)
(syntax-match spec () (syntax-match spec ()
[(_ isp sym* ...) [(_ isp sym* ...)
(unless (andmap symbol? sym*) (begin
(error 'import "invalid import spec ~s" spec)) (unless (andmap symbol? sym*)
(let-values ([(subst lib) (get-import isp)]) (error 'import "invalid import spec ~s" spec))
(let ([sym* (remove-dups sym*)]) (let-values ([(subst lib) (get-import isp)])
(let ([lab* (find* sym* subst)]) (let ([sym* (remove-dups sym*)])
(values (map cons sym* lab*) lib))))] (let ([lab* (find* sym* subst)])
(values (map cons sym* lab*) lib)))))]
[_ (error 'import "invalid import spec ~s" spec)])] [_ (error 'import "invalid import spec ~s" spec)])]
[(prefix) (error #f "prefix found")] [(prefix) (error #f "prefix found")]
[else [else
@ -2216,15 +2226,16 @@
[(invoke) [(invoke)
(syntax-match x () (syntax-match x ()
[(_ (id** ...) ...) [(_ (id** ...) ...)
(unless (andmap (lambda (id*) (andmap symbol? id*)) id**) (begin
(error #f "invalid invoke form ~s" x)) (unless (andmap (lambda (id*) (andmap symbol? id*)) id**)
(let ([lib* (error #f "invalid invoke form ~s" x))
(map (lambda (x) (let ([lib*
(or (find-library-by-name x) (map (lambda (x)
(error #f "cannot find library ~s" (or (find-library-by-name x)
x))) (error #f "cannot find library ~s"
id**)]) x)))
(for-each invoke-library lib*))] id**)])
(for-each invoke-library lib*)))]
[else (error #f "invalid invoke form ~s" x)])] [else (error #f "invalid invoke form ~s" x)])]
[else (error #f "invalid top-level form ~s" x)]))) [else (error #f "invalid top-level form ~s" x)])))
) )