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

* changed sanitize-binding to add a local prefix to all introduced 

keywords (like local-macro, local-macro!, and local-rtd)
This commit is contained in:
Abdulaziz Ghuloum 2007-05-07 20:02:29 -04:00
parent 32a1751025
commit 5f07f5f921
2 changed files with 28 additions and 9 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.

37
src/ikarus.syntax.ss
View File

@ -345,6 +345,7 @@
(define make-binding cons) (define make-binding cons)
(define binding-type car) (define binding-type car)
(define binding-value cdr) (define binding-value cdr)
(define local-binding-value cadr)
(define syntax-type (define syntax-type
(lambda (e r) (lambda (e r)
(cond (cond
@ -356,7 +357,7 @@
(unless label (unless label
(stx-error e "unbound identifier")) (stx-error e "unbound identifier"))
(case type (case type
[(lexical core-prim macro global) [(lexical core-prim macro global local-macro)
(values type (binding-value b) id)] (values type (binding-value b) id)]
[else (values 'other #f #f)])))] [else (values 'other #f #f)])))]
[(syntax-pair? e) [(syntax-pair? e)
@ -366,7 +367,7 @@
[b (label->binding label r)] [b (label->binding label r)]
[type (binding-type b)]) [type (binding-type b)])
(case type (case type
[(define define-syntax core-macro begin macro module set!) [(define define-syntax core-macro begin macro local-macro module set!)
(values type (binding-value b) id)] (values type (binding-value b) id)]
[else [else
(values 'call #f #f)])) (values 'call #f #f)]))
@ -381,16 +382,17 @@
[(_ stx) #'(error 'chi "invalid syntax ~s" (strip stx '()))] [(_ stx) #'(error 'chi "invalid syntax ~s" (strip stx '()))]
[(_ stx msg) #'(error 'chi "~a: ~s" msg (strip stx '()))]))) [(_ stx msg) #'(error 'chi "~a: ~s" msg (strip stx '()))])))
(define sanitize-binding (define sanitize-binding
(lambda (x) (lambda (x src)
(cond (cond
[(procedure? x) (cons 'macro x)] [(procedure? x) (list* 'local-macro x src)]
[(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x))) [(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
x] (list* 'local-macro! (cdr x) src)]
[(and (pair? x) (eq? (car x) '$rtd)) x] [(and (pair? x) (eq? (car x) '$rtd))
(list* 'local-rtd (cdr x) src)]
[else (error 'expand "invalid transformer ~s" x)]))) [else (error 'expand "invalid transformer ~s" x)])))
(define make-eval-transformer (define make-eval-transformer
(lambda (x) (lambda (x)
(sanitize-binding (eval-core x)))) (sanitize-binding (eval-core x) x)))
(module (syntax-match) (module (syntax-match)
(define-syntax syntax-match-test (define-syntax syntax-match-test
(lambda (ctx) (lambda (ctx)
@ -675,8 +677,8 @@
[type (binding-type b)]) [type (binding-type b)])
(unless lab (stx-error e "unbound identifier")) (unless lab (stx-error e "unbound identifier"))
(case type (case type
[($rtd) [(local-rtd)
(build-data no-source (binding-value b))] (build-data no-source (local-binding-value b))]
[else (stx-error e "invalid type")]))]))) [else (stx-error e "invalid type")]))])))
(define when-transformer ;;; go away (define when-transformer ;;; go away
(lambda (e r mr) (lambda (e r mr)
@ -1600,11 +1602,17 @@
[(with-syntax) with-syntax-macro] [(with-syntax) with-syntax-macro]
[else (error 'macro-transformer "invalid macro ~s" x)])] [else (error 'macro-transformer "invalid macro ~s" x)])]
[else (error 'core-macro-transformer "invalid macro ~s" x)]))) [else (error 'core-macro-transformer "invalid macro ~s" x)])))
(define (local-macro-transformer x)
(car x))
;;; chi procedures ;;; chi procedures
(define chi-macro (define chi-macro
(lambda (p e) (lambda (p e)
(let ([s ((macro-transformer p) (add-mark anti-mark e))]) (let ([s ((macro-transformer p) (add-mark anti-mark e))])
(add-mark (gen-mark) s)))) (add-mark (gen-mark) s))))
(define chi-local-macro
(lambda (p e)
(let ([s ((local-macro-transformer p) (add-mark anti-mark e))])
(add-mark (gen-mark) s))))
(define chi-expr* (define chi-expr*
(lambda (e* r mr) (lambda (e* r mr)
;;; expand left to right ;;; expand left to right
@ -1640,6 +1648,7 @@
[(lexical) [(lexical)
(let ([lex value]) (let ([lex value])
(build-lexical-reference no-source lex))] (build-lexical-reference no-source lex))]
[(local-macro) (chi-expr (chi-local-macro value e) r mr)]
[(macro) (chi-expr (chi-macro value e) r mr)] [(macro) (chi-expr (chi-macro value e) r mr)]
[(constant) [(constant)
(let ([datum value]) (let ([datum value])
@ -1799,6 +1808,9 @@
[(_ x* ...) [(_ x* ...)
(f (append x* (cdr e*)) module-init** (f (append x* (cdr e*)) module-init**
r mr lhs* lex* rhs* kwd*)])] r mr lhs* lex* rhs* kwd*)])]
[(local-macro)
(f (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
module-init** r mr lhs* lex* rhs* kwd*)]
[(macro) [(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*)) (f (cons (add-subst rib (chi-macro value e)) (cdr e*))
module-init** r mr lhs* lex* rhs* kwd*)] module-init** r mr lhs* lex* rhs* kwd*)]
@ -1890,6 +1902,9 @@
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
(f (append x* (cdr e*)) r mr lhs* lex* rhs* kwd*)])] (f (append x* (cdr e*)) r mr lhs* lex* rhs* kwd*)])]
[(local-macro)
(f (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
r mr lhs* lex* rhs* kwd*)]
[(macro) [(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*)) (f (cons (add-subst rib (chi-macro value e)) (cdr e*))
r mr lhs* lex* rhs* kwd*)] r mr lhs* lex* rhs* kwd*)]
@ -1956,6 +1971,10 @@
[(_ x* ...) [(_ x* ...)
(f (append x* (cdr e*)) module-init** r mr lhs* lex* rhs* (f (append x* (cdr e*)) module-init** r mr lhs* lex* rhs*
kwd*)])] kwd*)])]
[(local-macro)
(f (cons (add-subst rib (chi-local-macro value e)) (cdr e*))
module-init**
r mr lhs* lex* rhs* kwd*)]
[(macro) [(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*)) (f (cons (add-subst rib (chi-macro value e)) (cdr e*))
module-init** module-init**