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

syntax/parse:

Browse Source 
added parameterized conventions
  fixed description for "str" stxclass
  fixed bug in multiple #:declare directives

svn: r18439
This commit is contained in:
Ryan Culpepper 2010-03-03 05:50:15 +00:00
parent af22da2e1e
commit cec810a9df
6 changed files with 122 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/syntax/private/stxparse/lib.ss
View File

@ -40,10 +40,14 @@
(define-pred-stxclass identifier symbol?)
(define-pred-stxclass boolean boolean?)
(define-pred-stxclass str string?)
(define-pred-stxclass character char?)
(define-pred-stxclass keyword keyword?)
(define-syntax-class str #:attributes () #:opaque
#:description "string"
(pattern x
#:fail-unless (string? (syntax-e #'x)) #f))
(define-pred-stxclass number number?)
(define-pred-stxclass integer integer?)
(define-pred-stxclass exact-integer exact-integer?)

14
collects/syntax/private/stxparse/parse.ss
View File

@ -46,20 +46,6 @@
;; ----
#|
syntax-class protocol
---------------------
for syntax-class SC with args (P ...)
if commit? = #t
parser : Stx P ... -> (U list expectation)
if commit? = #f
parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer
|#
;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
;; : expr[(values ParseFunction DescriptionFunction)]
;; Takes a list of the relevant attrs; order is significant!

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

@ -21,6 +21,31 @@
(struct-out conventions)
(struct-out literalset))
#|
NOTES
syntax-class protocol
---------------------
Two kinds of syntax class: commit? = #t, commit? = #f
let syntax-class SC have params (P ...)
if commit? = #t
parser : Stx P ... -> (U list expectation)
if commit? = #f
parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer
conventions
-----------
let conventions C have params (P ...)
get-procedures :
(P ... -> (values (listof ParserFun) (listof DescriptionFun)))
|#
#|
A stxclass is
(make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean)
@ -60,10 +85,10 @@ A SideClause is one of
#|
A Conventions is
(make-conventions (listof ConventionRule))
(make-conventions id (-> (listof ConventionRule)))
A ConventionRule is (list regexp DeclEntry)
|#
(define-struct conventions (rules) #:transparent)
(define-struct conventions (get-procedures get-rules) #:transparent)
#|
A LiteralSet is

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

@ -173,9 +173,11 @@
(define (get-decls+defs chunks strict?
#:context [ctx (current-syntax-context)])
(parameterize ((current-syntax-context ctx))
(decls-create-defs (get-decls chunks strict?))))
(let*-values ([(decls defs1) (get-decls chunks strict?)]
[(decls defs2) (decls-create-defs decls)])
(values decls (append defs1 defs2)))))
;; get-decls : chunks -> DeclEnv
;; get-decls : chunks -> (values DeclEnv (listof syntax))
(define (get-decls chunks strict?)
(define lits (options-select-value chunks '#:literals #:default null))
(define litsets (options-select-value chunks '#:literal-sets #:default null))
@ -184,8 +186,28 @@
(define literals
(append-lits+litsets (check-literals-bound lits strict?)
litsets))
(define convention-rules (apply append (cons localconvs convs)))
(new-declenv literals #:conventions convention-rules))
(define-values (convs-rules convs-defs)
(for/fold ([convs-rules null] [convs-defs null])
([conv-entry convs])
(let* ([c (car conv-entry)]
[args (cdr conv-entry)]
[get-parser-id (conventions-get-procedures c)]
[rules ((conventions-get-rules c))])
(values (append rules convs-rules)
(cons (make-conventions-def (map cadr rules) get-parser-id args)
convs-defs)))))
(define convention-rules (append localconvs convs-rules))
(values (new-declenv literals #:conventions convention-rules)
(reverse convs-defs)))
;; make-conventions-def : (listof den:delay) id (listof syntax) -> syntax
(define (make-conventions-def dens get-procedures-id args)
(with-syntax ([(parser ...) (map den:delayed-parser dens)]
[get-procedures get-procedures-id]
[(arg ...) args])
#'(define-values (parser ...)
(let-values ([(parsers descriptions) (get-procedures arg ...)])
(apply values parsers)))))
(define (check-literals-bound lits strict?)
(define phase (syntax-local-phase-level))
@ -229,7 +251,7 @@
;; to allow forward references
(with-syntax ([parser (generate-temporary class)]
[description (generate-temporary class)])
(values (make den:delayed #'parser #'get-description class)
(values (make den:delayed #'parser #'description class)
(list #`(define-values (parser description)
(curried-stxclass-procedures
#,class #,args)))))])]
@ -891,26 +913,26 @@
;; grab-decls : (listof chunk) DeclEnv
;; -> (values DeclEnv (listof chunk))
(define (grab-decls chunks decls)
(define (grab-decls chunks decls0)
(define (add-decl stx decls)
(syntax-case stx ()
[(#:declare name sc)
(identifier? #'sc)
(add-decl* #'name #'sc null)]
(add-decl* decls #'name #'sc null)]
[(#:declare name (sc expr ...))
(identifier? #'sc)
(add-decl* #'name #'sc (syntax->list #'(expr ...)))]
(add-decl* decls #'name #'sc (syntax->list #'(expr ...)))]
[(#:declare name bad-sc)
(wrong-syntax #'bad-sc
"expected syntax class name (possibly with parameters)")]))
(define (add-decl* id sc-name args)
(define (add-decl* decls id sc-name args)
(declenv-put-stxclass decls id sc-name args))
(define (loop chunks decls)
(match chunks
[(cons (cons '#:declare decl-stx) rest)
(loop rest (add-decl decl-stx decls))]
[_ (values decls chunks)]))
(loop chunks decls))
(loop chunks decls0))
;; ----
@ -989,23 +1011,28 @@
(list (datum->syntax lctx (car entry) srcctx)
(cadr entry))))
;; returns (listof (cons Conventions (listof syntax)))
(define (check-conventions-list stx ctx)
(unless (stx-list? stx)
(raise-syntax-error #f "expected conventions list" ctx stx))
(for/list ([x (stx->list stx)])
(check-conventions x ctx)))
;; returns (cons Conventions (listof syntax))
(define (check-conventions stx ctx)
(define (elaborate conventions-id)
(define (elaborate conventions-id args)
(let ([cs (syntax-local-value/catch conventions-id conventions?)])
(unless cs
(raise-syntax-error #f "expected identifier defined as a conventions"
ctx conventions-id))
(conventions-rules cs)))
(cons cs args)))
(syntax-case stx ()
[(conventions arg ...)
(identifier? #'conventions)
(elaborate #'conventions (syntax->list #'(arg ...)))]
[conventions
(identifier? #'conventions)
(elaborate #'conventions)]
(elaborate #'conventions null)]
[_
(raise-syntax-error "expected conventions entry" ctx stx)]))
@ -1019,9 +1046,12 @@
;; returns (list regexp DeclEntry)
(define (check-conventions-rule stx ctx)
(define (check-conventions-pattern x blame)
(cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))]
(cond [(symbol? x)
(regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))]
[(regexp? x) x]
[else (raise-syntax-error #f "expected identifier convention pattern" ctx blame)]))
[else
(raise-syntax-error #f "expected identifier convention pattern"
ctx blame)]))
(define (check-sc-expr x rx)
(syntax-case x ()
[sc

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

@ -561,7 +561,7 @@ An Expectation is one of
(define (frontier->sexpr dfc)
(match (invert-dfc dfc)
[(make dfc:empty _) '()]
[(make dfc:car p _) (cons 0 (frontier->sexpr p))]
[(make dfc:car p _) (cons 'car (frontier->sexpr p))]
[(make dfc:cdr p n) (cons n (frontier->sexpr p))]
[(make dfc:pre p _) (cons 'pre (frontier->sexpr p))]
[(make dfc:post p _) (cons 'post (frontier->sexpr p))]))

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

@ -92,26 +92,52 @@
(define-syntax (define-conventions stx)
(syntax-case stx ()
[(define-conventions name rule ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f "expected identifier" stx #'name))
(with-syntax ([([entry (def ...)] ...)
(for/list ([line (check-conventions-rules #'(rule ...) stx)])
(let ([rx (car line)]
[den (cadr line)])
(let-values ([(den defs) (create-aux-def den)])
(list #`(list (quote #,rx)
(make-den:delayed
(quote-syntax #,(den:delayed-parser den))
(quote-syntax #,(den:delayed-description den))
(quote-syntax #,(den:delayed-class den))))
defs))))])
[(define-conventions (name param ...) rule ...)
(let ([params (syntax->list #'(param ...))])
(for ([x (syntax->list #'(name param ...))])
(unless (identifier? x)
(raise-syntax-error #f "expected identifier" stx x)))
(let ()
(define rules (check-conventions-rules #'(rule ...) stx))
(define rxs (map car rules))
(define dens0 (map cadr rules))
(define den+defs-list
(for/list ([den0 dens0])
(let-values ([(den defs) (create-aux-def den0)])
(cons den defs))))
(define dens (map car den+defs-list))
(define defs (apply append (map cdr den+defs-list)))
(define/with-syntax (rx ...) rxs)
(define/with-syntax (def ...) defs)
(define/with-syntax (parser ...)
(map den:delayed-parser dens))
(define/with-syntax (description ...)
(map den:delayed-description dens))
(define/with-syntax (class-name ...)
(map den:delayed-class dens))
#'(begin
def ... ...
(define-syntax name
(make-conventions
(list entry ...))))))]))
(quote-syntax get-procedures)
(lambda ()
(let ([class-names (list (quote-syntax class-name) ...)])
(map list
(list 'rx ...)
(map make-den:delayed
(generate-temporaries class-names)
(generate-temporaries class-names)
class-names))))))
(define get-procedures
(lambda (param ...)
def ...
(values (list parser ...)
(list description ...)))))))]
[(define-conventions name rule ...)
(identifier? #'name)
#'(define-conventions (name) rule ...)]))
(define-syntax (define-literal-set stx)
(syntax-case stx ()
@ -182,7 +208,7 @@
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #t #:context stx)])
(let ([rhs (parse-rhs #'rhs #f #f #:context stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)