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

* made unbound variable violations have &undefined condition type.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-23 19:52:18 -05:00
parent 1c4ba26923
commit 1786677c73
3 changed files with 23 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1282
1283

35
scheme/psyntax.expander.ss
View File

@ -572,6 +572,9 @@
;;; - the shape of the expression (identifier, pair, or datum)
;;; - the binding of the identifier (for id-stx) or the type of
;;; car of the pair.
(define (raise-unbound-error id)
(syntax-violation* #f "unbound identifier" id
(make-undefined-violation)))
(define syntax-type
(lambda (e r)
(cond
@ -581,7 +584,7 @@
(b (label->binding label r))
(type (binding-type b)))
(unless label ;;; fail early.
(stx-error e "unbound identifier"))
(raise-unbound-error id))
(case type
((lexical core-prim macro macro! global local-macro
local-macro! global-macro global-macro!
@ -596,7 +599,7 @@
(b (label->binding label r))
(type (binding-type b)))
(unless label ;;; fail early.
(stx-error id "unbound identifier"))
(raise-unbound-error id))
(case type
((define define-syntax core-macro begin macro
macro! local-macro local-macro! global-macro
@ -851,7 +854,7 @@
(let* ((lab (id->label id))
(b (label->binding lab r))
(type (binding-type b)))
(unless lab (stx-error e "unbound identifier"))
(unless lab (raise-unbound-error id))
(unless (and (eq? type '$rtd) (not (list? (binding-value b))))
(stx-error e "not a record type"))
(build-data no-source (binding-value b)))))))
@ -863,7 +866,7 @@
(let* ((lab (id->label id))
(b (label->binding lab r))
(type (binding-type b)))
(unless lab (stx-error e "unbound identifier"))
(unless lab (raise-unbound-error id))
(unless (and (eq? type '$rtd) (list? (binding-value b)))
(stx-error e "not a record type"))
(chi-expr (car (binding-value b)) r mr))))))
@ -875,7 +878,7 @@
(let* ((lab (id->label id))
(b (label->binding lab r))
(type (binding-type b)))
(unless lab (stx-error e "unbound identifier"))
(unless lab (raise-unbound-error id))
(unless (and (eq? type '$rtd) (list? (binding-value b)))
(stx-error e "invalid type"))
(chi-expr (cadr (binding-value b)) r mr))))))
@ -3629,11 +3632,8 @@
#f)
(extract-position-condition x)))))
(define syntax-violation
(case-lambda
[(who msg form)
(syntax-violation who msg form #f)]
[(who msg form subform)
(define syntax-violation*
(lambda (who msg form condition-object)
(unless (string? msg)
(assertion-violation 'syntax-violation "message is not a string" msg))
(let ([who
@ -3653,10 +3653,17 @@
(make-who-condition who)
(condition))
(make-message-condition msg)
(make-syntax-violation
(syntax->datum form)
(syntax->datum subform))
(extract-position-condition form))))]))
condition-object
(extract-position-condition form))))))
(define syntax-violation
(case-lambda
[(who msg form) (syntax-violation who msg form #f)]
[(who msg form subform)
(syntax-violation* who msg form
(make-syntax-violation
(syntax->datum form)
(syntax->datum subform)))]))
(define identifier? (lambda (x) (id? x)))

2
scheme/todo-r6rs.ss
View File

@ -265,7 +265,7 @@
[bitwise-copy-bit-field S bw]
[bitwise-first-bit-set C bw]
[bitwise-if S bw]
[bitwise-length S bw]
[bitwise-length C bw]
[bitwise-reverse-bit-field S bw]
[bitwise-rotate-bit-field S bw]
;;;