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

fixes bug 176756: define-condition-type does not work in repl

This commit is contained in:
Abdulaziz Ghuloum 2007-12-17 11:37:10 -05:00
parent 64c20409ce
commit bbe388656c
2 changed files with 33 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1251 1252

45
scheme/psyntax.expander.ss
View File

@ -521,9 +521,13 @@
(cond (cond
((imported-label->binding x) => ((imported-label->binding x) =>
(lambda (b) (lambda (b)
(if (and (pair? b) (eq? (car b) '$core-rtd)) (cond
(cons '$rtd (map bless (cdr b))) [(and (pair? b) (eq? (car b) '$core-rtd))
b))) (cons '$rtd (map bless (cdr b)))]
[(and (pair? b) (eq? (car b) 'global-rtd))
(let ([lib (cadr b)] [loc (cddr b)])
(cons '$rtd (symbol-value loc)))]
[else b])))
((assq x r) => cdr) ((assq x r) => cdr)
(else '(displaced-lexical . #f))))) (else '(displaced-lexical . #f)))))
@ -816,7 +820,7 @@
(type (binding-type b))) (type (binding-type b)))
(unless lab (stx-error e "unbound identifier")) (unless lab (stx-error e "unbound identifier"))
(unless (and (eq? type '$rtd) (not (list? (binding-value b)))) (unless (and (eq? type '$rtd) (not (list? (binding-value b))))
(stx-error e "invalid type")) (stx-error e "invalid type" b))
(build-data no-source (binding-value b))))))) (build-data no-source (binding-value b)))))))
(define record-type-descriptor-transformer (define record-type-descriptor-transformer
@ -828,7 +832,7 @@
(type (binding-type b))) (type (binding-type b)))
(unless lab (stx-error e "unbound identifier")) (unless lab (stx-error e "unbound identifier"))
(unless (and (eq? type '$rtd) (list? (binding-value b))) (unless (and (eq? type '$rtd) (list? (binding-value b)))
(stx-error e "invalid type")) (stx-error e "invalid type" b))
(chi-expr (car (binding-value b)) r mr)))))) (chi-expr (car (binding-value b)) r mr))))))
(define record-constructor-descriptor-transformer (define record-constructor-descriptor-transformer
@ -2809,20 +2813,27 @@
(define set-global-macro-binding! (define set-global-macro-binding!
(lambda (id loc b) (lambda (id loc b)
(let ([type (define (extend-macro! id loc type transformer)
(case (binding-type b) (let ([sym (id->sym id)]
[(local-macro) 'global-macro] [label (id->label id)])
[(local-macro!) 'global-macro!]
[else
(assertion-violation 'set-global-macro-binding!
"BUG: invalid type" b)])]
[transformer (cadr b)]
[label (id->label id)]
[sym (id->sym id)])
(set-symbol-value! loc transformer) (set-symbol-value! loc transformer)
(extend-library-subst! (interaction-library) sym label) (extend-library-subst! (interaction-library) sym label)
(extend-library-env! (interaction-library) label (extend-library-env! (interaction-library) label
(cons* type (interaction-library) loc))))) (cons* type (interaction-library) loc))))
(case (binding-type b)
[(local-macro)
(extend-macro! id loc 'global-macro (cadr b))]
[(local-macro!)
(extend-macro! id loc 'global-macro! (cadr b))]
[($rtd)
(extend-macro! id loc 'global-rtd (cdr b))]
; (extend-library-subst! (interaction-library)
; (id->sym id) (id->label id))
; (extend-library-env! (interaction-library)
; (id->label id) b)]
[else
(assertion-violation 'set-global-macro-binding!
"BUG: invalid type" b)])))
(define gen-global-macro-binding (define gen-global-macro-binding
(lambda (id ctxt) (gen-global-var-binding id ctxt))) (lambda (id ctxt) (gen-global-var-binding id ctxt)))
@ -2832,7 +2843,7 @@
(let ((label (id->label id))) (let ((label (id->label id)))
(let ((b (imported-label->binding label))) (let ((b (imported-label->binding label)))
(case (binding-type b) (case (binding-type b)
((global global-macro global-macro!) ((global global-macro global-macro! global-rtd)
(let ((x (binding-value b))) (let ((x (binding-value b)))
(let ((lib (car x)) (loc (cdr x))) (let ((lib (car x)) (loc (cdr x)))
(cond (cond