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

replaced some calls to assertion-violation with calls to 

syntax-violation for better syntactic error reporting.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-19 23:42:27 -05:00
parent 6eb6bf750d
commit 2c31b5bf51
2 changed files with 59 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1271 1272

107
scheme/psyntax.expander.ss
View File

@ -117,7 +117,7 @@
(car label*) (car label*)
(find sym mark* (cdr sym*) (cdr mark**) (cdr label*))))) (find sym mark* (cdr sym*) (cdr mark**) (cdr label*)))))
(when (rib-sealed/freq rib) (when (rib-sealed/freq rib)
(assertion-violation 'extend-rib! "rib is sealed" rib)) (assertion-violation 'extend-rib! "BUG: rib is sealed" rib))
(let ((sym (id->sym id)) (let ((sym (id->sym id))
(mark* (stx-mark* id))) (mark* (stx-mark* id)))
(let ((sym* (rib-sym* rib))) (let ((sym* (rib-sym* rib)))
@ -361,7 +361,7 @@
[(annotation? x) [(annotation? x)
(syntax-vector->list (annotation-expression x))] (syntax-vector->list (annotation-expression x))]
((vector? x) (vector->list x)) ((vector? x) (vector->list x))
(else (assertion-violation 'syntax-vector->list "not a syntax vector" x))))) (else (assertion-violation 'syntax-vector->list "BUG: not a syntax vector" x)))))
(define syntax-pair? (define syntax-pair?
(lambda (x) (syntax-kind? x pair?))) (lambda (x) (syntax-kind? x pair?)))
(define syntax-vector? (define syntax-vector?
@ -380,7 +380,7 @@
[(annotation? x) [(annotation? x)
(syntax-car (annotation-expression x))] (syntax-car (annotation-expression x))]
[(pair? x) (car x)] [(pair? x) (car x)]
[else (assertion-violation 'syntax-car "not a pair" x)]))) [else (assertion-violation 'syntax-car "BUG: not a pair" x)])))
(define syntax-cdr (define syntax-cdr
(lambda (x) (lambda (x)
(cond (cond
@ -389,14 +389,14 @@
[(annotation? x) [(annotation? x)
(syntax-cdr (annotation-expression x))] (syntax-cdr (annotation-expression x))]
[(pair? x) (cdr x)] [(pair? x) (cdr x)]
[else (assertion-violation 'syntax-cdr "not a pair" x)]))) [else (assertion-violation 'syntax-cdr "BUG: not a pair" x)])))
(define syntax->list (define syntax->list
(lambda (x) (lambda (x)
(if (syntax-pair? x) (if (syntax-pair? x)
(cons (syntax-car x) (syntax->list (syntax-cdr x))) (cons (syntax-car x) (syntax->list (syntax-cdr x)))
(if (syntax-null? x) (if (syntax-null? x)
'() '()
(assertion-violation 'syntax->list "invalid argument" x))))) (assertion-violation 'syntax->list "BUG: invalid argument" x)))))
(define id? (define id?
(lambda (x) (syntax-kind? x symbol?))) (lambda (x) (syntax-kind? x symbol?)))
@ -406,7 +406,7 @@
[(stx? x) (id->sym (stx-expr x))] [(stx? x) (id->sym (stx-expr x))]
[(annotation? x) (annotation-expression x)] [(annotation? x) (annotation-expression x)]
[(symbol? x) x] [(symbol? x) x]
[else (assertion-violation 'id->sym "not an id" x)]))) [else (assertion-violation 'id->sym "BUG: not an id" x)])))
;;; Two lists of marks are considered the same if they have the ;;; Two lists of marks are considered the same if they have the
;;; same length and the corresponding marks on each are eq?. ;;; same length and the corresponding marks on each are eq?.
@ -603,9 +603,9 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ stx) ((_ stx)
(syntax (assertion-violation 'expander "invalid syntax" (stx->datum stx)))) (syntax (syntax-violation #f "invalid syntax" stx)))
((_ stx msg arg* ...) ((_ stx msg)
(syntax (assertion-violation 'expander msg (strip stx '()) arg* ...)))))) (syntax (syntax-violation #f msg stx))))))
;;; when the rhs of a syntax definition is evaluated, it should be ;;; when the rhs of a syntax definition is evaluated, it should be
;;; either a procedure, an identifier-syntax transformer or an ;;; either a procedure, an identifier-syntax transformer or an
@ -841,7 +841,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" b)) (stx-error e "not a record type"))
(build-data no-source (binding-value b))))))) (build-data no-source (binding-value b)))))))
(define record-type-descriptor-transformer (define record-type-descriptor-transformer
@ -853,7 +853,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" b)) (stx-error e "not a record type"))
(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
@ -994,16 +994,16 @@
[(id? last) (cons last id*)] [(id? last) (cons last id*)]
[(syntax-null? last) id*] [(syntax-null? last) id*]
[else [else
(stx-error stx "not an identifier" last)])]) (syntax-violation #f "not an identifier" stx last)])])
(cond (cond
[(null? id*) (values)] [(null? id*) (values)]
[(not (id? (car id*))) [(not (id? (car id*)))
(stx-error stx "not an identifier" (car id*))] (syntax-violation #f "not an identifier" stx (car id*))]
[else [else
(f (cdr id*)) (f (cdr id*))
(when (bound-id-member? (car id*) (cdr id*)) (when (bound-id-member? (car id*) (cdr id*))
(stx-error stx "duplicate binding" (car id*)))]))] (syntax-violation #f "duplicate binding" stx (car id*)))]))]
[_ (stx-error stx "malformed binding form" fmls)])) [_ (syntax-violation #f "malformed binding form" stx fmls)]))
(define let-macro (define let-macro
(lambda (stx) (lambda (stx)
@ -1817,9 +1817,9 @@
(not (free-id-member? kwd valid-kwds))) (not (free-id-member? kwd valid-kwds)))
(stx-error kwd "not a valid define-record-type keyword")] (stx-error kwd "not a valid define-record-type keyword")]
[(bound-id-member? kwd seen*) [(bound-id-member? kwd seen*)
(stx-error x (syntax-violation #f
"duplicate use of keyword " "duplicate use of keyword "
(symbol->string (stx->datum kwd)))] x kwd)]
[else (f (cdr cls*) (cons kwd seen*))])] [else (f (cdr cls*) (cons kwd seen*))])]
[cls [cls
(stx-error cls "malformed define-record-type clause")])))) (stx-error cls "malformed define-record-type clause")]))))
@ -2368,7 +2368,10 @@
((type-descriptor) type-descriptor-transformer) ((type-descriptor) type-descriptor-transformer)
((record-type-descriptor) record-type-descriptor-transformer) ((record-type-descriptor) record-type-descriptor-transformer)
((record-constructor-descriptor) record-constructor-descriptor-transformer) ((record-constructor-descriptor) record-constructor-descriptor-transformer)
(else (assertion-violation 'macro-transformer "cannot find transformer" name))))) (else (assertion-violation
'macro-transformer
"BUG: cannot find transformer"
name)))))
(define file-options-macro (define file-options-macro
(lambda (x) (lambda (x)
@ -2432,8 +2435,12 @@
fields mutable immutable parent protocol fields mutable immutable parent protocol
sealed opaque nongenerative parent-rtd) sealed opaque nongenerative parent-rtd)
incorrect-usage-macro) incorrect-usage-macro)
(else (assertion-violation 'macro-transformer "invalid macro" x)))) (else
(else (assertion-violation 'core-macro-transformer "invalid macro" x))))) (assertion-violation 'macro-transformer
"BUG: invalid macro" x))))
(else
(assertion-violation 'core-macro-transformer
"BUG: invalid macro" x)))))
(define (local-macro-transformer x) (define (local-macro-transformer x)
(car x)) (car x))
@ -2458,7 +2465,8 @@
(let ((transformer (let ((transformer
(cond (cond
((procedure? x) x) ((procedure? x) x)
(else (assertion-violation 'chi-global-macro "not a procedure"))))) (else (assertion-violation 'chi-global-macro
"BUG: not a procedure" x)))))
(let ((s (transformer (add-mark anti-mark e)))) (let ((s (transformer (add-mark anti-mark e))))
(add-mark (gen-mark) s)))))) (add-mark (gen-mark) s))))))
@ -2634,7 +2642,7 @@
(build-sequence no-source (build-sequence no-source
(list (chi-expr expr r mr) (list (chi-expr expr r mr)
(build-void))))) (build-void)))))
(else (assertion-violation 'chi-rhs "invalid rhs" rhs))))) (else (assertion-violation 'chi-rhs "BUG: invalid rhs" rhs)))))
(define chi-rhs* (define chi-rhs*
(lambda (rhs* r mr) (lambda (rhs* r mr)
@ -2909,7 +2917,7 @@
(set-global-macro-binding! id loc b) (set-global-macro-binding! id loc b)
(chi-top* (cdr e*) init*)))))) (chi-top* (cdr e*) init*))))))
((let-syntax letrec-syntax) ((let-syntax letrec-syntax)
(assertion-violation 'chi-top* "not supported yet at top level" type)) (assertion-violation 'chi-top* "BUG: not supported yet at top level" type))
((begin) ((begin)
(syntax-match e () (syntax-match e ()
((_ x* ...) ((_ x* ...)
@ -2938,9 +2946,9 @@
((assq sym (library-subst lib)) => ((assq sym (library-subst lib)) =>
(lambda (p) (lambda (p)
(unless (eq? (cdr p) label) (unless (eq? (cdr p) label)
(stx-error e (syntax-violation 'import
"identifier conflict" "identifier conflict"
sym)))) e sym))))
(else (else
(extend-library-subst! lib sym label)))) (extend-library-subst! lib sym label))))
subst-names subst-labels))) subst-names subst-labels)))
@ -2971,7 +2979,8 @@
((null? exp*) ((null? exp*)
(let ((id* (map (lambda (x) (mkstx x top-mark* '())) ext*))) (let ((id* (map (lambda (x) (mkstx x top-mark* '())) ext*)))
(unless (valid-bound-ids? id*) (unless (valid-bound-ids? id*)
(assertion-violation 'expander "invalid exports" (find-dups id*)))) (syntax-violation 'export "invalid exports"
(find-dups id*))))
(values (map syntax->datum int*) (map syntax->datum ext*))) (values (map syntax->datum int*) (map syntax->datum ext*)))
(else (else
(syntax-match (car exp*) () (syntax-match (car exp*) ()
@ -2980,12 +2989,12 @@
(unless (and (eq? (syntax->datum rename) 'rename) (unless (and (eq? (syntax->datum rename) 'rename)
(for-all id? i*) (for-all id? i*)
(for-all id? e*)) (for-all id? e*))
(assertion-violation 'expander "invalid export specifier" (car exp*))) (syntax-violation 'export "invalid export specifier" (car exp*)))
(f (cdr exp*) (append i* int*) (append e* ext*)))) (f (cdr exp*) (append i* int*) (append e* ext*))))
(ie (ie
(begin (begin
(unless (id? ie) (unless (id? ie)
(assertion-violation 'expander "invalid export" ie)) (syntax-violation 'export "invalid export" ie))
(f (cdr exp*) (cons ie int*) (cons ie ext*))))))))) (f (cdr exp*) (cons ie int*) (cons ie ext*)))))))))
;;; given a library name, like (foo bar (1 2 3)), ;;; given a library name, like (foo bar (1 2 3)),
@ -3032,7 +3041,7 @@
;;; and (#<library (foo)> #<library (bar)>) ;;; and (#<library (foo)> #<library (bar)>)
(define (parse-import-spec* imp*) (define (parse-import-spec* imp*)
(define (dup-error name) (define (dup-error name)
(assertion-violation 'import "two imports with different bindings" name)) (syntax-violation 'import "two imports with different bindings" name))
(define (merge-substs s subst) (define (merge-substs s subst)
(define (insert-to-subst a subst) (define (insert-to-subst a subst)
(let ((name (car a)) (label (cdr a))) (let ((name (car a)) (label (cdr a)))
@ -3053,7 +3062,7 @@
(define (exclude sym subst) (define (exclude sym subst)
(cond (cond
((null? subst) ((null? subst)
(assertion-violation 'import "cannot rename unbound identifier" sym)) (syntax-violation 'import "cannot rename unbound identifier" sym))
((eq? sym (caar subst)) ((eq? sym (caar subst))
(values (cdar subst) (cdr subst))) (values (cdar subst) (cdr subst)))
(else (else
@ -3070,7 +3079,7 @@
(map (lambda (x) (map (lambda (x)
(cond (cond
((assq x subst) => cdr) ((assq x subst) => cdr)
(else (assertion-violation 'import "cannot find identifier" x)))) (else (syntax-violation 'import "cannot find identifier" x))))
sym*)) sym*))
(define (rem* sym* subst) (define (rem* sym* subst)
(let f ((subst subst)) (let f ((subst subst))
@ -3107,7 +3116,7 @@
(lambda (x) (<= x (syntax->datum n)))] (lambda (x) (<= x (syntax->datum n)))]
[(p? n) (and (eq? (syntax->datum p?) '>=) (subversion? n)) [(p? n) (and (eq? (syntax->datum p?) '>=) (subversion? n))
(lambda (x) (>= x (syntax->datum n)))] (lambda (x) (>= x (syntax->datum n)))]
[_ (assertion-violation 'import "invalid sub-version spec" x* spec)])) [_ (syntax-violation 'import "invalid sub-version spec" spec x*)]))
(define (version-pred x*) (define (version-pred x*)
(syntax-match x* () (syntax-match x* ()
[() (lambda (x) #t)] [() (lambda (x) #t)]
@ -3132,7 +3141,7 @@
[else [else
(and ((car p*) (car x)) (and ((car p*) (car x))
(f (cdr p*) (cdr x*)))]))))] (f (cdr p*) (cdr x*)))]))))]
[_ (assertion-violation 'import "invalid version spec" x* spec)])) [_ (syntax-violation 'import "invalid version spec" spec x*)]))
(let f ([x spec]) (let f ([x spec])
(syntax-match x () (syntax-match x ()
[((version-spec* ...)) [((version-spec* ...))
@ -3183,23 +3192,22 @@
;;; FIXME: versioning stuff ;;; FIXME: versioning stuff
(let-values ([(name pred) (parse-library-name spec*)]) (let-values ([(name pred) (parse-library-name spec*)])
(when (null? name) (when (null? name)
(assertion-violation 'import "empty library name" spec*)) (syntax-violation 'import "empty library name" spec*))
(let ((lib (find-library-by-name name))) (let ((lib (find-library-by-name name)))
(unless lib (unless lib
(assertion-violation 'import (syntax-violation 'import
"cannot find library with required name" "cannot find library with required name"
name)) name))
(unless (pred (library-version lib)) (unless (pred (library-version lib))
(assertion-violation 'import (syntax-violation 'import
"library does not satisfy version specification" "library does not satisfy version specification"
lib spec* lib))
spec*))
((imp-collector) lib) ((imp-collector) lib)
(library-subst lib)))) (library-subst lib))))
((x x* ...) ((x x* ...)
(not (memq (syntax->datum x) '(rename except only prefix library))) (not (memq (syntax->datum x) '(rename except only prefix library)))
(get-import `(library (,x . ,x*)))) (get-import `(library (,x . ,x*))))
(spec (assertion-violation 'import "invalid import spec" spec)))) (spec (syntax-violation 'import "invalid import spec" spec))))
(define (add-imports! imp h) (define (add-imports! imp h)
(let ([subst (get-import imp)]) (let ([subst (get-import imp)])
(for-each (for-each
@ -3246,28 +3254,28 @@
(define inv-collector (define inv-collector
(make-parameter (make-parameter
(lambda args (lambda args
(assertion-violation 'inv-collector "not initialized")) (assertion-violation 'inv-collector "BUG: not initialized"))
(lambda (x) (lambda (x)
(unless (procedure? x) (unless (procedure? x)
(assertion-violation 'inv-collector "not a procedure" x)) (assertion-violation 'inv-collector "BUG: not a procedure" x))
x))) x)))
(define vis-collector (define vis-collector
(make-parameter (make-parameter
(lambda args (lambda args
(assertion-violation 'vis-collector "not initialized")) (assertion-violation 'vis-collector "BUG: not initialized"))
(lambda (x) (lambda (x)
(unless (procedure? x) (unless (procedure? x)
(assertion-violation 'vis-collector "not a procedure" x)) (assertion-violation 'vis-collector "BUG: not a procedure" x))
x))) x)))
(define imp-collector (define imp-collector
(make-parameter (make-parameter
(lambda args (lambda args
(assertion-violation 'imp-collector "not initialized")) (assertion-violation 'imp-collector "BUG: not initialized"))
(lambda (x) (lambda (x)
(unless (procedure? x) (unless (procedure? x)
(assertion-violation 'imp-collector "not a procedure" x)) (assertion-violation 'imp-collector "BUG: not a procedure" x))
x))) x)))
(define chi-library-internal (define chi-library-internal
@ -3311,7 +3319,8 @@
(let ([b (cdr p)]) (let ([b (cdr p)])
(let ([type (car b)]) (let ([type (car b)])
(when (eq? type 'mutable) (when (eq? type 'mutable)
(assertion-violation 'export errstr name)))))))) (syntax-violation 'export
errstr name))))))))
export-subst) export-subst)
(let ((invoke-body (let ((invoke-body
(build-library-letrec* no-source (build-library-letrec* no-source
@ -3350,8 +3359,8 @@
(values imp* b*)) (values imp* b*))
(((import . x) . y) (((import . x) . y)
(eq? (syntax->datum import) 'import) (eq? (syntax->datum import) 'import)
(assertion-violation 'expander (syntax-violation 'expander
"invalid syntax of top-level program")) "invalid syntax of top-level program" (syntax-car e*)))
(_ (_
(assertion-violation 'expander (assertion-violation 'expander
"top-level program is missing an (import ---) clause")))) "top-level program is missing an (import ---) clause"))))