From 28fcdd3df67a27813a04cbe93b37e009923e321b Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Fri, 30 Nov 2007 05:36:25 -0500 Subject: [PATCH] Fixed bug 172986: define-record-type allowing invalid syntax --- scheme/last-revision | 2 +- scheme/psyntax.expander.ss | 27 ++++++++++++++++++++++++++- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/scheme/last-revision b/scheme/last-revision index 23ca55f..de439d0 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1145 +1146 diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 87a62b2..884c053 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -1693,9 +1693,34 @@ (lambda (set-foo-x! idx) `(define ,set-foo-x! (record-mutator ,foo-rtd ,idx))) set-foo-x!* set-foo-idx*))))) + (define (verify-clauses x cls*) + (define valid-kwds + (map bless + '(fields parent parent-rtd protocol sealed opaque nongenerative))) + (define (free-id-member? x ls) + (and (pair? ls) + (or (free-id=? x (car ls)) + (free-id-member? x (cdr ls))))) + (let f ([cls* cls*] [seen* '()]) + (unless (null? cls*) + (syntax-match (car cls*) () + [(kwd . rest) + (cond + [(or (not (id? kwd)) + (not (free-id-member? kwd valid-kwds))) + (stx-error kwd "not a valid define-record-type keyword")] + [(bound-id-member? kwd seen*) + (stx-error x + "duplicate use of keyword " + (symbol->string (stx->datum kwd)))] + [else (f (cdr cls*) (cons kwd seen*))])] + [cls + (stx-error cls "malformed define-record-type clause")])))) (syntax-match x () [(_ namespec clause* ...) - (do-define-record namespec clause*)]))) + (begin + (verify-clauses x clause*) + (do-define-record namespec clause*))]))) (define define-condition-type-macro (lambda (x)