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

stxclass: improved error reporting & transparent stxclasses

Browse Source 
svn: r13568
This commit is contained in:
Ryan Culpepper 2009-02-14 03:00:24 +00:00
parent dba74f8f15
commit 5b0ceb3db4
4 changed files with 96 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/stxclass/private/codegen-data.ss
View File

@ -24,51 +24,62 @@
;; A LiteralPKS is (make-literalpks identifier (listof PK))
(define-struct literalpks (literal pks))
;; A FrontierContextExpr (FCE) is one of
;; - (list FrontierIndexExpr Syntax)
;; - (list* FrontierIndexExpr Syntax FrontierContextExpr)
;; - (make-joined-frontier FCE id)
;; - (make-fce Id FrontierIndexExpr)
;; - (make-joined-frontier FCE id)
;; A FrontierIndexExpr is
;; - `(+ ,Number Syntax ...)
;; - `(+ ,Number ,Syntax ...)
(define-struct fce (stx indexes))
(define-struct joined-frontier (base ext) #:transparent)
(define (empty-frontier x)
(list '(+ 0) x))
(make-fce x (list '(+ 0))))
(define (done-frontier x)
(list '(+ +inf.0) x))
(make-fce x (list '(+ +inf.0))))
(define (frontier:add-car fc x)
(list* '(+ 0) x fc))
(make-fce x (cons '(+ 0) (fce-indexes fc))))
(define (frontier:add-cdr fc)
(cons (fi:add1 (car fc))
(cdr fc)))
(define (fi:add1 fi)
`(+ ,(add1 (cadr fi)) ,@(cddr fi)))
(define (fi:add1 fi)
`(+ ,(add1 (cadr fi)) ,@(cddr fi)))
(make-fce (fce-stx fc)
(cons (fi:add1 (car (fce-indexes fc)))
(cdr (fce-indexes fc)))))
(define (frontier:add-index fc expr)
(cons (fi:add-index (car fc) expr)
(cdr fc)))
(define (fi:add-index fi expr)
`(+ ,(cadr fi) ,expr ,@(cddr fi)))
(define (fi:add-index fi expr)
`(+ ,(cadr fi) ,expr ,@(cddr fi)))
(make-fce (fce-stx fc)
(cons (fi:add-index (car (fce-indexes fc)) expr)
(cdr (fce-indexes fc)))))
(define (join-frontiers base ext-expr)
(make-joined-frontier base ext-expr))
(define (join-frontiers base ext)
(make-joined-frontier base ext))
;; A DynamicFrontierContext (DFC) is one of
;; - (list Syntax Number)
;; - (list* Syntax Number DynamicFrontierContext)
;; A DynamicFrontierContext (DFC) is a list of numbers.
;; More operations on DFCs in runtime.ss
(define (frontier->expr fc)
(define (frontier->dfc-expr fc)
(define (loop fc)
(match fc
[(list fe stx)
#`(list #,fe #,stx)]
[(list* fe stx rest)
#`(list* #,fe #,stx #,(loop rest))]
[(struct fce (stx indexes))
#`(list #,@indexes)]
[(struct joined-frontier (base ext))
#`(let ([base #,(loop base)])
(if #,ext (append (reverse (failed-frontier #,ext)) base) base))]))
(if (failed? #,ext)
(append (reverse (failed-frontier #,ext)) base)
base))]))
#`(reverse #,(loop fc)))
(define (frontier->fstx-expr fc)
(define (loop fc)
(match fc
[(struct fce (stx indexes))
stx]
[(struct joined-frontier (base ext))
#`(let ([inner-failure #,ext])
(or (and (failed? inner-failure) (failed-frontier-stx inner-failure))
#,(loop base)))]))
(loop fc))

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

@ -23,9 +23,9 @@
(cond [(rhs:union? rhs)
(with-syntax ([(arg ...) args])
#`(lambda (x arg ...)
(define (fail-rhs x expected frontier)
(define (fail-rhs x expected frontier frontier-stx)
#,(if (rhs-transparent? rhs)
#`(make-failed x expected frontier)
#`(make-failed x expected frontier frontier-stx)
#'#f))
#,(let ([pks (rhs->pks rhs relsattrs #'x)])
(unless (pair? pks)
@ -139,15 +139,16 @@
(wrong-syntax id "expected identifier")))
(syntax->list stx))
;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx
;; fail : id id #:pattern datum #:reason datum #:fce FCE #:fstx id -> stx
(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])
(k x p failcontext))))
[fc-expr (frontier->dfc-expr fce)]
[fstx-expr (frontier->fstx-expr fce)])
#`(let ([failcontext fc-expr]
[failcontext-syntax fstx-expr])
(k x p failcontext failcontext-syntax))))
;; Parsing
@ -201,15 +202,9 @@
(let ([result (parser var0 arg-var ...)])
(if (ok? result)
#,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)
(if (failed? result)
#,(fail failid (car vars)
;; FIXME: join expectation with this stxclass
;; for better error message
#:pattern #'(failed-expectation result) ;; join with this-stxclass
#:fce (join-frontiers (car fcs) #'result))
#,(fail failid (car vars)
#:pattern (expectation-of-stxclass stxclass #'(arg-var ...))
#:fce (car fcs))))))))
#,(fail failid (car vars)
#:pattern (expectation-of-stxclass stxclass #'(arg-var ...) #'result)
#:fce (join-frontiers (car fcs) #'result)))))))
;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx
(define (parse:pk:id/any vars fcs failid args pks)

74
collects/stxclass/private/runtime.ss
View File

@ -75,21 +75,38 @@
;; A PatternParseResult is one of
;; - (listof value)
;; - (make-failed stx expectation/c frontier/#f)
;; - (make-failed stx expectation/c frontier/#f stx)
(define (ok? x) (or (pair? x) (null? x)))
(define-struct failed (stx expectation frontier)
(define-struct failed (stx expectation frontier frontier-stx)
#:transparent)
;; Runtime: Dynamic Frontier Contexts (DFCs)
;; A DFC is a list of numbers.
;; compare-dfcs : DFC DFC -> (one-of '< '= '>)
;; Note A>B means A is "further along" than B.
(define (compare-dfcs a b)
(cond [(and (null? a) (null? b))
'=]
[(and (pair? a) (null? b))
'>]
[(and (null? a) (pair? b))
'<]
[(and (pair? a) (pair? b))
(cond [(> (car a) (car b)) '>]
[(< (car a) (car b)) '<]
[else (compare-dfcs (cdr a) (cdr b))])]))
;; Runtime: parsing failures/expectations
;; An Expectation is
;; (make-expc (listof scdyn) bool (listof atom) (listof id))
;; (make-expc (listof scdyn) (listof expc) (listof atom) (listof id))
(define-struct expc (stxclasses pairs? data literals)
#:transparent)
(define-struct scdyn (name desc)
(define-struct scdyn (name desc failure)
#:transparent)
(define expectation/c (or/c expc?))
@ -99,13 +116,17 @@
(begin-for-syntax
(define certify (syntax-local-certifier))
(define (expectation-of-stxclass stxclass args)
(define (expectation-of-stxclass stxclass args result-var)
(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 ...))))))
(certify #`(begin
;;(printf "inner failure was ~s\n" #,result-var)
(make-stxclass-expc
(make-scdyn 'name (desc-var arg ...)
(if (failed? #,result-var) #,result-var #f)))))))
(define (expectation-of-constants pairs? data literals)
(with-syntax ([(datum ...) data]
@ -135,28 +156,18 @@
(if (null? rest-attempts)
(first-attempt fail)
(let ([next-fail
(lambda (x1 p1 f1)
(lambda (x1 p1 f1 fs1)
(let ([combining-fail
(lambda (x2 p2 f2)
(choose-error fail x1 x2 p1 p2 f1 f2))])
(lambda (x2 p2 f2 fs2)
(choose-error fail x1 x2 p1 p2 f1 f2 fs1 fs2))])
(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 frontier1))]
[(and (pair? f1) (null? f2)) (go1)]
[(and (null? f1) (pair? f2)) (go2)]
[(and (pair? f1) (pair? f2))
(let ([c1 (cadr f1)]
[c2 (cadr f2)])
(cond [(> c1 c2) (go1)]
[(< c1 c2) (go2)]
[else (loop (cddr f1) (cddr f2))]))])))
(define (choose-error k x1 x2 p1 p2 frontier1 frontier2 fs1 fs2)
(case (compare-dfcs frontier1 frontier2)
[(>) (k x1 p1 frontier1 fs1)]
[(<) (k x2 p2 frontier2 fs2)]
[(=) (k x1 (merge-expectations p1 p2) frontier1 fs1)]))
(define (merge-expectations e1 e2)
(make-expc (union (expc-stxclasses e1) (expc-stxclasses e2))
@ -190,14 +201,15 @@
";"
"or"))]))
(define (string-of-stxclasses stxclasses)
(comma-list (map string-of-stxclass stxclasses)))
(define (string-of-stxclasses scdyns)
(comma-list (map string-of-stxclass scdyns)))
(define (string-of-stxclass stxclass)
(and stxclass
(format "~a"
(or (scdyn-desc stxclass)
(scdyn-name stxclass)))))
(define (string-of-stxclass scdyn)
(define expected (or (scdyn-desc scdyn) (scdyn-name scdyn)))
(if (scdyn-failure scdyn)
(let ([inner (expectation->string (failed-expectation (scdyn-failure scdyn)))])
(or inner (format "~a" expected)))
(format "~a" expected)))
(define (string-of-literals literals0)
(define literals

14
collects/stxclass/private/sc.ss
View File

@ -7,6 +7,7 @@
"rep.ss"
"codegen.ss"
"../util.ss")
scheme/list
scheme/match
syntax/stx
"runtime.ss")
@ -198,7 +199,7 @@
[(with-patterns ([p x] . more) . b)
(syntax-parse x [p (with-patterns more . b)])]))
(define ((syntax-patterns-fail stx0) x expected frontier)
(define ((syntax-patterns-fail stx0) x expected frontier frontier-stx)
(define (err msg stx)
(raise (make-exn:fail:syntax
(if msg
@ -206,7 +207,7 @@
(string->immutable-string "bad syntax"))
(current-continuation-marks)
(list stx))))
(define-values (stx n) (frontier->syntax frontier))
(define n (last frontier))
(cond [(expectation-of-null? expected)
;; FIXME: "extra term(s) after <pattern>"
(syntax-case x ()
@ -226,17 +227,10 @@
[else (format " after ~s ~a"
n
(if (= 1 n) "form" "forms"))]))
stx))]
frontier-stx))]
[else
(err #f stx0)]))
(define (frontier->syntax f)
(match f
[(list x n)
(values x n)]
[(list-rest _ _ rest)
(frontier->syntax rest)]))
#|