suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

stxclass: fixed/simplified error reporting, removed dead code

Browse Source 
svn: r13396
This commit is contained in:
Ryan Culpepper 2009-02-03 22:03:35 +00:00
parent f27f1f7223
commit f950e2dfe6
5 changed files with 111 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
collects/stxclass/private/codegen.ss
View File

@ -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)))

5
collects/stxclass/private/kws.ss
View File

@ -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))

88
collects/stxclass/private/messages.ss
View File

@ -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))]))

17
collects/stxclass/private/rep-data.ss
View File

@ -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 <Pattern> 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)

60
collects/stxclass/private/rep.ss
View File

@ -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)]))