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

syntax/parse:

Browse Source 
allow forward references from conventions
  fix progress comparison bug

svn: r18019
This commit is contained in:
Ryan Culpepper 2010-02-08 18:39:56 +00:00
parent 89eb249b00
commit c1373f8214
4 changed files with 85 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/syntax/private/stxparse/rep-data.ss
View File

@ -88,17 +88,22 @@ DeclEntry =
(make-den:lit id id)
(make-den:class id id (listof syntax) bool)
(make-den:parser id id (listof SAttr) bool bool)
(make-den:delayed id id id)
|#
(define-struct declenv (table conventions))
(define-struct den:lit (internal external))
(define-struct den:class (name class args))
(define-struct den:parser (parser description attrs splicing? commit?))
(define-struct den:delayed (parser description class))
(define (new-declenv literals #:conventions [conventions null])
(for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)])
(make-declenv
(for/fold ([table (make-immutable-bound-id-table)])
([literal literals])
(declenv-put-literal decls (car literal) (cadr literal))))
(bound-id-table-set table (car literal)
(make den:lit (car literal) (cadr literal))))
conventions))
(define (declenv-lookup env id #:use-conventions? [use-conventions? #t])
(or (bound-id-table-ref (declenv-table env) id #f)
@ -124,13 +129,6 @@ DeclEntry =
(wrong-syntax id "(internal error) late unbound check")]
['#f (void)])))
(define (declenv-put-literal env internal-id lit-id)
(declenv-check-unbound env internal-id)
(make-declenv
(bound-id-table-set (declenv-table env) internal-id
(make den:lit internal-id lit-id))
(declenv-conventions env)))
(define (declenv-put-stxclass env id stxclass-name args)
(declenv-check-unbound env id)
(make-declenv
@ -138,13 +136,6 @@ DeclEntry =
(make den:class id stxclass-name args))
(declenv-conventions env)))
(define (declenv-put-parser env id parser get-description attrs splicing? commit?)
;; no unbound check, since replacing 'stxclass entry
(make-declenv
(bound-id-table-set (declenv-table env) id
(make den:parser parser get-description attrs splicing? commit?))
(declenv-conventions env)))
;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
;; -> (values DeclEnv a)
(define (declenv-update/fold env0 f acc0)
@ -183,14 +174,16 @@ DeclEntry =
(flat-named-contract 'DeclEnv declenv?))
(define DeclEntry/c
(flat-named-contract 'DeclEntry (or/c den:lit? den:class? den:parser?)))
(flat-named-contract 'DeclEntry
(or/c den:lit? den:class? den:parser? den:delayed?)))
(define SideClause/c
(or/c clause:fail? clause:with? clause:attr?))
(provide (struct-out den:lit)
(struct-out den:class)
(struct-out den:parser))
(struct-out den:parser)
(struct-out den:delayed))
(provide/contract
[DeclEnv/c contract?]
@ -209,12 +202,6 @@ DeclEntry =
[declenv-put-stxclass
(-> DeclEnv/c identifier? identifier? (listof syntax?)
DeclEnv/c)]
[declenv-put-literal
(-> DeclEnv/c identifier? identifier?
DeclEnv/c)]
[declenv-put-parser
(-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? boolean?
DeclEnv/c)]
[declenv-domain-difference
(-> DeclEnv/c (listof identifier?)
(listof identifier?))]

56
collects/syntax/private/stxparse/rep.ss
View File

@ -212,24 +212,31 @@
[(struct den:lit (_i _e))
(values entry null)]
[(struct den:class (name class args))
(cond [(identifier? name)
(let ([sc (get-stxclass/check-arg-count class (length args))])
(with-syntax ([sc-parser (stxclass-parser-name sc)]
[sc-description (stxclass-description sc)])
(if (pair? args)
(with-syntax ([x (generate-temporary 'x)]
[parser (generate-temporary class)]
[description (generate-temporary class)]
[(arg ...) args])
(with-syntax ([parser (generate-temporary class)]
[description (generate-temporary class)])
(values (make den:parser #'parser #'description
(stxclass-attrs sc) (stxclass/h? sc)
(stxclass-commit? sc))
(list #'(define (parser x) (sc-parser x arg ...))
#'(define (description) (description arg ...)))))
(values (make den:parser #'sc-parser #'sc-description
(stxclass-attrs sc) (stxclass/h? sc)
(stxclass-commit? sc))
null))))]
(list #`(define-values (parser description)
(curried-stxclass-procedures
#,class #,args)))))))]
[(regexp? name)
;; Conventions rule; delay class lookup until module/intdefs pass2
;; to allow forward references
(fprintf (current-error-port) "conventions aux def\n")
(with-syntax ([parser (generate-temporary class)]
[description (generate-temporary class)])
(values (make den:delayed #'parser #'get-description class)
(list #`(define-values (parser description)
(curried-stxclass-procedures
#,class #,args)))))])]
[(struct den:parser (_p _d _a _sp _c))
(values entry null)]
[(struct den:delayed (_p _d _c))
(values entry null)]))
(define (append-lits+litsets lits litsets)
@ -450,9 +457,29 @@
"(internal error) decls had leftover stxclass entry: ~s"
entry)]
[(struct den:parser (parser desc attrs splicing? commit?))
;; FIXME: why no allow-head? check???
(if splicing?
(parse-pat:id/h id parser null attrs commit?)
(begin
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id parser null attrs commit?))
(parse-pat:id/s id parser null attrs commit?))]
[(struct den:delayed (parser desc class))
(let ([sc (get-stxclass class)])
(cond [(stxclass/s? sc)
(parse-pat:id/s id
parser
null
(stxclass-attrs sc)
(stxclass-commit? sc))]
[(stxclass/h? sc)
(unless allow-head?
(wrong-syntax id "splicing syntax class not allowed here"))
(parse-pat:id/h id
parser
null
(stxclass-attrs sc)
(stxclass-commit? sc))]))]
['#f
(when #t ;; FIXME: right place???
(unless (safe-name? id)
@ -1007,8 +1034,9 @@
[_ (raise-syntax-error #f "expected syntax class use" ctx x)]))
(syntax-case stx ()
[(rx sc)
(list (check-conventions-pattern (syntax-e #'rx) #'rx)
(check-sc-expr #'sc #'rx))]))
(let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)])
(list name-pattern
(check-sc-expr #'sc name-pattern)))]))
;; bind clauses
(define (check-bind-clause-list stx ctx)

22
collects/syntax/private/stxparse/runtime.ss
View File

@ -254,8 +254,8 @@ A Dynamic Frontier Context (DFC) is one of
[(list (make dfc:car pa _) (make dfc:car pb _))
(compare-idfcs pa pb)]
[(list (make dfc:cdr pa na) (make dfc:cdr pb nb))
(cond [(< na nb) '<]
[(> na nb) '>]
(cond [(< na nb) (compare-idfcs pa (make dfc:cdr pb (- nb na)))]
[(> na nb) (compare-idfcs (make-dfc:cdr pa (- na nb)) pb)]
[(= na nb) (compare-idfcs pa pb)])]
[(list (make dfc:pre pa _) (make dfc:pre pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
@ -579,3 +579,21 @@ An Expectation is one of
(define-struct parser (proc errors)
#:property prop:procedure (struct-field-index proc))
;;
(provide curried-stxclass-procedures)
(define-syntax (curried-stxclass-procedures stx)
(syntax-case stx ()
[(cp class (arg ...))
(let* ([args (syntax->list #'(arg ...))]
[sc (get-stxclass/check-arg-count #'class (length args))])
(with-syntax ([parser (stxclass-parser-name sc)]
[get-description (stxclass-description sc)]
[(extra ...)
(if (stxclass-commit? sc)
#'()
#'(k))])
#'(values (lambda (x extra ...) (parser x extra ... arg ...))
(lambda () (get-description arg ...)))))]))

11
collects/syntax/private/stxparse/sc.ss
View File

@ -3,6 +3,7 @@
scheme/private/sc
unstable/syntax
unstable/struct
"minimatch.ss"
"rep-data.ss"
"rep.ss")
scheme/list
@ -101,12 +102,10 @@
[den (cadr line)])
(let-values ([(den defs) (create-aux-def den)])
(list #`(list (quote #,rx)
(make-den:parser
(quote-syntax #,(den:parser-parser den))
(quote-syntax #,(den:parser-description den))
(quote #,(den:parser-attrs den))
(quote #,(den:parser-splicing? den))
(quote #,(den:parser-commit? den))))
(make-den:delayed
(quote-syntax #,(den:delayed-parser den))
(quote-syntax #,(den:delayed-description den))
(quote-syntax #,(den:delayed-class den))))
defs))))])
#'(begin
def ... ...