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

* Fixes bug 163980: Error message contains "fmls" 

Slightly better error message for malformed formal parameters
  (duplicate and non-identifiers are signaled properly).
This commit is contained in:
Abdulaziz Ghuloum 2007-11-21 02:10:42 -05:00
parent 978093bcc2
commit b71de5dab4
2 changed files with 36 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1098 1099

52
scheme/psyntax.expander.ss
View File

@ -951,7 +951,7 @@
(syntax-match e () (syntax-match e ()
((_ (fmls* b* b** ...) ...) ((_ (fmls* b* b** ...) ...)
(let-values (((fmls* body*) (let-values (((fmls* body*)
(chi-lambda-clause* fmls* (chi-lambda-clause* e fmls*
(map cons b* b**) r mr))) (map cons b* b**) r mr)))
(build-case-lambda no-source fmls* body*)))))) (build-case-lambda no-source fmls* body*))))))
@ -960,7 +960,7 @@
(syntax-match e () (syntax-match e ()
((_ fmls b b* ...) ((_ fmls b b* ...)
(let-values (((fmls body) (let-values (((fmls body)
(chi-lambda-clause fmls (chi-lambda-clause e fmls
(cons b b*) r mr))) (cons b b*) r mr)))
(build-lambda no-source fmls body)))))) (build-lambda no-source fmls body))))))
@ -985,18 +985,36 @@
`(syntax-case (list . ,expr*) () `(syntax-case (list . ,expr*) ()
(,fml* (begin ,b . ,b*)))))))) (,fml* (begin ,b . ,b*))))))))
(define (invalid-fmls-error stx fmls)
(syntax-match fmls ()
[(id* ... . last)
(let f ([id* (cond
[(id? last) (cons last id*)]
[(syntax-null? last) id*]
[else
(stx-error stx "not an identifier" last)])])
(cond
[(null? id*) (values)]
[(not (id? (car id*)))
(stx-error stx "not an identifier" (car id*))]
[else
(f (cdr id*))
(when (bound-id-member? (car id*) (cdr id*))
(stx-error stx "duplicate binding" (car id*)))]))]
[_ (stx-error stx "malformed binding form" fmls)]))
(define let-macro (define let-macro
(lambda (stx) (lambda (stx)
(syntax-match stx () (syntax-match stx ()
((_ ((lhs* rhs*) ...) b b* ...) ((_ ((lhs* rhs*) ...) b b* ...)
(if (valid-bound-ids? lhs*) (if (valid-bound-ids? lhs*)
(bless `((lambda ,lhs* ,b . ,b*) . ,rhs*)) (bless `((lambda ,lhs* ,b . ,b*) . ,rhs*))
(stx-error stx "invalid bindings"))) (invalid-fmls-error stx lhs*)))
((_ f ((lhs* rhs*) ...) b b* ...) (id? f) ((_ f ((lhs* rhs*) ...) b b* ...) (id? f)
(if (valid-bound-ids? lhs*) (if (valid-bound-ids? lhs*)
(bless `(letrec ((,f (lambda ,lhs* ,b . ,b*))) (bless `(letrec ((,f (lambda ,lhs* ,b . ,b*)))
(,f . ,rhs*))) (,f . ,rhs*)))
(stx-error stx "invalid syntax")))))) (invalid-fmls-error stx lhs*))))))
(define trace-lambda-macro (define trace-lambda-macro
(lambda (stx) (lambda (stx)
@ -1005,12 +1023,12 @@
(if (valid-bound-ids? fmls) (if (valid-bound-ids? fmls)
(bless `(make-traced-procedure ',who (bless `(make-traced-procedure ',who
(lambda ,fmls ,b . ,b*))) (lambda ,fmls ,b . ,b*)))
(stx-error stx "invalid formals"))) (invalid-fmls-error stx fmls)))
((_ who (fmls ... . last) b b* ...) ((_ who (fmls ... . last) b b* ...)
(if (valid-bound-ids? (cons last fmls)) (if (valid-bound-ids? (cons last fmls))
(bless `(make-traced-procedure ',who (bless `(make-traced-procedure ',who
(lambda (,@fmls . ,last) ,b . ,b*))) (lambda (,@fmls . ,last) ,b . ,b*)))
(stx-error stx "invalid formals")))))) (invalid-fmls-error stx (append fmls last)))))))
(define trace-define-macro (define trace-define-macro
(lambda (stx) (lambda (stx)
@ -1020,13 +1038,13 @@
(bless `(define ,who (bless `(define ,who
(make-traced-procedure ',who (make-traced-procedure ',who
(lambda ,fmls ,b . ,b*)))) (lambda ,fmls ,b . ,b*))))
(stx-error stx "invalid formals"))) (invalid-fmls-error stx fmls)))
((_ (who fmls ... . last) b b* ...) ((_ (who fmls ... . last) b b* ...)
(if (valid-bound-ids? (cons last fmls)) (if (valid-bound-ids? (cons last fmls))
(bless `(define ,who (bless `(define ,who
(make-traced-procedure ',who (make-traced-procedure ',who
(lambda (,@fmls . ,last) ,b . ,b*)))) (lambda (,@fmls . ,last) ,b . ,b*))))
(stx-error stx "invalid formals"))) (invalid-fmls-error stx (append fmls last))))
((_ who expr) ((_ who expr)
(if (id? who) (if (id? who)
(bless `(define ,who (bless `(define ,who
@ -1035,7 +1053,7 @@
(make-traced-procedure ',who v) (make-traced-procedure ',who v)
(error 'trace-define (error 'trace-define
"not a procedure" v))))) "not a procedure" v)))))
(stx-error stx "invalid formals")))))) (stx-error stx "invalid name"))))))
(define guard-macro (define guard-macro
(lambda (x) (lambda (x)
@ -2406,7 +2424,7 @@
(else (stx-error e)))))))) (else (stx-error e))))))))
(define chi-lambda-clause (define chi-lambda-clause
(lambda (fmls body* r mr) (lambda (stx fmls body* r mr)
(syntax-match fmls () (syntax-match fmls ()
((x* ...) ((x* ...)
(if (valid-bound-ids? x*) (if (valid-bound-ids? x*)
@ -2418,7 +2436,7 @@
(add-subst (make-full-rib x* lab*) body*) (add-subst (make-full-rib x* lab*) body*)
(add-lexicals lab* lex* r) (add-lexicals lab* lex* r)
mr))) mr)))
(stx-error fmls "invalid fmls"))) (invalid-fmls-error stx fmls)))
((x* ... . x) ((x* ... . x)
(if (valid-bound-ids? (cons x x*)) (if (valid-bound-ids? (cons x x*))
(let ((lex* (map gen-lexical x*)) (lab* (map gen-label x*)) (let ((lex* (map gen-lexical x*)) (lab* (map gen-label x*))
@ -2431,18 +2449,18 @@
body*) body*)
(add-lexicals (cons lab lab*) (cons lex lex*) r) (add-lexicals (cons lab lab*) (cons lex lex*) r)
mr))) mr)))
(stx-error fmls "invalid fmls"))) (invalid-fmls-error stx fmls)))
(_ (stx-error fmls "invalid fmls"))))) (_ (stx-error fmls "invalid syntax")))))
(define chi-lambda-clause* (define chi-lambda-clause*
(lambda (fmls* body** r mr) (lambda (stx fmls* body** r mr)
(cond (cond
((null? fmls*) (values '() '())) ((null? fmls*) (values '() '()))
(else (else
(let-values (((a b) (let-values (((a b)
(chi-lambda-clause (car fmls*) (car body**) r mr))) (chi-lambda-clause stx (car fmls*) (car body**) r mr)))
(let-values (((a* b*) (let-values (((a* b*)
(chi-lambda-clause* (cdr fmls*) (cdr body**) r mr))) (chi-lambda-clause* stx (cdr fmls*) (cdr body**) r mr)))
(values (cons a a*) (cons b b*)))))))) (values (cons a a*) (cons b b*))))))))
(define chi-rhs (define chi-rhs
@ -2452,7 +2470,7 @@
(let ((x (cdr rhs))) (let ((x (cdr rhs)))
(let ((fmls (car x)) (body* (cdr x))) (let ((fmls (car x)) (body* (cdr x)))
(let-values (((fmls body) (let-values (((fmls body)
(chi-lambda-clause fmls body* r mr))) (chi-lambda-clause fmls fmls body* r mr)))
(build-lambda no-source fmls body))))) (build-lambda no-source fmls body)))))
((expr) ((expr)
(let ((expr (cdr rhs))) (let ((expr (cdr rhs)))