From f950e2dfe64cbe99d7fc3befda4e4296b4a156ff Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 3 Feb 2009 22:03:35 +0000 Subject: [PATCH] stxclass: fixed/simplified error reporting, removed dead code svn: r13396 --- collects/stxclass/private/codegen.ss | 90 ++++++++++++++------------- collects/stxclass/private/kws.ss | 5 +- collects/stxclass/private/messages.ss | 88 ++++++++++++++------------ collects/stxclass/private/rep-data.ss | 17 +---- collects/stxclass/private/rep.ss | 60 ++++-------------- 5 files changed, 111 insertions(+), 149 deletions(-) diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 8eb5f858a6..1685612b13 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -24,15 +24,16 @@ (cond [(rhs:union? rhs) (with-syntax ([(arg ...) args]) #`(lambda (x arg ...) - (define (fail-rhs x expected reason frontier) - (make-failed x expected reason frontier)) + (define (fail-rhs x expected frontier) + (make-failed x expected frontier)) #,(let ([pks (rhs->pks rhs relsattrs #'x)]) - (if (pair? pks) - (parse:pks (list #'x) - (list (empty-frontier #'x)) - pks - #'fail-rhs) - (fail #'fail-rhs #'x #:fce (empty-frontier #'x))))))] + (unless (pair? pks) + (wrong-syntax (rhs-orig-stx rhs) + "syntax class has no variants")) + (parse:pks (list #'x) + (list (empty-frontier #'x)) + pks + #'fail-rhs))))] [(rhs:basic? rhs) (rhs:basic-parser rhs)])) @@ -67,13 +68,12 @@ (unless (stx-list? clauses-stx) (wrong-syntax clauses-stx "expected sequence of clauses")) (let ([pks (map clause->pk (stx->list clauses-stx))]) - (if (pair? pks) - (parse:pks (list var) - (list (empty-frontier var)) - pks - failid) - (fail failid var #:fce (empty-frontier var))))) - + (unless (pair? pks) + (wrong-syntax stx "no variants")) + (parse:pks (list var) + (list (empty-frontier var)) + pks + failid))) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) @@ -107,7 +107,7 @@ (if x #,k-rest #,(fail #'enclosing-fail main-var - #:reason "side condition failed" + #:pattern (expectation-of/message "side condition failed") #:fce (done-frontier main-var))))))] [(cons (struct clause:with (p e)) rest) (let* ([new-iattrs (append (pattern-attrs p) iattrs)] @@ -139,12 +139,13 @@ (syntax->list stx)) ;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx -(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fce fce) - (with-syntax ([k k] [x x] [p p] [reason reason] +(define (fail k x #:pattern p #:fce fce) + (with-syntax ([k k] + [x x] + [p p] [fc-expr (frontier->expr fce)]) #`(let ([failcontext fc-expr]) - #;(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext) - (k x p 'reason failcontext)))) + (k x p failcontext)))) ;; Parsing @@ -163,8 +164,7 @@ #`(with-enclosing-fail #,failvar #,(pk-k pk)))]) (with-syntax ([failvar failvar] [(expr ...) exprs]) - #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))]) - (try failvar (expr ...)))))] + #`(try failvar [expr ...] #,failid)))] [else (let-values ([(vars extpks) (split-pks vars pks)]) (let* ([failvar (car (generate-temporaries #'(fail-k)))] @@ -173,8 +173,7 @@ (parse:extpk vars fcs extpk failvar))]) (with-syntax ([failvar failvar] [(expr ...) exprs]) - #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))]) - (try failvar (expr ...))))))])) + #`(try failvar [expr ...] #,failid))))])) ;; parse:extpk : (listof identifier) (listof FCE) ExtPK identifier -> stx @@ -182,29 +181,38 @@ (define (parse:extpk vars fcs extpk failid) (match extpk [(struct idpks (stxclass args pks)) - (parse:pk:id vars fcs failid stxclass args pks)] + (if stxclass + (parse:pk:id/stxclass vars fcs failid stxclass args pks) + (parse:pk:id/any vars fcs failid args pks))] [(struct cpks (pairpks datumpkss literalpkss)) (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)] [(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k)) (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)])) -;; parse:pk:id : (listof id) (listof FCE) id SC stx (listof pk) -> stx -(define (parse:pk:id vars fcs failid stxclass args pks) - (define var (car vars)) - (define fc (car fcs)) - (with-syntax ([var0 var] +;; parse:pk:id/stxclass : (listof id) (listof FCE) id SC stx (listof pk) -> stx +(define (parse:pk:id/stxclass vars fcs failid stxclass args pks) + (with-syntax ([var0 (car vars)] [(arg ...) args] [(arg-var ...) (generate-temporaries args)] - [(result) (generate-temporaries #'(result))]) + [parser (sc-parser-name stxclass)] + [result (generate-temporary 'result)]) #`(let ([arg-var arg] ...) - (let ([result #,(if stxclass - #`(#,(sc-parser-name stxclass) var0 arg-var ...) - #`(list var0))]) + (let ([result (parser var0 arg-var ...)]) (if (ok? result) #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid) - #,(fail failid var + #,(fail failid (car vars) #:pattern (expectation-of-stxclass stxclass #'(arg-var ...)) - #:fce fc)))))) + #:fce (car fcs))))))) + +;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx +(define (parse:pk:id/any vars fcs failid args pks) + (with-syntax ([var0 (car vars)] + [(arg ...) args] + [(arg-var ...) (generate-temporaries args)] + [result (generate-temporary 'result)]) + #`(let ([arg-var arg] ...) + (let ([result (list var0)]) + #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid))))) ;; parse:pk:c : (listof id) (listof FCE) id ??? ... -> stx (define (parse:pk:c vars fcs failid pairpks datumpkss literalpkss) @@ -237,7 +245,7 @@ (cond #,@(if (pair? pairpks) #`([(pair? dvar0) (let ([head-var (car dvar0)] - [tail-var (cdr dvar0)]) + [tail-var (datum->syntax var0 (cdr dvar0) var0)]) #,(parse:pks (list* #'head-var #'tail-var (cdr vars)) (list* (frontier:add-car (car fcs) #'head-var) (frontier:add-cdr (car fcs)) @@ -329,6 +337,7 @@ (let ([rep (add1 rep)]) (parse-loop x #,@hid-args #,@reps enclosing-fail)) #,(fail #'enclosing-fail #'var0 + #:pattern (expectation-of/message "maximum rep constraint failed") #:fce (frontier:add-index (car fcs) #`(calculate-index #,@reps))))))) @@ -337,10 +346,9 @@ (for/list ([repvar reps] [minrep mins] #:when minrep) #`[(< #,repvar #,minrep) #,(fail #'enclosing-fail (car vars) + #:pattern (expectation-of/message "mininum rep constraint failed") #:fce (frontier:add-index (car fcs) - #`(calculate-index #,@reps)) - #:pattern (expectation-of-constants - #f '(minimum-rep-constraint-failed) '()))])]) + #`(calculate-index #,@reps)))])]) #`(cond minrep-clause ... [else (let ([hid (finalize hid-arg)] ... ... @@ -458,8 +466,6 @@ (pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2))) ;; FIXME: conservative (and (pat:literal? p1) (pat:literal? p2)) - (pat:splice? p1) - (pat:splice? p2) (pat:gseq? p1) (pat:gseq? p2))) diff --git a/collects/stxclass/private/kws.ss b/collects/stxclass/private/kws.ss index 792a974bc3..b5acb950a7 100644 --- a/collects/stxclass/private/kws.ss +++ b/collects/stxclass/private/kws.ss @@ -88,9 +88,9 @@ ;; A PatternParseResult is one of ;; - (listof value) -;; - (make-failed stx sexpr(Pattern) string frontier/#f) +;; - (make-failed stx expectation/c frontier/#f) (define (ok? x) (or (pair? x) (null? x))) -(define-struct failed (stx patstx reason frontier) +(define-struct failed (stx expectation frontier) #:transparent) @@ -98,4 +98,3 @@ (syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar)))) expr)) - diff --git a/collects/stxclass/private/messages.ss b/collects/stxclass/private/messages.ss index 3f34db32b1..0197aa9b2c 100644 --- a/collects/stxclass/private/messages.ss +++ b/collects/stxclass/private/messages.ss @@ -1,9 +1,12 @@ #lang scheme/base -(require (for-syntax scheme/base "rep-data.ss") +(require (for-syntax scheme/base syntax/stx "rep-data.ss") + scheme/contract scheme/match) (provide (for-syntax expectation-of-stxclass - expectation-of-constants) + expectation-of-constants + expectation-of/message) try + expectation/c expectation-of-null? expectation->string) @@ -13,46 +16,63 @@ (define-struct expc (stxclasses pairs? data literals) #:transparent) +(define expectation/c (or/c expc?)) + (define (make-stxclass-expc scdyn) (make-expc (list scdyn) #f null null)) (begin-for-syntax (define certify (syntax-local-certifier)) (define (expectation-of-stxclass stxclass args) - (if stxclass - (with-syntax ([name (sc-name stxclass)] - [desc-var (sc-description stxclass)] - [(arg ...) args]) - (certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...))))) - #'#f)) + (unless (sc? stxclass) + (raise-type-error 'expectation-of-stxclass "stxclass" stxclass)) + (with-syntax ([name (sc-name stxclass)] + [desc-var (sc-description stxclass)] + [(arg ...) args]) + (certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...)))))) (define (expectation-of-constants pairs? data literals) (with-syntax ([(datum ...) data] [(literal ...) literals] [pairs? pairs?]) (certify - #'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...)))))) + #'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...))))) -(define-syntax try - (syntax-rules () - [(try failvar (expr0)) - expr0] - [(try failvar (expr0 . exprs)) - (let ([failvar - (lambda (x1 p1 r1 f1) - (let ([failvar - (lambda (x2 p2 r2 f2) - (choose-error failvar x1 x2 p1 p2 r1 r2 f1 f2))]) - (try failvar exprs)))]) - expr0)])) + (define (expectation-of/message msg) + (with-syntax ([msg msg]) + (certify + #'(make-expc '() #f '((msg)) '()))))) -(define (choose-error k x1 x2 p1 p2 r1 r2 frontier1 frontier2) - (define (go1) (k x1 p1 r1 frontier1)) - (define (go2) (k x2 p2 r2 frontier2)) + +(define-syntax (try stx) + (syntax-case stx () + [(try failvar (expr ...) previous-fail) + (when (stx-null? #'(expr ...)) + (raise-syntax-error #f "must have at least one attempt" stx)) + #'(try* (list (lambda (failvar) expr) ...) previous-fail)])) + +;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result +;; FailFunction = (stx expectation/c ?? DynamicFrontier) -> Result +(define (try* attempts fail) + (let ([first-attempt (car attempts)] + [rest-attempts (cdr attempts)]) + (if (null? rest-attempts) + (first-attempt fail) + (let ([next-fail + (lambda (x1 p1 f1) + (let ([combining-fail + (lambda (x2 p2 f2) + (choose-error fail x1 x2 p1 p2 f1 f2))]) + (try* rest-attempts combining-fail)))]) + (first-attempt next-fail))))) + +(define (choose-error k x1 x2 p1 p2 frontier1 frontier2) + (define (go1) (k x1 p1 frontier1)) + (define (go2) (k x2 p2 frontier2)) (let loop ([f1 frontier1] [f2 frontier2]) (cond [(and (null? f1) (null? f2)) (let ([p (merge-expectations p1 p2)]) - (k x1 p #f frontier1))] + (k x1 p frontier1))] [(and (pair? f1) (null? f2)) (go1)] [(and (null? f1) (pair? f2)) (go2)] [(and (pair? f1) (pair? f2)) @@ -68,7 +88,8 @@ (union (expc-data e1) (expc-data e2)) (union (expc-literals e1) (expc-literals e2)))) -(define union append) +(define (union a b) + (append a (for/list ([x b] #:when (not (member x a))) x))) (define (expectation-of-null? e) (match e @@ -141,18 +162,3 @@ [(2) (format "~a ~a~a" (car items) ult (cadr items))] [else (let ([strings (list* (car items) (loop (cdr items)))]) (apply string-append strings))])) - -;; (define (comma-list items0) -;; (define items (for/list ([item items0]) (format "~s" item))) -;; (define (loop items) -;; (cond [(null? items) -;; null] -;; [(null? (cdr items)) -;; (list ", or " (car items))] -;; [else -;; (list* ", " (car items) (loop (cdr items)))])) -;; (case (length items) -;; [(2) (format "~a or ~a" (car items) (cadr items))] -;; [else (let ([strings (list* (car items) (loop (cdr items)))]) -;; (apply string-append strings))])) - diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index eb4a7af172..73ebb8a08c 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -17,10 +17,7 @@ (struct-out pat:datum) (struct-out pat:literal) (struct-out pat:pair) - (struct-out pat:splice) (struct-out pat:gseq) - (struct-out splice-pattern) - (struct-out pat:splice-id) (struct-out head) (struct-out clause:when) (struct-out clause:with)) @@ -68,16 +65,8 @@ (define-struct (pat:datum pattern) (datum) #:transparent) (define-struct (pat:literal pattern) (literal) #:transparent) (define-struct (pat:pair pattern) (head tail) #:transparent) -(define-struct (pat:splice pattern) (head tail) #:transparent) (define-struct (pat:gseq pattern) (heads tail) #:transparent) -;; A SplicePattern is one of -;; (make-pat:splice-id identifier SSC (listof stx)) -(define-struct (splice-pattern pattern) () - #:transparent) -(define-struct (pat:splice-id splice-pattern) (name stx-splice-class args) - #:transparent) - ;; A Head is ;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f) (define-struct head (orig-stx attrs depth ps min max as-list? occurs default) @@ -196,7 +185,7 @@ (syntax-e scname))] [_ (void)]) (let ([sc (get-stxclass scname)]) - (values id sc null (ssc? sc))))] + (values id sc null)))] [(decls id0) => (lambda (p) (define scname (cadr p)) @@ -207,8 +196,8 @@ "too few arguments for syntax-class ~a (expected ~s)" (sc-name stxclass) (length (sc-inputs stxclass)))) - (values id0 stxclass args (ssc? stxclass)))] - [else (values id0 #f null #f)])) + (values id0 stxclass args))] + [else (values id0 #f null)])) ;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index 6821bc4608..62fc25040e 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -6,18 +6,16 @@ syntax/stx "../util.ss" "rep-data.ss") + (provide/contract [parse-pattern - (->* [any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer?] - [boolean?] - pattern?)] + (-> any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer? + pattern?)] [parse-pattern-directives (->* [stx-list?] [#:sc? boolean? #:literals (listof identifier?)] (values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))] - [parse-rhs (syntax? boolean? syntax? . -> . rhs?)] - [parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)]) - + [parse-rhs (syntax? boolean? syntax? . -> . rhs?)]) (define (atomic-datum? stx) (let ([datum (syntax-e stx)]) @@ -49,16 +47,6 @@ ;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs. ;; Used for pass1 (attr collection); parser requires stxclasses to be bound. (define (parse-rhs stx allow-unbound? ctx) - (parse-rhs* stx allow-unbound? #f ctx)) - -;; parse-splice-rhs : stx(SyntaxClassRHS) boolean stx -> RHS -;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs. -;; Used for pass1 (attr collection); parser requires stxclasses to be bound. -(define (parse-splice-rhs stx allow-unbound? ctx) - (parse-rhs* stx allow-unbound? #t ctx)) - -;; parse-rhs* : stx boolean boolean stx -> RHS -(define (parse-rhs* stx allow-unbound? splice? ctx) (define-values (chunks rest) (chunk-kw-seq stx rhs-directive-table #:context ctx)) (define lits0 (assq '#:literals chunks)) @@ -90,7 +78,7 @@ (define (gather-patterns stx) (syntax-case stx (pattern) [((pattern . _) . rest) - (cons (parse-rhs-pattern (stx-car stx) allow-unbound? splice? literals) + (cons (parse-rhs-pattern (stx-car stx) allow-unbound? literals) (gather-patterns #'rest))] [() null])) @@ -110,7 +98,7 @@ (parse-rhs*-patterns rest)])) ;; parse-rhs-pattern : stx boolean boolean (listof identifier) -> RHS -(define (parse-rhs-pattern stx allow-unbound? splice? literals) +(define (parse-rhs-pattern stx allow-unbound? literals) (syntax-case stx (pattern) [(pattern p . rest) (parameterize ((allow-unbound-stxclasses allow-unbound?)) @@ -122,8 +110,6 @@ (wrong-syntax (if (pair? rest) (car rest) rest) "unexpected terms after pattern directives")) (let* ([pattern (parse-pattern #'p decls 0)] - [_ (when splice? - (check-proper-list-pattern pattern))] [with-patterns (for/list ([c clauses] #:when (clause:with? c)) (clause:with-pattern c))] @@ -141,7 +127,7 @@ (list '#:transparent))) ;; parse-pattern : stx(Pattern) env number -> Pattern -(define (parse-pattern stx decls depth [allow-splice? #f]) +(define (parse-pattern stx decls depth) (syntax-case stx () [dots (or (dots? #'dots) @@ -152,10 +138,7 @@ (make pat:literal stx null depth stx)] [id (identifier? #'id) - (let-values ([(name sc args splice?) (split-id/get-stxclass #'id decls)]) - (when splice? - (unless allow-splice? - (wrong-syntax stx "splice-pattern not allowed here"))) + (let-values ([(name sc args) (split-id/get-stxclass #'id decls)]) (let ([attrs (cond [(wildcard? name) null] [(and (epsilon? name) sc) @@ -167,9 +150,7 @@ [else (list (make attr name depth (if sc (sc-attrs sc) null)))])] [name (if (epsilon? name) #f name)]) - (if splice? - (make pat:splice-id stx attrs depth name sc args) - (make pat:id stx attrs depth name sc args))))] + (make pat:id stx attrs depth name sc args)))] [datum (atomic-datum? #'datum) (make pat:datum stx null depth (syntax->datum #'datum))] @@ -188,12 +169,10 @@ [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)) stx)]) (make pat:gseq stx attrs depth (list head) tail))] [(a . b) - (let ([pa (parse-pattern #'a decls depth #t)] + (let ([pa (parse-pattern #'a decls depth)] [pb (parse-pattern #'b decls depth)]) (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)) stx)]) - (if (splice-pattern? pa) - (make pat:splice stx attrs depth pa pb) - (make pat:pair stx attrs depth pa pb))))])) + (make pat:pair stx attrs depth pa pb)))])) (define (pattern->head p) (match p @@ -360,20 +339,3 @@ decls remap (reverse rclauses)))) - -;; check-proper-list-pattern : Pattern -> void -(define (check-proper-list-pattern p) - (define (err stx) - (wrong-syntax stx "not a proper list pattern")) - (match p - [(struct pat:id (orig-stx _ _ _ _ _)) - (err orig-stx)] - [(struct pat:datum (orig-stx _ _ datum)) - (unless (null? datum) - (err orig-stx))] - [(struct pat:pair (_ _ _ head tail)) - (check-proper-list-pattern tail)] - [(struct pat:splice (_ _ _ head tail)) - (check-proper-list-pattern tail)] - [(struct pat:gseq (_ _ _ heads tail)) - (check-proper-list-pattern tail)]))