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

syntax/parse: lazily load most macro transformers and compile-time support

Browse Source
This commit is contained in:
Ryan Culpepper 2011-09-27 02:03:23 -06:00
parent 3441d0f7d0
commit 1c6b8bd68e
25 changed files with 966 additions and 834 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/syntax/parse/debug.rkt
View File

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

2
collects/syntax/parse/experimental/contract.rkt
View File

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

76
collects/syntax/parse/experimental/eh.rkt
View File

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

30
collects/syntax/parse/experimental/reflect.rkt
View File

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

11
collects/syntax/parse/experimental/splicing.rkt
View File

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

7
collects/syntax/parse/private/keywords.rkt
View File

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

8
collects/syntax/parse/private/lib.rkt
View File

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

18
collects/syntax/parse/private/litconv.rkt
View File

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

235
collects/syntax/parse/private/parse.rkt
View File

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

6
collects/syntax/parse/private/rep-attrs.rkt
View File

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

60
collects/syntax/parse/private/rep-data.rkt
View File

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

3
collects/syntax/parse/private/rep-patterns.rkt
View File

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

10
collects/syntax/parse/private/rep.rkt
View File

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

194
collects/syntax/parse/private/runtime-failure.rkt
View File

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

175
collects/syntax/parse/private/runtime-progress.rkt
View File

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

41
collects/syntax/parse/private/runtime-reflect.rkt
View File

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

230
collects/syntax/parse/private/runtime-report.rkt
View File

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

186
collects/syntax/parse/private/runtime.rkt
View File

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

207
collects/syntax/parse/private/sc.rkt
View File

@ -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)
(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) ...))))))))))]))
(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 ()
[(_ . 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))))

5
collects/tests/stxparse/setup.rkt
View File

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

7
collects/unstable/lazy-require.rkt
View File

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

16
collects/unstable/scribblings/lazy-require.scrbl
View File

@ -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.
}