syntax/parse: lazily load most macro transformers and compile-time support
This commit is contained in:
Ryan Culpepper
parent
3441d0f7d0
commit
1c6b8bd68e
|
|
@ -6,11 +6,15 @@
|
|||
"private/rep.rkt"
|
||||
"private/kws.rkt")
|
||||
"../parse.rkt"
|
||||
syntax/parse/private/residual
|
||||
"private/runtime.rkt"
|
||||
"private/runtime-progress.rkt"
|
||||
"private/runtime-report.rkt"
|
||||
(except-in "private/runtime-report.rkt"
|
||||
syntax-patterns-fail)
|
||||
"private/kws.rkt")
|
||||
|
||||
;; No lazy loading for this module's dependencies.
|
||||
|
||||
(provide syntax-class-parse
|
||||
syntax-class-attributes
|
||||
syntax-class-arity
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
"../private/lib.rkt"
|
||||
"provide.rkt"
|
||||
unstable/wrapc
|
||||
(only-in "../private/runtime.rkt"
|
||||
(only-in syntax/parse/private/residual ;; keep abs. path
|
||||
this-context-syntax)
|
||||
racket/contract/base)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,77 +1,5 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
"../private/minimatch.rkt"
|
||||
"../private/rep.rkt"
|
||||
"../private/rep-data.rkt"
|
||||
"../private/rep-patterns.rkt")
|
||||
"../private/keywords.rkt"
|
||||
"../private/sc.rkt")
|
||||
|
||||
(require "../private/sc.rkt"
|
||||
"../private/keywords.rkt")
|
||||
(provide ~eh-var
|
||||
define-eh-alternative-set)
|
||||
|
||||
(define-syntax (define-eh-alternative-set stx)
|
||||
(define-syntax-class alt
|
||||
#:description "eh-alternate-set alternative"
|
||||
#:literals (pattern)
|
||||
(pattern (pattern alt)))
|
||||
(syntax-parse stx
|
||||
#:literals (pattern)
|
||||
[(_ name:id a:alt ...)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(let* ([decls (new-declenv null #:conventions null)]
|
||||
[ehpat+hstx-list
|
||||
(apply append
|
||||
(for/list ([alt (in-list (syntax->list #'(a.alt ...)))])
|
||||
(parse*-ellipsis-head-pattern alt decls #t #:context stx)))]
|
||||
[eh-alt+defs-list
|
||||
(for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
|
||||
(let ([ehpat (car ehpat+hstx)]
|
||||
[hstx (cadr ehpat+hstx)])
|
||||
(cond [(syntax? hstx)
|
||||
(with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))])
|
||||
(let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))])
|
||||
(list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
|
||||
(list #`(define parser
|
||||
(parser/rhs parser () #,attrs
|
||||
[#:description #f (pattern #,hstx)]
|
||||
#t
|
||||
#,stx))))))]
|
||||
[(eh-alternative? hstx)
|
||||
(list hstx null)]
|
||||
[else
|
||||
(error 'define-eh-alternative-set "internal error: unexpected ~e"
|
||||
hstx)])))]
|
||||
[eh-alts (map car eh-alt+defs-list)]
|
||||
[defs (apply append (map cadr eh-alt+defs-list))])
|
||||
(with-syntax ([(def ...) defs]
|
||||
[(alt-expr ...)
|
||||
(for/list ([alt (in-list eh-alts)])
|
||||
(with-syntax ([repc-expr
|
||||
(match (eh-alternative-repc alt)
|
||||
['#f
|
||||
#'(quote #f)]
|
||||
[(rep:once n u o)
|
||||
#`(rep:once (quote-syntax #,n)
|
||||
(quote-syntax #,u)
|
||||
(quote-syntax #,o))]
|
||||
[(rep:optional n o d)
|
||||
#`(rep:optional (quote-syntax #,n)
|
||||
(quote-syntax #,o)
|
||||
(quote-syntax #,d))]
|
||||
[(rep:bounds min max n u o)
|
||||
#`(rep:bounds (quote #,min)
|
||||
(quote #,max)
|
||||
(quote-syntax #,n)
|
||||
(quote-syntax #,u)
|
||||
(quote-syntax #,o))])]
|
||||
[attrs-expr
|
||||
#`(quote #,(eh-alternative-attrs alt))]
|
||||
[parser-expr
|
||||
#`(quote-syntax #,(eh-alternative-parser alt))])
|
||||
#'(eh-alternative repc-expr attrs-expr parser-expr)))])
|
||||
#'(begin def ...
|
||||
(define-syntax name
|
||||
(eh-alternative-set (list alt-expr ...)))))))]))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,38 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
(require (for-syntax racket/base
|
||||
unstable/lazy-require
|
||||
syntax/parse/private/residual-ct) ;; keep abs.path
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
"../private/minimatch.rkt"
|
||||
"../private/keywords.rkt"
|
||||
"../private/runtime-reflect.rkt"
|
||||
"../private/kws.rkt")
|
||||
(begin-for-syntax
|
||||
(lazy-require
|
||||
[syntax/parse/private/rep-data ;; keep abs. path
|
||||
(get-stxclass
|
||||
stxclass-delimit-cut?)]))
|
||||
|
||||
(define-syntax (reify-syntax-class stx)
|
||||
(if (eq? (syntax-local-context) 'expression)
|
||||
(syntax-case stx ()
|
||||
[(rsc sc)
|
||||
(let* ([stxclass (get-stxclass #'sc)]
|
||||
[splicing? (stxclass-splicing? stxclass)])
|
||||
(unless (stxclass-delimit-cut? stxclass)
|
||||
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
|
||||
stx #'sc))
|
||||
(with-syntax ([name (stxclass-name stxclass)]
|
||||
[parser (stxclass-parser stxclass)]
|
||||
[arity (stxclass-arity stxclass)]
|
||||
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
|
||||
[ctor
|
||||
(if splicing?
|
||||
#'reified-splicing-syntax-class
|
||||
#'reified-syntax-class)])
|
||||
#'(ctor 'name parser 'arity '((aname adepth) ...))))])
|
||||
#`(#%expression #,stx)))
|
||||
|
||||
(define (reified-syntax-class-arity r)
|
||||
(match (reified-arity r)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,16 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
"../../parse.rkt"
|
||||
"../private/rep-data.rkt"
|
||||
syntax/parse
|
||||
unstable/lazy-require
|
||||
"../private/kws.rkt")
|
||||
"../private/runtime.rkt")
|
||||
syntax/parse/private/residual) ;; keep abs. path
|
||||
(provide define-primitive-splicing-syntax-class)
|
||||
|
||||
(begin-for-syntax
|
||||
(lazy-require
|
||||
[syntax/parse/private/rep-attrs
|
||||
(sort-sattrs)]))
|
||||
|
||||
(define-syntax (define-primitive-splicing-syntax-class stx)
|
||||
|
||||
(define-syntax-class attr
|
||||
|
|
|
|||
|
|
@ -3,12 +3,13 @@
|
|||
|
||||
;; == Keywords
|
||||
|
||||
(define-for-syntax (bad-keyword-use stx)
|
||||
(raise-syntax-error #f "keyword used out of context" stx))
|
||||
|
||||
(define-syntax-rule (define-keyword name)
|
||||
(begin
|
||||
(provide name)
|
||||
(define-syntax name
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword used out of context" stx)))))
|
||||
(define-syntax name bad-keyword-use)))
|
||||
|
||||
(define-keyword pattern)
|
||||
(define-keyword ~var)
|
||||
|
|
|
|||
|
|
@ -73,11 +73,3 @@
|
|||
#:attr value (syntax-local-value #'x (lambda () notfound))
|
||||
#:fail-when (eq? (attribute value) notfound) #f
|
||||
#:fail-unless (pred (attribute value)) #f))
|
||||
|
||||
#|
|
||||
(define-syntax-class expr
|
||||
#:attributes ()
|
||||
#:description "expression"
|
||||
#:commit
|
||||
(pattern (~and x (~fail #:when (keyword? (syntax-e #'x))))))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -1,14 +1,20 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
unstable/lazy-require
|
||||
"sc.rkt"
|
||||
"lib.rkt"
|
||||
"kws.rkt"
|
||||
racket/syntax
|
||||
syntax/keyword
|
||||
"rep-data.rkt"
|
||||
"rep.rkt"
|
||||
"kws.rkt")
|
||||
"runtime.rkt"
|
||||
syntax/keyword)
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
syntax/parse/private/residual ;; keep abs. path
|
||||
(only-in unstable/syntax phase-of-enclosing-module))
|
||||
(begin-for-syntax
|
||||
(lazy-require
|
||||
[syntax/parse/private/rep ;; keep abs. path
|
||||
(parse-kw-formals
|
||||
check-conventions-rules
|
||||
create-aux-def)]))
|
||||
(provide define-conventions
|
||||
define-literal-set
|
||||
literal-set->predicate
|
||||
|
|
@ -44,6 +50,8 @@
|
|||
(define/with-syntax (class-name ...)
|
||||
(map den:delayed-class dens))
|
||||
|
||||
;; FIXME: could move make-den:delayed to user of conventions
|
||||
;; and eliminate from residual.rkt
|
||||
#'(begin
|
||||
(define-syntax h.name
|
||||
(make-conventions
|
||||
|
|
|
|||
19
collects/syntax/parse/private/parse-aux.rkt
Normal file
19
collects/syntax/parse/private/parse-aux.rkt
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang racket/base
|
||||
(require (for-template "parse.rkt"))
|
||||
(provide id:define-syntax-class
|
||||
id:define-splicing-syntax-class
|
||||
id:syntax-parse
|
||||
id:syntax-parser
|
||||
id:define/syntax-parse
|
||||
id:syntax-parser/template
|
||||
id:parser/rhs
|
||||
id:define-eh-alternative-set)
|
||||
|
||||
(define (id:define-syntax-class) #'define-syntax-class)
|
||||
(define (id:define-splicing-syntax-class) #'define-splicing-syntax-class)
|
||||
(define (id:syntax-parse) #'syntax-parse)
|
||||
(define (id:syntax-parser) #'syntax-parser)
|
||||
(define (id:define/syntax-parse) #'define/syntax-parse)
|
||||
(define (id:syntax-parser/template) #'syntax-parser/template)
|
||||
(define (id:parser/rhs) #'parser/rhs)
|
||||
(define (id:define-eh-alternative-set) #'define-eh-alternative-set)
|
||||
|
|
@ -4,18 +4,170 @@
|
|||
syntax/id-table
|
||||
syntax/keyword
|
||||
racket/syntax
|
||||
"minimatch.rkt"
|
||||
"rep-attrs.rkt"
|
||||
"rep-data.rkt"
|
||||
"rep-patterns.rkt"
|
||||
"rep.rkt"
|
||||
"kws.rkt"
|
||||
"txlift.rkt")
|
||||
"keywords.rkt"
|
||||
racket/syntax
|
||||
racket/stxparam
|
||||
syntax/stx
|
||||
unstable/struct
|
||||
"runtime.rkt"
|
||||
"runtime-report.rkt"
|
||||
"runtime-reflect.rkt")
|
||||
(provide (all-defined-out))
|
||||
syntax/parse/private/residual ;; keep abs. path
|
||||
syntax/parse/private/runtime ;; keep abs.path
|
||||
syntax/parse/private/runtime-reflect) ;; keep abs. path
|
||||
|
||||
;; ============================================================
|
||||
|
||||
(provide define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
define/syntax-parse
|
||||
syntax-parser/template
|
||||
parser/rhs
|
||||
define-eh-alternative-set)
|
||||
|
||||
(begin-for-syntax
|
||||
(define (tx:define-*-syntax-class stx splicing?)
|
||||
(syntax-case stx ()
|
||||
[(_ header . rhss)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(let-values ([(name formals arity)
|
||||
(let ([p (check-stxclass-header #'header stx)])
|
||||
(values (car p) (cadr p) (caddr p)))])
|
||||
(let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)]
|
||||
[opt-rhs+def
|
||||
(and (andmap identifier? (syntax->list formals))
|
||||
(optimize-rhs the-rhs (syntax->list formals)))]
|
||||
[the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
|
||||
(with-syntax ([name name]
|
||||
[formals formals]
|
||||
[parser (generate-temporary (format-symbol "parse-~a" name))]
|
||||
[arity arity]
|
||||
[attrs (rhs-attrs the-rhs)]
|
||||
[(opt-def ...)
|
||||
(if opt-rhs+def
|
||||
(list (cadr opt-rhs+def))
|
||||
'())]
|
||||
[options (rhs-options the-rhs)]
|
||||
[integrate-expr
|
||||
(syntax-case (rhs-integrate the-rhs) ()
|
||||
[#s(integrate predicate description)
|
||||
#'(integrate (quote-syntax predicate)
|
||||
'description)]
|
||||
[#f
|
||||
#''#f])])
|
||||
#`(begin (define-syntax name
|
||||
(stxclass 'name 'arity
|
||||
'attrs
|
||||
(quote-syntax parser)
|
||||
'#,splicing?
|
||||
options
|
||||
integrate-expr))
|
||||
opt-def ...
|
||||
(define-values (parser)
|
||||
;; If opt-rhs, do not reparse:
|
||||
;; need to keep same generated predicate name
|
||||
#,(if opt-rhs+def
|
||||
(begin
|
||||
#`(parser/rhs/parsed
|
||||
name formals attrs #,the-rhs
|
||||
#,(and (rhs-description the-rhs) #t)
|
||||
#,splicing? #,stx))
|
||||
#`(parser/rhs
|
||||
name formals attrs rhss #,splicing? #,stx))))))))])))
|
||||
|
||||
(define-syntax define-syntax-class
|
||||
(lambda (stx) (tx:define-*-syntax-class stx #f)))
|
||||
(define-syntax define-splicing-syntax-class
|
||||
(lambda (stx) (tx:define-*-syntax-class stx #t)))
|
||||
|
||||
(define-syntax (parser/rhs stx)
|
||||
(syntax-case stx ()
|
||||
[(parser/rhs name formals attrs rhss splicing? ctx)
|
||||
(with-disappeared-uses
|
||||
(let ([rhs
|
||||
(parameterize ((current-syntax-context #'ctx))
|
||||
(parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
|
||||
#:context #'ctx))])
|
||||
#`(parser/rhs/parsed name formals attrs
|
||||
#,rhs #,(and (rhs-description rhs) #t)
|
||||
splicing? ctx)))]))
|
||||
|
||||
(define-syntax (parser/rhs/parsed stx)
|
||||
(syntax-case stx ()
|
||||
[(prp name formals attrs rhs rhs-has-description? splicing? ctx)
|
||||
#`(let ([get-description
|
||||
(lambda formals
|
||||
(if 'rhs-has-description?
|
||||
#,(rhs-description (syntax-e #'rhs))
|
||||
(symbol->string 'name)))])
|
||||
(parse:rhs rhs attrs formals splicing?
|
||||
(if 'rhs-has-description?
|
||||
#,(rhs-description (syntax-e #'rhs))
|
||||
(symbol->string 'name))))]))
|
||||
|
||||
(define-syntax (syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parse stx-expr . clauses)
|
||||
(quasisyntax/loc stx
|
||||
(let ([x (datum->syntax #f stx-expr)])
|
||||
(parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))]))
|
||||
|
||||
(define-syntax (syntax-parser stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parser . clauses)
|
||||
(quasisyntax/loc stx
|
||||
(lambda (x)
|
||||
(let ([x (datum->syntax #f x)])
|
||||
(parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))]))
|
||||
|
||||
(define-syntax (syntax-parser/template stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parser/template ctx . clauses)
|
||||
(quasisyntax/loc stx
|
||||
(lambda (x)
|
||||
(let ([x (datum->syntax #f x)])
|
||||
(parse:clauses x clauses one-template ctx))))]))
|
||||
|
||||
(define-syntax (define/syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
[(define/syntax-parse pattern . rest)
|
||||
(let-values ([(rest pattern defs)
|
||||
(parse-pattern+sides #'pattern
|
||||
#'rest
|
||||
#:splicing? #f
|
||||
#:decls (new-declenv null)
|
||||
#:context stx)])
|
||||
(let ([expr
|
||||
(syntax-case rest ()
|
||||
[( expr ) #'expr]
|
||||
[_ (raise-syntax-error #f "bad syntax" stx)])]
|
||||
[attrs (pattern-attrs pattern)])
|
||||
(with-syntax ([(a ...) attrs]
|
||||
[(#s(attr name _ _) ...) attrs]
|
||||
[pattern pattern]
|
||||
[(def ...) defs]
|
||||
[expr expr])
|
||||
#'(defattrs/unpack (a ...)
|
||||
(let* ([x (datum->syntax #f expr)]
|
||||
[cx x]
|
||||
[pr (ps-empty x x)]
|
||||
[es null]
|
||||
[fh0 (syntax-patterns-fail x)])
|
||||
(parameterize ((current-syntax-context x))
|
||||
def ...
|
||||
(#%expression
|
||||
(with ([fail-handler fh0]
|
||||
[cut-prompt fh0])
|
||||
(parse:S x cx pattern pr es
|
||||
(list (attribute name) ...))))))))))]))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
#|
|
||||
Parsing protocol:
|
||||
|
|
@ -807,11 +959,72 @@ Conventions:
|
|||
[(_ rep #s(rep:bounds min max name too-few-msg too-many-msg))
|
||||
(expect:message (or too-many-msg (name->too-many name)))]))
|
||||
|
||||
(define (name->too-few/once name)
|
||||
(and name (format "missing required occurrence of ~a" name)))
|
||||
;; ====
|
||||
|
||||
(define (name->too-few name)
|
||||
(and name (format "too few occurrences of ~a" name)))
|
||||
|
||||
(define (name->too-many name)
|
||||
(and name (format "too many occurrences of ~a" name)))
|
||||
(define-syntax (define-eh-alternative-set stx)
|
||||
(define (parse-alt x)
|
||||
(syntax-case x (pattern)
|
||||
[(pattern alt)
|
||||
#'alt]
|
||||
[else
|
||||
(wrong-syntax x "expected eh-alternative-set alternative")]))
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(_ name a ...)
|
||||
(unless (identifier? #'name)
|
||||
(wrong-syntax #'name "expected identifier"))
|
||||
(let* ([alts (map parse-alt (syntax->list #'(a ...)))]
|
||||
[decls (new-declenv null #:conventions null)]
|
||||
[ehpat+hstx-list
|
||||
(apply append
|
||||
(for/list ([alt (in-list alts)])
|
||||
(parse*-ellipsis-head-pattern alt decls #t #:context stx)))]
|
||||
[eh-alt+defs-list
|
||||
(for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
|
||||
(let ([ehpat (car ehpat+hstx)]
|
||||
[hstx (cadr ehpat+hstx)])
|
||||
(cond [(syntax? hstx)
|
||||
(with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))])
|
||||
(let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))])
|
||||
(list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
|
||||
(list #`(define parser
|
||||
(parser/rhs parser () #,attrs
|
||||
[#:description #f (pattern #,hstx)]
|
||||
#t
|
||||
#,stx))))))]
|
||||
[(eh-alternative? hstx)
|
||||
(list hstx null)]
|
||||
[else
|
||||
(error 'define-eh-alternative-set "internal error: unexpected ~e"
|
||||
hstx)])))]
|
||||
[eh-alts (map car eh-alt+defs-list)]
|
||||
[defs (apply append (map cadr eh-alt+defs-list))])
|
||||
(with-syntax ([(def ...) defs]
|
||||
[(alt-expr ...)
|
||||
(for/list ([alt (in-list eh-alts)])
|
||||
(with-syntax ([repc-expr
|
||||
(match (eh-alternative-repc alt)
|
||||
['#f
|
||||
#'(quote #f)]
|
||||
[(rep:once n u o)
|
||||
#`(rep:once (quote-syntax #,n)
|
||||
(quote-syntax #,u)
|
||||
(quote-syntax #,o))]
|
||||
[(rep:optional n o d)
|
||||
#`(rep:optional (quote-syntax #,n)
|
||||
(quote-syntax #,o)
|
||||
(quote-syntax #,d))]
|
||||
[(rep:bounds min max n u o)
|
||||
#`(rep:bounds (quote #,min)
|
||||
(quote #,max)
|
||||
(quote-syntax #,n)
|
||||
(quote-syntax #,u)
|
||||
(quote-syntax #,o))])]
|
||||
[attrs-expr
|
||||
#`(quote #,(eh-alternative-attrs alt))]
|
||||
[parser-expr
|
||||
#`(quote-syntax #,(eh-alternative-parser alt))])
|
||||
#'(eh-alternative repc-expr attrs-expr parser-expr)))])
|
||||
#'(begin def ...
|
||||
(define-syntax name
|
||||
(eh-alternative-set (list alt-expr ...))))))])))
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
(require syntax/parse/private/residual-ct ;; keep abs. path
|
||||
racket/contract/base
|
||||
syntax/id-table
|
||||
racket/syntax
|
||||
unstable/struct)
|
||||
(provide (struct-out attr))
|
||||
|
||||
#|
|
||||
An IAttr is (make-attr identifier number boolean)
|
||||
|
|
@ -19,8 +19,6 @@ SAttr lists are always stored in sorted order, to make comparison
|
|||
of signatures easier for reified syntax-classes.
|
||||
|#
|
||||
|
||||
(define-struct attr (name depth syntax?) #:prefab)
|
||||
|
||||
(define (iattr? a)
|
||||
(and (attr? a) (identifier? (attr-name a))))
|
||||
|
||||
|
|
|
|||
|
|
@ -4,45 +4,30 @@
|
|||
racket/list
|
||||
syntax/id-table
|
||||
racket/syntax
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
"minimatch.rkt"
|
||||
"kws.rkt"
|
||||
"rep-attrs.rkt"
|
||||
"rep-patterns.rkt")
|
||||
(provide (all-from-out "rep-attrs.rkt")
|
||||
(all-from-out "rep-patterns.rkt")
|
||||
(struct-out stxclass)
|
||||
;; from residual.rkt
|
||||
(provide (struct-out stxclass)
|
||||
(struct-out options)
|
||||
(struct-out integrate)
|
||||
stxclass/s?
|
||||
(struct-out conventions)
|
||||
(struct-out literalset)
|
||||
(struct-out eh-alternative-set)
|
||||
(struct-out eh-alternative))
|
||||
;; from here
|
||||
(provide stxclass/s?
|
||||
stxclass/h?
|
||||
stxclass-commit?
|
||||
stxclass-delimit-cut?
|
||||
(struct-out attr)
|
||||
(struct-out rhs)
|
||||
(struct-out variant)
|
||||
(struct-out clause:fail)
|
||||
(struct-out clause:with)
|
||||
(struct-out clause:attr)
|
||||
(struct-out clause:do)
|
||||
(struct-out conventions)
|
||||
(struct-out literalset)
|
||||
(struct-out eh-alternative-set)
|
||||
(struct-out eh-alternative))
|
||||
|
||||
#|
|
||||
A stxclass is
|
||||
#s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
|
||||
where Options = #s(options boolean boolean)
|
||||
Integrate = #s(integrate id string)
|
||||
Arity is defined in kws.rkt
|
||||
|#
|
||||
(define-struct stxclass (name arity attrs parser splicing? options integrate)
|
||||
#:prefab)
|
||||
|
||||
(define-struct options (commit? delimit-cut?)
|
||||
#:prefab)
|
||||
(define-struct integrate (predicate description)
|
||||
#:prefab)
|
||||
(struct-out clause:do))
|
||||
|
||||
(define (stxclass/s? x)
|
||||
(and (stxclass? x) (not (stxclass-splicing? x))))
|
||||
|
|
@ -72,33 +57,11 @@ A Variant is
|
|||
SideClause is defined in rep-patterns
|
||||
|#
|
||||
|
||||
#|
|
||||
A Conventions is
|
||||
(make-conventions id (-> (listof ConventionRule)))
|
||||
A ConventionRule is (list regexp DeclEntry)
|
||||
|#
|
||||
(define-struct conventions (get-procedures get-rules) #:transparent)
|
||||
|
||||
#|
|
||||
A LiteralSet is
|
||||
(make-literalset (listof (list symbol id phase-var-id)))
|
||||
|#
|
||||
(define-struct literalset (literals) #:transparent)
|
||||
|
||||
;; make-dummy-stxclass : identifier -> SC
|
||||
;; Dummy stxclass for calculating attributes of recursive stxclasses.
|
||||
(define (make-dummy-stxclass name)
|
||||
(make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f))
|
||||
|
||||
#|
|
||||
An EH-alternative-set is
|
||||
(eh-alternative-set (listof EH-alternative)
|
||||
An EH-alternative is
|
||||
(eh-alternative RepetitionConstraint (listof SAttr) id)
|
||||
|#
|
||||
(define-struct eh-alternative-set (alts))
|
||||
(define-struct eh-alternative (repc attrs parser))
|
||||
|
||||
;; Environments
|
||||
|
||||
#|
|
||||
|
|
@ -130,7 +93,7 @@ expressions are duplicated, and may be evaluated in different scopes.
|
|||
(define-struct den:class (name class argu))
|
||||
(define-struct den:magic-class (name class argu))
|
||||
(define-struct den:parser (parser attrs splicing? commit? delimit-cut?))
|
||||
(define-struct den:delayed (parser class))
|
||||
;; and from residual.rkt: (define-struct den:delayed (parser class))
|
||||
|
||||
(define (new-declenv literals #:conventions [conventions null])
|
||||
(make-declenv
|
||||
|
|
@ -229,6 +192,7 @@ expressions are duplicated, and may be evaluated in different scopes.
|
|||
(struct-out den:class)
|
||||
(struct-out den:magic-class)
|
||||
(struct-out den:parser)
|
||||
;; from residual.rkt:
|
||||
(struct-out den:delayed))
|
||||
|
||||
(provide/contract
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "rep-attrs.rkt"
|
||||
(require syntax/parse/private/residual-ct ;; keep abs. path
|
||||
"rep-attrs.rkt"
|
||||
"kws.rkt"
|
||||
unstable/struct
|
||||
(for-syntax racket/base
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
#lang racket/base
|
||||
(require (for-template racket/base
|
||||
racket/stxparam
|
||||
"keywords.rkt"
|
||||
"runtime.rkt")
|
||||
syntax/parse/private/keywords
|
||||
syntax/parse/private/residual ;; keep abs. path
|
||||
syntax/parse/private/runtime)
|
||||
racket/contract/base
|
||||
"minimatch.rkt"
|
||||
syntax/id-table
|
||||
|
|
@ -11,7 +12,10 @@
|
|||
racket/syntax
|
||||
unstable/struct
|
||||
"txlift.rkt"
|
||||
"rep-attrs.rkt"
|
||||
"rep-data.rkt"
|
||||
"rep-patterns.rkt"
|
||||
syntax/parse/private/residual-ct ;; keep abs. path
|
||||
"kws.rkt")
|
||||
|
||||
;; Error reporting
|
||||
|
|
@ -188,7 +192,7 @@
|
|||
(define attributes (options-select-value chunks '#:attributes #:default #f))
|
||||
(define-values (decls defs) (get-decls+defs chunks strict?))
|
||||
(values rest description transparent? attributes auto-nested? colon-notation?
|
||||
decls defs (make options commit? delimit-cut?)))
|
||||
decls defs (options commit? delimit-cut?)))
|
||||
|
||||
;; ----
|
||||
|
||||
|
|
|
|||
54
collects/syntax/parse/private/residual-ct.rkt
Normal file
54
collects/syntax/parse/private/residual-ct.rkt
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
#lang racket/base
|
||||
(provide (struct-out attr)
|
||||
(struct-out stxclass)
|
||||
(struct-out options)
|
||||
(struct-out integrate)
|
||||
(struct-out conventions)
|
||||
(struct-out literalset)
|
||||
(struct-out eh-alternative-set)
|
||||
(struct-out eh-alternative)
|
||||
(struct-out den:delayed))
|
||||
|
||||
;; == from rep-attr.rkt
|
||||
(define-struct attr (name depth syntax?) #:prefab)
|
||||
|
||||
;; == from rep-data.rkt
|
||||
|
||||
#|
|
||||
A stxclass is
|
||||
#s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
|
||||
where Options = #s(options boolean boolean)
|
||||
Integrate = #s(integrate id string)
|
||||
Arity is defined in kws.rkt
|
||||
|#
|
||||
(define-struct stxclass (name arity attrs parser splicing? options integrate)
|
||||
#:prefab)
|
||||
|
||||
(define-struct options (commit? delimit-cut?)
|
||||
#:prefab)
|
||||
(define-struct integrate (predicate description)
|
||||
#:prefab)
|
||||
|
||||
#|
|
||||
A Conventions is
|
||||
(make-conventions id (-> (listof ConventionRule)))
|
||||
A ConventionRule is (list regexp DeclEntry)
|
||||
|#
|
||||
(define-struct conventions (get-procedures get-rules) #:transparent)
|
||||
|
||||
#|
|
||||
A LiteralSet is
|
||||
(make-literalset (listof (list symbol id phase-var-id)))
|
||||
|#
|
||||
(define-struct literalset (literals) #:transparent)
|
||||
|
||||
#|
|
||||
An EH-alternative-set is
|
||||
(eh-alternative-set (listof EH-alternative))
|
||||
An EH-alternative is
|
||||
(eh-alternative RepetitionConstraint (listof SAttr) id)
|
||||
|#
|
||||
(define-struct eh-alternative-set (alts))
|
||||
(define-struct eh-alternative (repc attrs parser))
|
||||
|
||||
(define-struct den:delayed (parser class))
|
||||
194
collects/syntax/parse/private/residual.rkt
Normal file
194
collects/syntax/parse/private/residual.rkt
Normal file
|
|
@ -0,0 +1,194 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/stxparam
|
||||
unstable/lazy-require)
|
||||
|
||||
;; ============================================================
|
||||
;; Compile-time
|
||||
|
||||
(require (for-syntax racket/private/sc
|
||||
syntax/parse/private/residual-ct))
|
||||
(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
|
||||
|
||||
(begin-for-syntax
|
||||
;; == from runtime.rkt
|
||||
|
||||
(provide make-attribute-mapping
|
||||
attribute-mapping?
|
||||
attribute-mapping-var
|
||||
attribute-mapping-name
|
||||
attribute-mapping-depth
|
||||
attribute-mapping-syntax?)
|
||||
|
||||
(define-struct attribute-mapping (var name depth syntax?)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure
|
||||
(lambda (self stx)
|
||||
(if (attribute-mapping-syntax? self)
|
||||
#`(#%expression #,(attribute-mapping-var self))
|
||||
(let ([source-name
|
||||
(or (let loop ([p (syntax-property stx 'disappeared-use)])
|
||||
(cond [(identifier? p) p]
|
||||
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
||||
[else #f]))
|
||||
(attribute-mapping-name self))])
|
||||
#`(let ([value #,(attribute-mapping-var self)])
|
||||
(check-attr-value-is-syntax '#,(attribute-mapping-depth self)
|
||||
value
|
||||
(quote-syntax #,source-name))
|
||||
value)))))
|
||||
)
|
||||
|
||||
;; ============================================================
|
||||
;; Run-time
|
||||
|
||||
(require "runtime-progress.rkt"
|
||||
syntax/stx)
|
||||
|
||||
(provide (all-from-out "runtime-progress.rkt")
|
||||
|
||||
this-syntax
|
||||
this-context-syntax
|
||||
attribute
|
||||
attribute-binding
|
||||
stx-list-take
|
||||
stx-list-drop/cx
|
||||
check-list^depth*
|
||||
check-literal*
|
||||
begin-for-syntax/once
|
||||
|
||||
name->too-few/once
|
||||
name->too-few
|
||||
name->too-many
|
||||
syntax-patterns-fail)
|
||||
|
||||
;; == from runtime.rkt
|
||||
|
||||
;; this-syntax
|
||||
;; Bound to syntax being matched inside of syntax class
|
||||
(define-syntax-parameter this-syntax
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
|
||||
|
||||
;; this-context-syntax
|
||||
;; Bound to (expression that extracts) context syntax (bottom frame in progress)
|
||||
(define-syntax-parameter this-context-syntax
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
|
||||
|
||||
(define-syntax (attribute stx)
|
||||
(syntax-case stx ()
|
||||
[(attribute name)
|
||||
(identifier? #'name)
|
||||
(let ([mapping (syntax-local-value #'name (lambda () #f))])
|
||||
(unless (syntax-pattern-variable? mapping)
|
||||
(raise-syntax-error #f "not bound as a pattern variable" stx #'name))
|
||||
(let ([var (syntax-mapping-valvar mapping)])
|
||||
(let ([attr (syntax-local-value var (lambda () #f))])
|
||||
(unless (attribute-mapping? attr)
|
||||
(raise-syntax-error #f "not bound as an attribute" stx #'name))
|
||||
(syntax-property (attribute-mapping-var attr)
|
||||
'disappeared-use
|
||||
#'name))))]))
|
||||
|
||||
;; (attribute-binding id)
|
||||
;; mostly for debugging/testing
|
||||
(define-syntax (attribute-binding stx)
|
||||
(syntax-case stx ()
|
||||
[(attribute-bound? name)
|
||||
(identifier? #'name)
|
||||
(let ([value (syntax-local-value #'name (lambda () #f))])
|
||||
(if (syntax-pattern-variable? value)
|
||||
(let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
|
||||
(if (attribute-mapping? value)
|
||||
#`(quote #,(make-attr (attribute-mapping-name value)
|
||||
(attribute-mapping-depth value)
|
||||
(attribute-mapping-syntax? value)))
|
||||
#'(quote #f)))
|
||||
#'(quote #f)))]))
|
||||
|
||||
;; stx-list-take : stxish nat -> syntax
|
||||
(define (stx-list-take stx n)
|
||||
(datum->syntax #f
|
||||
(let loop ([stx stx] [n n])
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons (stx-car stx)
|
||||
(loop (stx-cdr stx) (sub1 n)))))))
|
||||
|
||||
;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
|
||||
(define (stx-list-drop/cx x cx n)
|
||||
(let loop ([x x] [cx cx] [n n])
|
||||
(if (zero? n)
|
||||
(values x
|
||||
(if (syntax? x) x cx))
|
||||
(loop (stx-cdr x)
|
||||
(if (syntax? x) x cx)
|
||||
(sub1 n)))))
|
||||
|
||||
;; check-attr-value-is-syntax : nat any id -> boolean
|
||||
;; returns #t if value is a (listof^depth syntax)
|
||||
;; used by attribute-mapping code above
|
||||
(define (check-attr-value-is-syntax depth value source-id)
|
||||
(define (check-syntax depth value)
|
||||
(if (zero? depth)
|
||||
(syntax? value)
|
||||
(and (list? value)
|
||||
(for/and ([part (in-list value)])
|
||||
(check-syntax (sub1 depth) part)))))
|
||||
(unless (check-syntax depth value)
|
||||
(raise-syntax-error #f
|
||||
(format "attribute is bound to non-syntax value: ~e" value)
|
||||
source-id)))
|
||||
|
||||
;; check-list^depth* : symbol nat any -> list^depth
|
||||
(define (check-list^depth* aname n0 v0)
|
||||
(define (loop n v)
|
||||
(when (positive? n)
|
||||
(unless (list? v)
|
||||
(raise-type-error aname (format "lists nested ~s deep" n0) v))
|
||||
(for ([x (in-list v)]) (loop (sub1 n) x))))
|
||||
(loop n0 v0)
|
||||
v0)
|
||||
|
||||
;; check-literal* : id phase phase (listof phase) stx -> void
|
||||
(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
|
||||
(unless (or (memv (and used-phase (- used-phase mod-phase))
|
||||
ok-phases/ct-rel)
|
||||
(identifier-binding id used-phase))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
|
||||
used-phase
|
||||
(and used-phase (- used-phase mod-phase)))
|
||||
ctx id)))
|
||||
|
||||
;; (begin-for-syntax/once expr/phase1 ...)
|
||||
;; evaluates in pass 2 of module/intdefs expansion
|
||||
(define-syntax (begin-for-syntax/once stx)
|
||||
(syntax-case stx ()
|
||||
[(bfs/o e ...)
|
||||
(cond [(list? (syntax-local-context))
|
||||
#`(define-values ()
|
||||
(begin (begin-for-syntax/once e ...)
|
||||
(values)))]
|
||||
[else
|
||||
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
|
||||
(m))])]))
|
||||
|
||||
;; == parse.rkt
|
||||
|
||||
(define (name->too-few/once name)
|
||||
(and name (format "missing required occurrence of ~a" name)))
|
||||
|
||||
(define (name->too-few name)
|
||||
(and name (format "too few occurrences of ~a" name)))
|
||||
|
||||
(define (name->too-many name)
|
||||
(and name (format "too many occurrences of ~a" name)))
|
||||
|
||||
;; == parse.rkt
|
||||
|
||||
(lazy-require
|
||||
["runtime-report.rkt"
|
||||
(syntax-patterns-fail)])
|
||||
|
|
@ -1,194 +0,0 @@
|
|||
#lang racket/base
|
||||
(require "minimatch.rkt"
|
||||
"runtime-progress.rkt")
|
||||
(provide (struct-out failure)
|
||||
|
||||
expect?
|
||||
(struct-out expect:thing)
|
||||
(struct-out expect:atom)
|
||||
(struct-out expect:literal)
|
||||
(struct-out expect:message)
|
||||
(struct-out expect:disj)
|
||||
|
||||
normalize-expectstack
|
||||
simplify-common-expectstacks
|
||||
maximal-failures
|
||||
partition/equal?)
|
||||
|
||||
;; A Failure is (make-failure PS ExpectStack)
|
||||
;; A FailureSet is one of
|
||||
;; - Failure
|
||||
;; - (cons FailureSet FailureSet)
|
||||
|
||||
;; FailFunction = (FailureSet -> Answer)
|
||||
|
||||
(define-struct failure (progress expectstack) #:prefab)
|
||||
|
||||
;; == Expectations
|
||||
|
||||
;; FIXME: add phase to expect:literal
|
||||
|
||||
#|
|
||||
An ExpectStack is (listof Expect)
|
||||
|
||||
An Expect is one of
|
||||
- (make-expect:thing string boolean)
|
||||
* (make-expect:message string)
|
||||
* (make-expect:atom atom)
|
||||
* (make-expect:literal identifier)
|
||||
* (make-expect:disj (non-empty-listof Expect))
|
||||
|
||||
The *-marked variants can only occur at the top of the stack.
|
||||
|#
|
||||
(define-struct expect:thing (description transparent?) #:prefab)
|
||||
(define-struct expect:message (message) #:prefab)
|
||||
(define-struct expect:atom (atom) #:prefab)
|
||||
(define-struct expect:literal (literal) #:prefab)
|
||||
(define-struct expect:disj (expects) #:prefab)
|
||||
|
||||
(define (expect? x)
|
||||
(or (expect:thing? x)
|
||||
(expect:message? x)
|
||||
(expect:atom? x)
|
||||
(expect:literal? x)
|
||||
(expect:disj? x)))
|
||||
|
||||
|
||||
;; == Failure simplification ==
|
||||
|
||||
;; maximal-failures : FailureSet -> (listof (listof Failure))
|
||||
(define (maximal-failures fs)
|
||||
(define ann-failures
|
||||
(for/list ([f (in-list (flatten fs null))])
|
||||
(cons f (invert-ps (failure-progress f)))))
|
||||
(maximal/progress ann-failures))
|
||||
|
||||
(define (flatten fs onto)
|
||||
(cond [(pair? fs)
|
||||
(flatten (car fs) (flatten (cdr fs) onto))]
|
||||
[else
|
||||
(cons fs onto)]))
|
||||
|
||||
;; == Expectation simplification ==
|
||||
|
||||
;; normalize-expectstack : ExpectStack -> ExpectStack
|
||||
(define (normalize-expectstack es)
|
||||
(filter-expectstack (truncate-opaque-expectstack es)))
|
||||
|
||||
;; truncate-opaque-expectstack : ExpectStack -> ExpectStack
|
||||
;; Eliminates expectations on top of opaque (ie, transparent=#f) frames.
|
||||
(define (truncate-opaque-expectstack es)
|
||||
(let/ec return
|
||||
(let loop ([es es])
|
||||
(match es
|
||||
['() '()]
|
||||
[(cons (expect:thing description '#f) rest-es)
|
||||
;; Tricky! If multiple opaque frames, multiple "returns",
|
||||
;; but innermost one called first, so jumps past the rest.
|
||||
(return (cons (car es) (loop rest-es)))]
|
||||
[(cons expect rest-es)
|
||||
(cons expect (loop rest-es))]))))
|
||||
|
||||
;; filter-expectstack : ExpectStack -> ExpectStack
|
||||
;; Eliminates missing (ie, #f) messages and descriptions
|
||||
(define (filter-expectstack es)
|
||||
(filter (lambda (expect)
|
||||
(match expect
|
||||
[(expect:thing '#f _)
|
||||
#f]
|
||||
[(expect:message '#f)
|
||||
#f]
|
||||
[_ #t]))
|
||||
es))
|
||||
|
||||
#|
|
||||
Simplification dilemma
|
||||
|
||||
What if we have (e1 e2) and (e2)? How do we report that?
|
||||
Options:
|
||||
1) consider them separate
|
||||
2) simplify to (e2), drop e1
|
||||
|
||||
Big problem with Option 1:
|
||||
eg (x:id ...) matching #'1 yields
|
||||
(union (failure #:progress () #:expectstack ())
|
||||
(failure #:progress () #:expectstack (#s(expect:atom ()))))
|
||||
but we don't want to see "expected ()"
|
||||
|
||||
So we go with option 2.
|
||||
|#
|
||||
|
||||
;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack)
|
||||
;; Should call remove-duplicates first.
|
||||
(define (simplify-common-expectstacks ess)
|
||||
;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
|
||||
(define (simplify ress)
|
||||
(let ([ress-partitions (partition/car ress)])
|
||||
(if ress-partitions
|
||||
(apply append
|
||||
(for/list ([ress-partition (in-list ress-partitions)])
|
||||
(let ([proto-frame (car (car ress-partition))]
|
||||
[cdr-ress (map cdr ress-partition)])
|
||||
(map (lambda (res) (cons proto-frame res))
|
||||
(simplify/check-leafs cdr-ress)))))
|
||||
(list null))))
|
||||
;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
|
||||
(define (simplify/check-leafs ress)
|
||||
(let ([ress (simplify ress)])
|
||||
(cond [(andmap singleton? ress)
|
||||
(let* ([frames (map car ress)])
|
||||
(list (list (if (singleton? frames)
|
||||
(car frames)
|
||||
(expect:disj frames)))))]
|
||||
[else ress])))
|
||||
;; singleton? : list -> boolean
|
||||
(define (singleton? res)
|
||||
(and (pair? res) (null? (cdr res))))
|
||||
(map reverse (simplify/check-leafs (map reverse ess))))
|
||||
|
||||
;; partition/car : (listof list) -> (listof (listof list))/#f
|
||||
;; Returns #f if any of lists is empty.
|
||||
(define (partition/car lists)
|
||||
(and (andmap pair? lists)
|
||||
(partition/equal? lists car)))
|
||||
|
||||
(define (partition/equal? items key)
|
||||
(let ([r-keys null] ;; mutated
|
||||
[key-t (make-hash)])
|
||||
(for ([item (in-list items)])
|
||||
(let ([k (key item)])
|
||||
(let ([entry (hash-ref key-t k null)])
|
||||
(when (null? entry)
|
||||
(set! r-keys (cons k r-keys)))
|
||||
(hash-set! key-t k (cons item entry)))))
|
||||
(let loop ([r-keys r-keys] [acc null])
|
||||
(cond [(null? r-keys) acc]
|
||||
[else
|
||||
(loop (cdr r-keys)
|
||||
(cons (reverse (hash-ref key-t (car r-keys)))
|
||||
acc))]))))
|
||||
|
||||
;; ==== Debugging
|
||||
|
||||
(provide failureset->sexpr
|
||||
failure->sexpr
|
||||
expectstack->sexpr
|
||||
expect->sexpr)
|
||||
|
||||
(define (failureset->sexpr fs)
|
||||
(let ([fs (flatten fs null)])
|
||||
(case (length fs)
|
||||
((1) (failure->sexpr (car fs)))
|
||||
(else `(union ,@(map failure->sexpr fs))))))
|
||||
|
||||
(define (failure->sexpr f)
|
||||
(match f
|
||||
[(failure progress expectstack)
|
||||
`(failure ,(progress->sexpr progress)
|
||||
#:expected ,(expectstack->sexpr expectstack))]))
|
||||
|
||||
(define (expectstack->sexpr es)
|
||||
(map expect->sexpr es))
|
||||
|
||||
(define (expect->sexpr e)
|
||||
e)
|
||||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require unstable/struct
|
||||
(require racket/list
|
||||
unstable/struct
|
||||
syntax/stx
|
||||
"minimatch.rkt")
|
||||
(provide ps-empty
|
||||
|
|
@ -12,14 +13,18 @@
|
|||
ps-add-unpstruct
|
||||
ps-add-opaque
|
||||
|
||||
invert-ps
|
||||
ps->stx+index
|
||||
ps-context-syntax
|
||||
ps-difference
|
||||
|
||||
invert-ps
|
||||
maximal/progress
|
||||
|
||||
progress->sexpr)
|
||||
(struct-out failure)
|
||||
expect?
|
||||
(struct-out expect:thing)
|
||||
(struct-out expect:atom)
|
||||
(struct-out expect:literal)
|
||||
(struct-out expect:message)
|
||||
(struct-out expect:disj))
|
||||
|
||||
#|
|
||||
Progress (PS) is a non-empty list of Progress Frames (PF).
|
||||
|
|
@ -140,20 +145,6 @@ Interpretation: Inner PS structures are applied first.
|
|||
(loop (cdr ps))
|
||||
ps]))))
|
||||
|
||||
#|
|
||||
Progress ordering
|
||||
-----------------
|
||||
|
||||
Lexicographic generalization of partial order on frames
|
||||
CAR < CDR < POST, stx incomparable except to self
|
||||
|
||||
Progress equality
|
||||
-----------------
|
||||
|
||||
If ps1 = ps2 then both must "blame" the same term,
|
||||
ie (ps->stx+index ps1) = (ps->stx+index ps2).
|
||||
|#
|
||||
|
||||
;; An Inverted PS (IPS) is a PS inverted for easy comparison.
|
||||
;; An IPS may not contain any 'opaque frames.
|
||||
|
||||
|
|
@ -161,100 +152,72 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
|
|||
(define (invert-ps ps)
|
||||
(reverse (ps-truncate-opaque ps)))
|
||||
|
||||
;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A))
|
||||
;; Returns a list of equivalence sets.
|
||||
(define (maximal/progress items)
|
||||
(cond [(null? items)
|
||||
null]
|
||||
[(null? (cdr items))
|
||||
(list (list (car (car items))))]
|
||||
[else
|
||||
(let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR)
|
||||
(partition/pf items)])
|
||||
(append (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
|
||||
(if (pair? rSTX)
|
||||
(maximal/stx rSTX)
|
||||
null)))]))
|
||||
|
||||
;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0
|
||||
(define (partition/pf items)
|
||||
(let ([rNULL null]
|
||||
[rCAR null]
|
||||
[rCDR null]
|
||||
[rPOST null]
|
||||
[rSTX null]
|
||||
[leastCDR #f])
|
||||
(for ([a+ips (in-list items)])
|
||||
(let ([ips (cdr a+ips)])
|
||||
(cond [(null? ips)
|
||||
(set! rNULL (cons a+ips rNULL))]
|
||||
[(eq? (car ips) 'car)
|
||||
(set! rCAR (cons a+ips rCAR))]
|
||||
[(exact-positive-integer? (car ips))
|
||||
(set! rCDR (cons a+ips rCDR))
|
||||
(set! leastCDR
|
||||
(if leastCDR
|
||||
(min leastCDR (car ips))
|
||||
(car ips)))]
|
||||
[(eq? (car ips) 'post)
|
||||
(set! rPOST (cons a+ips rPOST))]
|
||||
[(syntax? (car ips))
|
||||
(set! rSTX (cons a+ips rSTX))]
|
||||
[else
|
||||
(error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)])))
|
||||
(values rNULL rCAR rCDR rPOST rSTX leastCDR)))
|
||||
;; ==== Failure ====
|
||||
|
||||
;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A))
|
||||
(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
|
||||
(cond [(pair? rPOST)
|
||||
(maximal/progress (rmap pop-item-ips rPOST))]
|
||||
[(pair? rCDR)
|
||||
(maximal/progress
|
||||
(rmap (lambda (a+ips)
|
||||
(let ([a (car a+ips)] [ips (cdr a+ips)])
|
||||
(cond [(= (car ips) leastCDR)
|
||||
(cons a (cdr ips))]
|
||||
[else
|
||||
(cons a (cons (- (car ips) leastCDR) (cdr ips)))])))
|
||||
rCDR))]
|
||||
[(pair? rCAR)
|
||||
(maximal/progress (rmap pop-item-ips rCAR))]
|
||||
[(pair? rNULL)
|
||||
(list (map car rNULL))]
|
||||
[else
|
||||
null]))
|
||||
;; A Failure is (make-failure PS ExpectStack)
|
||||
;; A FailureSet is one of
|
||||
;; - Failure
|
||||
;; - (cons FailureSet FailureSet)
|
||||
|
||||
;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A))
|
||||
(define (maximal/stx rSTX)
|
||||
(let ([stxs null]
|
||||
[table (make-hasheq)])
|
||||
(for ([a+ips (in-list rSTX)])
|
||||
(let* ([ips (cdr a+ips)]
|
||||
[entry (hash-ref table (car ips) null)])
|
||||
(when (null? entry)
|
||||
(set! stxs (cons (car ips) stxs)))
|
||||
(hash-set! table (car ips) (cons a+ips entry))))
|
||||
(apply append
|
||||
(map (lambda (key)
|
||||
(maximal/progress (map pop-item-ips (hash-ref table key))))
|
||||
stxs))))
|
||||
;; FailFunction = (FailureSet -> Answer)
|
||||
|
||||
;; pop-item-ips : (cons A IPS) -> (cons A IPS)
|
||||
(define (pop-item-ips a+ips)
|
||||
(let ([a (car a+ips)]
|
||||
[ips (cdr a+ips)])
|
||||
(cons a (cdr ips))))
|
||||
(define-struct failure (progress expectstack) #:prefab)
|
||||
|
||||
(define (rmap f xs)
|
||||
(let rmaploop ([xs xs] [accum null])
|
||||
(cond [(pair? xs)
|
||||
(rmaploop (cdr xs) (cons (f (car xs)) accum))]
|
||||
[else
|
||||
accum])))
|
||||
;; == Expectations
|
||||
|
||||
;; == Debugging ==
|
||||
;; FIXME: add phase to expect:literal
|
||||
|
||||
(provide progress->sexpr)
|
||||
#|
|
||||
An ExpectStack is (listof Expect)
|
||||
|
||||
An Expect is one of
|
||||
- (make-expect:thing string boolean)
|
||||
* (make-expect:message string)
|
||||
* (make-expect:atom atom)
|
||||
* (make-expect:literal identifier)
|
||||
* (make-expect:disj (non-empty-listof Expect))
|
||||
|
||||
The *-marked variants can only occur at the top of the stack.
|
||||
|#
|
||||
(define-struct expect:thing (description transparent?) #:prefab)
|
||||
(define-struct expect:message (message) #:prefab)
|
||||
(define-struct expect:atom (atom) #:prefab)
|
||||
(define-struct expect:literal (literal) #:prefab)
|
||||
(define-struct expect:disj (expects) #:prefab)
|
||||
|
||||
(define (expect? x)
|
||||
(or (expect:thing? x)
|
||||
(expect:message? x)
|
||||
(expect:atom? x)
|
||||
(expect:literal? x)
|
||||
(expect:disj? x)))
|
||||
|
||||
|
||||
;; ==== Debugging
|
||||
|
||||
(provide failureset->sexpr
|
||||
failure->sexpr
|
||||
expectstack->sexpr
|
||||
expect->sexpr)
|
||||
|
||||
(define (failureset->sexpr fs)
|
||||
(let ([fs (flatten fs null)])
|
||||
(case (length fs)
|
||||
((1) (failure->sexpr (car fs)))
|
||||
(else `(union ,@(map failure->sexpr fs))))))
|
||||
|
||||
(define (failure->sexpr f)
|
||||
(match f
|
||||
[(failure progress expectstack)
|
||||
`(failure ,(progress->sexpr progress)
|
||||
#:expected ,(expectstack->sexpr expectstack))]))
|
||||
|
||||
(define (expectstack->sexpr es)
|
||||
(map expect->sexpr es))
|
||||
|
||||
(define (expect->sexpr e)
|
||||
e)
|
||||
|
||||
(define (progress->sexpr ps)
|
||||
(for/list ([pf (in-list (invert-ps ps))])
|
||||
|
|
|
|||
|
|
@ -1,15 +1,12 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
"rep-data.rkt")
|
||||
"rep-attrs.rkt"
|
||||
(require syntax/parse/private/residual ;; keep abs. path
|
||||
(only-in syntax/parse/private/residual-ct ;; keep abs. path
|
||||
attr-name attr-depth)
|
||||
"kws.rkt")
|
||||
(provide (struct-out reified)
|
||||
(provide reflect-parser
|
||||
(struct-out reified)
|
||||
(struct-out reified-syntax-class)
|
||||
(struct-out reified-splicing-syntax-class)
|
||||
reify-syntax-class
|
||||
reified-syntax-class?
|
||||
reified-splicing-syntax-class?
|
||||
reflect-parser)
|
||||
(struct-out reified-splicing-syntax-class))
|
||||
|
||||
#|
|
||||
A Reified is
|
||||
|
|
@ -20,32 +17,8 @@ A Reified is
|
|||
(define-struct (reified-syntax-class reified) ())
|
||||
(define-struct (reified-splicing-syntax-class reified) ())
|
||||
|
||||
;; ----
|
||||
|
||||
(define-syntax (reify-syntax-class stx)
|
||||
(if (eq? (syntax-local-context) 'expression)
|
||||
(syntax-case stx ()
|
||||
[(rsc sc)
|
||||
(let* ([stxclass (get-stxclass #'sc)]
|
||||
[splicing? (stxclass-splicing? stxclass)])
|
||||
(unless (stxclass-delimit-cut? stxclass)
|
||||
(raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
|
||||
stx #'sc))
|
||||
(with-syntax ([name (stxclass-name stxclass)]
|
||||
[parser (stxclass-parser stxclass)]
|
||||
[arity (stxclass-arity stxclass)]
|
||||
[(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
|
||||
[ctor
|
||||
(if splicing?
|
||||
#'reified-splicing-syntax-class
|
||||
#'reified-syntax-class)])
|
||||
#'(ctor 'name parser 'arity '((aname adepth) ...))))])
|
||||
#`(#%expression #,stx)))
|
||||
|
||||
;; ----
|
||||
|
||||
;; e-arity represents single call; min and max are same
|
||||
(define (reflect-parser obj e-arity e-attrs splicing?)
|
||||
;; e-arity represents single call; min and max are same
|
||||
(define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
|
||||
(if splicing?
|
||||
(unless (reified-splicing-syntax-class? obj)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,17 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
"minimatch.rkt"
|
||||
"runtime.rkt"
|
||||
(except-in syntax/parse/private/residual
|
||||
syntax-patterns-fail)
|
||||
"kws.rkt")
|
||||
(provide syntax-patterns-fail
|
||||
current-failure-handler)
|
||||
|
||||
#|
|
||||
Note: there is a cyclic dependence between residual.rkt and this module,
|
||||
broken by a lazy-require of this module into residual.rkt
|
||||
|#
|
||||
|
||||
(define ((syntax-patterns-fail stx0) fs)
|
||||
(call-with-values (lambda () ((current-failure-handler) stx0 fs))
|
||||
(lambda vals
|
||||
|
|
@ -21,8 +27,6 @@
|
|||
(define current-failure-handler
|
||||
(make-parameter default-failure-handler))
|
||||
|
||||
;; ----
|
||||
|
||||
#|
|
||||
Reporting
|
||||
---------
|
||||
|
|
@ -125,3 +129,223 @@ complicated.
|
|||
[(a . b) (cons #'a (improper-stx->list #'b))]
|
||||
[() null]
|
||||
[rest (list #'rest)]))
|
||||
|
||||
|
||||
;; ==== Failure analysis ====
|
||||
|
||||
|
||||
;; == Failure simplification ==
|
||||
|
||||
;; maximal-failures : FailureSet -> (listof (listof Failure))
|
||||
(define (maximal-failures fs)
|
||||
(define ann-failures
|
||||
(for/list ([f (in-list (flatten fs))])
|
||||
(cons f (invert-ps (failure-progress f)))))
|
||||
(maximal/progress ann-failures))
|
||||
|
||||
;; == Expectation simplification ==
|
||||
|
||||
;; normalize-expectstack : ExpectStack -> ExpectStack
|
||||
(define (normalize-expectstack es)
|
||||
(filter-expectstack (truncate-opaque-expectstack es)))
|
||||
|
||||
;; truncate-opaque-expectstack : ExpectStack -> ExpectStack
|
||||
;; Eliminates expectations on top of opaque (ie, transparent=#f) frames.
|
||||
(define (truncate-opaque-expectstack es)
|
||||
(let/ec return
|
||||
(let loop ([es es])
|
||||
(match es
|
||||
['() '()]
|
||||
[(cons (expect:thing description '#f) rest-es)
|
||||
;; Tricky! If multiple opaque frames, multiple "returns",
|
||||
;; but innermost one called first, so jumps past the rest.
|
||||
(return (cons (car es) (loop rest-es)))]
|
||||
[(cons expect rest-es)
|
||||
(cons expect (loop rest-es))]))))
|
||||
|
||||
;; filter-expectstack : ExpectStack -> ExpectStack
|
||||
;; Eliminates missing (ie, #f) messages and descriptions
|
||||
(define (filter-expectstack es)
|
||||
(filter (lambda (expect)
|
||||
(match expect
|
||||
[(expect:thing '#f _)
|
||||
#f]
|
||||
[(expect:message '#f)
|
||||
#f]
|
||||
[_ #t]))
|
||||
es))
|
||||
|
||||
#|
|
||||
Simplification dilemma
|
||||
|
||||
What if we have (e1 e2) and (e2)? How do we report that?
|
||||
Options:
|
||||
1) consider them separate
|
||||
2) simplify to (e2), drop e1
|
||||
|
||||
Big problem with Option 1:
|
||||
eg (x:id ...) matching #'1 yields
|
||||
(union (failure #:progress () #:expectstack ())
|
||||
(failure #:progress () #:expectstack (#s(expect:atom ()))))
|
||||
but we don't want to see "expected ()"
|
||||
|
||||
So we go with option 2.
|
||||
|#
|
||||
|
||||
;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack)
|
||||
;; Should call remove-duplicates first.
|
||||
(define (simplify-common-expectstacks ess)
|
||||
;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
|
||||
(define (simplify ress)
|
||||
(let ([ress-partitions (partition/car ress)])
|
||||
(if ress-partitions
|
||||
(apply append
|
||||
(for/list ([ress-partition (in-list ress-partitions)])
|
||||
(let ([proto-frame (car (car ress-partition))]
|
||||
[cdr-ress (map cdr ress-partition)])
|
||||
(map (lambda (res) (cons proto-frame res))
|
||||
(simplify/check-leafs cdr-ress)))))
|
||||
(list null))))
|
||||
;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack)
|
||||
(define (simplify/check-leafs ress)
|
||||
(let ([ress (simplify ress)])
|
||||
(cond [(andmap singleton? ress)
|
||||
(let* ([frames (map car ress)])
|
||||
(list (list (if (singleton? frames)
|
||||
(car frames)
|
||||
(expect:disj frames)))))]
|
||||
[else ress])))
|
||||
;; singleton? : list -> boolean
|
||||
(define (singleton? res)
|
||||
(and (pair? res) (null? (cdr res))))
|
||||
(map reverse (simplify/check-leafs (map reverse ess))))
|
||||
|
||||
;; partition/car : (listof list) -> (listof (listof list))/#f
|
||||
;; Returns #f if any of lists is empty.
|
||||
(define (partition/car lists)
|
||||
(and (andmap pair? lists)
|
||||
(partition/equal? lists car)))
|
||||
|
||||
(define (partition/equal? items key)
|
||||
(let ([r-keys null] ;; mutated
|
||||
[key-t (make-hash)])
|
||||
(for ([item (in-list items)])
|
||||
(let ([k (key item)])
|
||||
(let ([entry (hash-ref key-t k null)])
|
||||
(when (null? entry)
|
||||
(set! r-keys (cons k r-keys)))
|
||||
(hash-set! key-t k (cons item entry)))))
|
||||
(let loop ([r-keys r-keys] [acc null])
|
||||
(cond [(null? r-keys) acc]
|
||||
[else
|
||||
(loop (cdr r-keys)
|
||||
(cons (reverse (hash-ref key-t (car r-keys)))
|
||||
acc))]))))
|
||||
|
||||
|
||||
;; ==== Progress
|
||||
|
||||
#|
|
||||
Progress ordering
|
||||
-----------------
|
||||
|
||||
Lexicographic generalization of partial order on frames
|
||||
CAR < CDR < POST, stx incomparable except to self
|
||||
|
||||
Progress equality
|
||||
-----------------
|
||||
|
||||
If ps1 = ps2 then both must "blame" the same term,
|
||||
ie (ps->stx+index ps1) = (ps->stx+index ps2).
|
||||
|#
|
||||
|
||||
;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A))
|
||||
;; Returns a list of equivalence sets.
|
||||
(define (maximal/progress items)
|
||||
(cond [(null? items)
|
||||
null]
|
||||
[(null? (cdr items))
|
||||
(list (list (car (car items))))]
|
||||
[else
|
||||
(let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR)
|
||||
(partition/pf items)])
|
||||
(append (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
|
||||
(if (pair? rSTX)
|
||||
(maximal/stx rSTX)
|
||||
null)))]))
|
||||
|
||||
;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0
|
||||
(define (partition/pf items)
|
||||
(let ([rNULL null]
|
||||
[rCAR null]
|
||||
[rCDR null]
|
||||
[rPOST null]
|
||||
[rSTX null]
|
||||
[leastCDR #f])
|
||||
(for ([a+ips (in-list items)])
|
||||
(let ([ips (cdr a+ips)])
|
||||
(cond [(null? ips)
|
||||
(set! rNULL (cons a+ips rNULL))]
|
||||
[(eq? (car ips) 'car)
|
||||
(set! rCAR (cons a+ips rCAR))]
|
||||
[(exact-positive-integer? (car ips))
|
||||
(set! rCDR (cons a+ips rCDR))
|
||||
(set! leastCDR
|
||||
(if leastCDR
|
||||
(min leastCDR (car ips))
|
||||
(car ips)))]
|
||||
[(eq? (car ips) 'post)
|
||||
(set! rPOST (cons a+ips rPOST))]
|
||||
[(syntax? (car ips))
|
||||
(set! rSTX (cons a+ips rSTX))]
|
||||
[else
|
||||
(error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)])))
|
||||
(values rNULL rCAR rCDR rPOST rSTX leastCDR)))
|
||||
|
||||
;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A))
|
||||
(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR)
|
||||
(cond [(pair? rPOST)
|
||||
(maximal/progress (rmap pop-item-ips rPOST))]
|
||||
[(pair? rCDR)
|
||||
(maximal/progress
|
||||
(rmap (lambda (a+ips)
|
||||
(let ([a (car a+ips)] [ips (cdr a+ips)])
|
||||
(cond [(= (car ips) leastCDR)
|
||||
(cons a (cdr ips))]
|
||||
[else
|
||||
(cons a (cons (- (car ips) leastCDR) (cdr ips)))])))
|
||||
rCDR))]
|
||||
[(pair? rCAR)
|
||||
(maximal/progress (rmap pop-item-ips rCAR))]
|
||||
[(pair? rNULL)
|
||||
(list (map car rNULL))]
|
||||
[else
|
||||
null]))
|
||||
|
||||
;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A))
|
||||
(define (maximal/stx rSTX)
|
||||
(let ([stxs null]
|
||||
[table (make-hasheq)])
|
||||
(for ([a+ips (in-list rSTX)])
|
||||
(let* ([ips (cdr a+ips)]
|
||||
[entry (hash-ref table (car ips) null)])
|
||||
(when (null? entry)
|
||||
(set! stxs (cons (car ips) stxs)))
|
||||
(hash-set! table (car ips) (cons a+ips entry))))
|
||||
(apply append
|
||||
(map (lambda (key)
|
||||
(maximal/progress (map pop-item-ips (hash-ref table key))))
|
||||
stxs))))
|
||||
|
||||
;; pop-item-ips : (cons A IPS) -> (cons A IPS)
|
||||
(define (pop-item-ips a+ips)
|
||||
(let ([a (car a+ips)]
|
||||
[ips (cdr a+ips)])
|
||||
(cons a (cdr ips))))
|
||||
|
||||
(define (rmap f xs)
|
||||
(let rmaploop ([xs xs] [accum null])
|
||||
(cond [(pair? xs)
|
||||
(rmaploop (cdr xs) (cons (f (car xs)) accum))]
|
||||
[else
|
||||
accum])))
|
||||
|
|
|
|||
|
|
@ -1,51 +1,46 @@
|
|||
#lang racket/base
|
||||
(require racket/stxparam
|
||||
unstable/syntax
|
||||
"runtime-progress.rkt"
|
||||
"runtime-failure.rkt"
|
||||
syntax/parse/private/residual ;; keep abs. path
|
||||
(for-syntax racket/base
|
||||
racket/list
|
||||
syntax/kerncase
|
||||
racket/private/sc
|
||||
racket/syntax
|
||||
"rep-data.rkt"
|
||||
"rep-attrs.rkt"))
|
||||
"rep-attrs.rkt"
|
||||
"rep-data.rkt"))
|
||||
|
||||
(provide (all-from-out "runtime-progress.rkt")
|
||||
(all-from-out "runtime-failure.rkt")
|
||||
(provide with
|
||||
fail-handler
|
||||
cut-prompt
|
||||
wrap-user-code
|
||||
|
||||
this-syntax
|
||||
this-context-syntax
|
||||
|
||||
stx-list-take
|
||||
stx-list-drop/cx
|
||||
fail
|
||||
try
|
||||
|
||||
let-attributes
|
||||
let-attributes*
|
||||
let/unpack
|
||||
|
||||
defattrs/unpack
|
||||
attribute
|
||||
attribute-binding
|
||||
check-list^depth)
|
||||
check-list^depth
|
||||
|
||||
;; == Syntax Parameters
|
||||
check-literal
|
||||
no-shadow
|
||||
curried-stxclass-parser
|
||||
app-argu)
|
||||
|
||||
;; this-syntax
|
||||
;; Bound to syntax being matched inside of syntax class
|
||||
(define-syntax-parameter this-syntax
|
||||
(lambda (stx)
|
||||
(wrong-syntax stx "used out of context: not within a syntax class")))
|
||||
#|
|
||||
TODO: rename file
|
||||
|
||||
;; this-context-syntax
|
||||
;; Bound to (expression that extracts) context syntax (bottom frame in progress)
|
||||
(define-syntax-parameter this-context-syntax
|
||||
(lambda (stx)
|
||||
(wrong-syntax stx "used out of context: not within a syntax class")))
|
||||
This file contains "runtime" (ie, phase 0) auxiliary *macros* used in
|
||||
expansion of syntax-parse etc. This file must not contain any
|
||||
reference that persists in a compiled program; those must go in
|
||||
residual.rkt.
|
||||
|#
|
||||
|
||||
;; == with ==
|
||||
|
||||
(provide with)
|
||||
|
||||
(define-syntax (with stx)
|
||||
(syntax-case stx ()
|
||||
[(with ([stxparam expr] ...) . body)
|
||||
|
|
@ -58,13 +53,6 @@
|
|||
|
||||
;; == Control information ==
|
||||
|
||||
(provide fail-handler
|
||||
cut-prompt
|
||||
wrap-user-code
|
||||
|
||||
fail
|
||||
try)
|
||||
|
||||
(define-syntax-parameter fail-handler
|
||||
(lambda (stx)
|
||||
(wrong-syntax stx "internal error: used out of context")))
|
||||
|
|
@ -96,57 +84,8 @@
|
|||
(with ([fail-handler last-fh])
|
||||
e0)))))]))
|
||||
|
||||
;; -----
|
||||
|
||||
(require syntax/stx)
|
||||
(define (stx-list-take stx n)
|
||||
(datum->syntax #f
|
||||
(let loop ([stx stx] [n n])
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons (stx-car stx)
|
||||
(loop (stx-cdr stx) (sub1 n)))))))
|
||||
|
||||
;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
|
||||
(define (stx-list-drop/cx x cx n)
|
||||
(let loop ([x x] [cx cx] [n n])
|
||||
(if (zero? n)
|
||||
(values x
|
||||
(if (syntax? x) x cx))
|
||||
(loop (stx-cdr x)
|
||||
(if (syntax? x) x cx)
|
||||
(sub1 n)))))
|
||||
|
||||
;; == Attributes
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct attribute-mapping (var name depth syntax?)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure
|
||||
(lambda (self stx)
|
||||
(if (attribute-mapping-syntax? self)
|
||||
#`(#%expression #,(attribute-mapping-var self))
|
||||
#`(let ([value #,(attribute-mapping-var self)])
|
||||
(if (check-syntax '#,(attribute-mapping-depth self) value)
|
||||
value
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "attribute is bound to non-syntax value: ~e" value)
|
||||
(quote-syntax #,(or (let loop ([p (syntax-property stx 'disappeared-use)])
|
||||
(cond [(identifier? p) p]
|
||||
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
|
||||
[else #f]))
|
||||
(attribute-mapping-name self))))))))))
|
||||
|
||||
;; check-syntax : nat any -> boolean
|
||||
;; Returns #t if value is a (listof^depth syntax)
|
||||
(define (check-syntax depth value)
|
||||
(if (zero? depth)
|
||||
(syntax? value)
|
||||
(and (list? value)
|
||||
(for/and ([part (in-list value)])
|
||||
(check-syntax (sub1 depth) part)))))
|
||||
|
||||
(define-for-syntax (parse-attr x)
|
||||
(syntax-case x ()
|
||||
[#s(attr name depth syntax?) #'(name depth syntax?)]))
|
||||
|
|
@ -202,38 +141,6 @@
|
|||
(define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
|
||||
...)))]))
|
||||
|
||||
(define-syntax (attribute stx)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(attribute name)
|
||||
(identifier? #'name)
|
||||
(let ([mapping (syntax-local-value #'name (lambda () #f))])
|
||||
(unless (syntax-pattern-variable? mapping)
|
||||
(wrong-syntax #'name "not bound as a pattern variable"))
|
||||
(let ([var (syntax-mapping-valvar mapping)])
|
||||
(let ([attr (syntax-local-value var (lambda () #f))])
|
||||
(unless (attribute-mapping? attr)
|
||||
(wrong-syntax #'name "not bound as an attribute"))
|
||||
(syntax-property (attribute-mapping-var attr)
|
||||
'disappeared-use
|
||||
#'name))))])))
|
||||
|
||||
;; (attribute-binding id)
|
||||
;; mostly for debugging/testing
|
||||
(define-syntax (attribute-binding stx)
|
||||
(syntax-case stx ()
|
||||
[(attribute-bound? name)
|
||||
(identifier? #'name)
|
||||
(let ([value (syntax-local-value #'name (lambda () #f))])
|
||||
(if (syntax-pattern-variable? value)
|
||||
(let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
|
||||
(if (attribute-mapping? value)
|
||||
#`(quote #,(make-attr (attribute-mapping-name value)
|
||||
(attribute-mapping-depth value)
|
||||
(attribute-mapping-syntax? value)))
|
||||
#'(quote #f)))
|
||||
#'(quote #f)))]))
|
||||
|
||||
;; (check-list^depth attr expr)
|
||||
(define-syntax (check-list^depth stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -242,20 +149,6 @@
|
|||
(quasisyntax/loc #'expr
|
||||
(check-list^depth* 'name 'depth expr)))]))
|
||||
|
||||
(define (check-list^depth* aname n0 v0)
|
||||
(define (loop n v)
|
||||
(when (positive? n)
|
||||
(unless (list? v)
|
||||
(raise-type-error aname (format "lists nested ~s deep" n0) v))
|
||||
(for ([x (in-list v)]) (loop (sub1 n) x))))
|
||||
(loop n0 v0)
|
||||
v0)
|
||||
|
||||
|
||||
;; ====
|
||||
|
||||
(provide check-literal)
|
||||
|
||||
;; (check-literal id phase-level-expr ctx) -> void
|
||||
(define-syntax (check-literal stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -274,38 +167,8 @@
|
|||
'ok-phases/ct-rel
|
||||
(quote-syntax ctx))))]))
|
||||
|
||||
(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
|
||||
(unless (or (memv (and used-phase (- used-phase mod-phase))
|
||||
ok-phases/ct-rel)
|
||||
(identifier-binding id used-phase))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
|
||||
used-phase
|
||||
(and used-phase (- used-phase mod-phase)))
|
||||
ctx id)))
|
||||
|
||||
;; ----
|
||||
|
||||
(provide begin-for-syntax/once)
|
||||
|
||||
;; (begin-for-syntax/once expr/phase1 ...)
|
||||
;; evaluates in pass 2 of module/intdefs expansion
|
||||
(define-syntax (begin-for-syntax/once stx)
|
||||
(syntax-case stx ()
|
||||
[(bfs/o e ...)
|
||||
(cond [(list? (syntax-local-context))
|
||||
#`(define-values ()
|
||||
(begin (begin-for-syntax/once e ...)
|
||||
(values)))]
|
||||
[else
|
||||
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
|
||||
(m))])]))
|
||||
|
||||
;; ====
|
||||
|
||||
(provide no-shadow)
|
||||
|
||||
(begin-for-syntax
|
||||
(define (check-shadow def)
|
||||
(syntax-case def ()
|
||||
|
|
@ -336,11 +199,6 @@
|
|||
[_
|
||||
ee]))]))
|
||||
|
||||
;; ----
|
||||
|
||||
(provide curried-stxclass-parser
|
||||
app-argu)
|
||||
|
||||
(define-syntax (curried-stxclass-parser stx)
|
||||
(syntax-case stx ()
|
||||
[(_ class argu)
|
||||
|
|
|
|||
|
|
@ -1,177 +1,64 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/syntax
|
||||
"rep-data.rkt"
|
||||
"rep.rkt")
|
||||
racket/syntax
|
||||
"parse.rkt"
|
||||
"keywords.rkt"
|
||||
"runtime.rkt"
|
||||
"runtime-report.rkt")
|
||||
unstable/lazy-require)
|
||||
"keywords.rkt")
|
||||
|
||||
;; keep and keep as abs. path -- lazy-loaded macros produce references to this
|
||||
;; must be required via *absolute module path* from any disappearing module
|
||||
;; (so for consistency etc, require absolutely from all modules)
|
||||
(require syntax/parse/private/residual)
|
||||
|
||||
(begin-for-syntax
|
||||
(lazy-require
|
||||
;; load macro transformers lazily via identifier
|
||||
;; This module path must also be absolute (not sure why,
|
||||
;; but it definitely breaks on relative module path).
|
||||
[syntax/parse/private/parse-aux
|
||||
(id:define-syntax-class
|
||||
id:define-splicing-syntax-class
|
||||
id:syntax-parse
|
||||
id:syntax-parser
|
||||
id:define/syntax-parse
|
||||
id:syntax-parser/template
|
||||
id:parser/rhs
|
||||
id:define-eh-alternative-set)]))
|
||||
|
||||
(provide define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
define/syntax-parse
|
||||
|
||||
(except-out (all-from-out "keywords.rkt")
|
||||
~reflect
|
||||
~splicing-reflect
|
||||
~eh-var)
|
||||
|
||||
attribute
|
||||
this-syntax
|
||||
|
||||
define/syntax-parse
|
||||
|
||||
;;----
|
||||
syntax-parser/template
|
||||
parser/rhs)
|
||||
parser/rhs
|
||||
define-eh-alternative-set)
|
||||
|
||||
(begin-for-syntax
|
||||
(define (defstxclass stx header rhss splicing?)
|
||||
(parameterize ((current-syntax-context stx))
|
||||
(let-values ([(name formals arity)
|
||||
(let ([p (check-stxclass-header header stx)])
|
||||
(values (car p) (cadr p) (caddr p)))])
|
||||
(let* ([the-rhs (parse-rhs rhss #f splicing? #:context stx)]
|
||||
[opt-rhs+def
|
||||
(and (andmap identifier? (syntax->list formals))
|
||||
(optimize-rhs the-rhs (syntax->list formals)))]
|
||||
[the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
|
||||
(with-syntax ([name name]
|
||||
[formals formals]
|
||||
[rhss rhss]
|
||||
[parser (generate-temporary (format-symbol "parse-~a" name))]
|
||||
[arity arity]
|
||||
[attrs (rhs-attrs the-rhs)]
|
||||
[(opt-def ...)
|
||||
(if opt-rhs+def
|
||||
(list (cadr opt-rhs+def))
|
||||
'())]
|
||||
[options (rhs-options the-rhs)]
|
||||
[integrate-expr
|
||||
(syntax-case (rhs-integrate the-rhs) ()
|
||||
[#s(integrate predicate description)
|
||||
#'(integrate (quote-syntax predicate)
|
||||
'description)]
|
||||
[#f
|
||||
#''#f])])
|
||||
#`(begin (define-syntax name
|
||||
(stxclass 'name 'arity
|
||||
'attrs
|
||||
(quote-syntax parser)
|
||||
'#,splicing?
|
||||
options
|
||||
integrate-expr))
|
||||
opt-def ...
|
||||
(define-values (parser)
|
||||
;; If opt-rhs, do not reparse:
|
||||
;; need to keep same generated predicate name
|
||||
#,(if opt-rhs+def
|
||||
(begin
|
||||
;; (printf "Integrable syntax class: ~s\n" (syntax->datum #'name))
|
||||
#`(parser/rhs/parsed
|
||||
name formals attrs #,the-rhs
|
||||
#,(and (rhs-description the-rhs) #t)
|
||||
#,splicing? #,stx))
|
||||
#`(parser/rhs
|
||||
name formals attrs rhss #,splicing? #,stx))))))))))
|
||||
|
||||
(define-syntax (define-syntax-class stx)
|
||||
(define-syntaxes (define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
define/syntax-parse
|
||||
syntax-parser/template
|
||||
parser/rhs
|
||||
define-eh-alternative-set)
|
||||
(let ([tx (lambda (get-id)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(dsc header . rhss)
|
||||
(defstxclass stx #'header #'rhss #f)]))
|
||||
|
||||
(define-syntax (define-splicing-syntax-class stx)
|
||||
(syntax-case stx ()
|
||||
[(dssc header . rhss)
|
||||
(defstxclass stx #'header #'rhss #t)]))
|
||||
|
||||
;; ----
|
||||
|
||||
(define-syntax (parser/rhs stx)
|
||||
(syntax-case stx ()
|
||||
[(parser/rhs name formals attrs rhss splicing? ctx)
|
||||
(with-disappeared-uses
|
||||
(let ([rhs
|
||||
(parameterize ((current-syntax-context #'ctx))
|
||||
(parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?)
|
||||
#:context #'ctx))])
|
||||
#`(parser/rhs/parsed name formals attrs
|
||||
#,rhs #,(and (rhs-description rhs) #t)
|
||||
splicing? ctx)))]))
|
||||
|
||||
(define-syntax (parser/rhs/parsed stx)
|
||||
(syntax-case stx ()
|
||||
[(prp name formals attrs rhs rhs-has-description? splicing? ctx)
|
||||
#`(let ([get-description
|
||||
(lambda formals
|
||||
(if 'rhs-has-description?
|
||||
#,(rhs-description (syntax-e #'rhs))
|
||||
(symbol->string 'name)))])
|
||||
(parse:rhs rhs attrs formals splicing?
|
||||
(if 'rhs-has-description?
|
||||
#,(rhs-description (syntax-e #'rhs))
|
||||
(symbol->string 'name))))]))
|
||||
|
||||
;; ====
|
||||
|
||||
(define-syntax (syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parse stx-expr . clauses)
|
||||
(quasisyntax/loc stx
|
||||
(let ([x (datum->syntax #f stx-expr)])
|
||||
(parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))]))
|
||||
|
||||
(define-syntax (syntax-parser stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parser . clauses)
|
||||
(quasisyntax/loc stx
|
||||
(lambda (x)
|
||||
(let ([x (datum->syntax #f x)])
|
||||
(parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))]))
|
||||
|
||||
(define-syntax (syntax-parser/template stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parser/template ctx . clauses)
|
||||
(quasisyntax/loc stx
|
||||
(lambda (x)
|
||||
(let ([x (datum->syntax #f x)])
|
||||
(parse:clauses x clauses one-template ctx))))]))
|
||||
|
||||
;; ====
|
||||
|
||||
(define-syntax (define/syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
[(define/syntax-parse pattern . rest)
|
||||
(let-values ([(rest pattern defs)
|
||||
(parse-pattern+sides #'pattern
|
||||
#'rest
|
||||
#:splicing? #f
|
||||
#:decls (new-declenv null)
|
||||
#:context stx)])
|
||||
(let ([expr
|
||||
(syntax-case rest ()
|
||||
[( expr ) #'expr]
|
||||
[_ (raise-syntax-error #f "bad syntax" stx)])]
|
||||
[attrs (pattern-attrs pattern)])
|
||||
(with-syntax ([(a ...) attrs]
|
||||
[(#s(attr name _ _) ...) attrs]
|
||||
[pattern pattern]
|
||||
[(def ...) defs]
|
||||
[expr expr])
|
||||
#'(defattrs/unpack (a ...)
|
||||
(let* ([x (datum->syntax #f expr)]
|
||||
[cx x]
|
||||
[pr (ps-empty x x)]
|
||||
[es null]
|
||||
[fh0 (syntax-patterns-fail x)])
|
||||
(parameterize ((current-syntax-context x))
|
||||
def ...
|
||||
(#%expression
|
||||
(with ([fail-handler fh0]
|
||||
[cut-prompt fh0])
|
||||
(parse:S x cx pattern pr es
|
||||
(list (attribute name) ...))))))))))]))
|
||||
[(_ . args)
|
||||
(datum->syntax stx (cons (get-id) #'args) stx)])))])
|
||||
(values
|
||||
(tx id:define-syntax-class)
|
||||
(tx id:define-splicing-syntax-class)
|
||||
(tx id:syntax-parse)
|
||||
(tx id:syntax-parser)
|
||||
(tx id:define/syntax-parse)
|
||||
(tx id:syntax-parser/template)
|
||||
(tx id:parser/rhs)
|
||||
(tx id:define-eh-alternative-set))))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
syntax/parse
|
||||
syntax/parse/private/rep-attrs
|
||||
(only-in syntax/parse/private/runtime attribute-binding)
|
||||
(only-in syntax/parse/private/residual
|
||||
attribute-binding)
|
||||
syntax/parse/private/residual-ct ;; for attr functions
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide tok
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
(require (for-syntax racket/base)
|
||||
racket/runtime-path
|
||||
racket/promise)
|
||||
(provide lazy-require
|
||||
(for-syntax #%datum))
|
||||
(provide lazy-require)
|
||||
|
||||
(define-syntax (lazy-require stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -20,7 +19,9 @@
|
|||
(unless (identifier? name)
|
||||
(raise-syntax-error #f "expected identifier" #'orig-stx name))
|
||||
#`(define #,name (make-lazy-function '#,name get-sym)))])
|
||||
#'(begin (define-runtime-module-path-index mpi-var modpath)
|
||||
;; implicit quasiquote, so can use normal module-path syntax'
|
||||
;; or escape to compute a the module-path via expression
|
||||
#'(begin (define-runtime-module-path-index mpi-var (quasiquote modpath))
|
||||
(define (get-sym sym)
|
||||
(parameterize ((current-namespace (namespace-anchor->namespace anchor)))
|
||||
(dynamic-require mpi-var sym)))
|
||||
|
|
|
|||
|
|
@ -11,14 +11,20 @@
|
|||
|
||||
@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]]
|
||||
|
||||
@defform[(lazy-require [mod-expr (imported-fun-id ...)] ...)
|
||||
#:contracts ([mod-expr module-path?])]{
|
||||
@defform/subs[#:literals (unquote)
|
||||
(lazy-require [mod (imported-fun-id ...)] ...)
|
||||
([mod module-path
|
||||
(unquote module-path-expr)])
|
||||
#:contracts ([module-path-expr module-path?])]{
|
||||
|
||||
Defines each @racket[imported-fun-id] as a function that, when called,
|
||||
dynamically requires the export named @racket['imported-fun-id] from
|
||||
the module specified by @racket[mod-expr] and calls it with the same
|
||||
the module specified by @racket[mod] and calls it with the same
|
||||
arguments.
|
||||
|
||||
As with @racket[define-runtime-module-path-index], @racket[mod-expr]
|
||||
The module @racket[mod] can be specified as a @racket[_module-path]
|
||||
(see @racket[require]) or as an @racket[unquote]-escaped expression
|
||||
that computes a module path. As with
|
||||
@racket[define-runtime-module-path-index], a @racket[module-path-expr]
|
||||
is evaluated both in phase 0 and phase 1.
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user