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

Included upstream changes until a2ab778ddbb86f4ff890f3a8391873a44fcef3d4 (inclusive)

Browse Source
This commit is contained in:
Georges Dupéron 2018-09-25 09:41:55 +02:00
parent aaf880c130
commit b75a961409
15 changed files with 4185 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
parse/debug.rkt
View File

@ -8,5 +8,7 @@
(my-include "debug.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "debug.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "debug.rkt-6-90-0-29")]
[else
(my-include "debug.rkt-6-90-0-29")])
(my-include "debug.rkt-7-0-0-20")])

127
parse/debug.rkt-7-0-0-20 Normal file
View File

@ -0,0 +1,127 @@
#lang racket/base
(require (for-syntax racket/base
syntax/stx
racket/syntax
syntax/parse/private/rep-data
"private/rep.rkt"
syntax/parse/private/kws)
racket/list
racket/pretty
"../parse.rkt"
(except-in stxparse-info/parse/private/residual
prop:pattern-expander syntax-local-syntax-parse-pattern-introduce)
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"
syntax/parse/private/kws)
;; No lazy loading for this module's dependencies.
(provide syntax-class-parse
syntax-class-attributes
syntax-class-arity
syntax-class-keywords
debug-rhs
debug-pattern
debug-parse
debug-syntax-parse!)
(define-syntax (syntax-class-parse stx)
(syntax-case stx ()
[(_ s x arg ...)
(parameterize ((current-syntax-context stx))
(with-disappeared-uses
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
[stxclass
(get-stxclass/check-arity #'s stx
(length (arguments-pargs argu))
(arguments-kws argu))]
[attrs (stxclass-attrs stxclass)])
(with-syntax ([parser (stxclass-parser stxclass)]
[argu argu]
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (undos fs) fs)])
(app-argu parser x x (ps-empty x x) #f null fh fh #f
(lambda (fh undos . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu))))))]))
(define-syntaxes (syntax-class-attributes
syntax-class-arity
syntax-class-keywords)
(let ()
(define ((mk handler) stx)
(syntax-case stx ()
[(_ s)
(parameterize ((current-syntax-context stx))
(with-disappeared-uses
(handler (get-stxclass #'s))))]))
(values (mk (lambda (s)
(let ([attrs (stxclass-attrs s)])
(with-syntax ([(a ...) (map attr-name attrs)]
[(d ...) (map attr-depth attrs)])
#'(quote ((a d) ...))))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a)))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(values '#,(arity-minkws a) '#,(arity-maxkws a))))))))
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f #:context stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p . rest)
(let-values ([(rest pattern defs)
(parse-pattern+sides #'p #'rest
#:splicing? #f
#:decls (new-declenv null)
#:context stx)])
(unless (stx-null? rest)
(raise-syntax-error #f "unexpected terms" stx rest))
#`(quote ((definitions . #,defs)
(pattern #,pattern))))]))
(define-syntax-rule (debug-parse x p ...)
(let/ec escape
(parameterize ((current-failure-handler
(lambda (_ fs)
(define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
(escape
`(parse-failure
#:raw-failures
,raw-fs-sexpr
#:maximal-failures
,maximal-fs-sexpr)))))
(syntax-parse x [p 'success] ...))))
(define (fs->sexprs fs)
(let* ([raw-fs (map invert-failure (reverse (flatten fs)))]
[selected-groups (maximal-failures raw-fs)])
(values (failureset->sexpr raw-fs)
(let ([selected (map (lambda (fs)
(cons 'progress-class
(map failure->sexpr fs)))
selected-groups)])
(if (= (length selected) 1)
(car selected)
(cons 'union selected))))))
(define (debug-syntax-parse!)
(define old-failure-handler (current-failure-handler))
(current-failure-handler
(lambda (ctx fs)
(define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
(eprintf "*** syntax-parse debug info ***\n")
(eprintf "Raw failures:\n")
(pretty-write raw-fs-sexpr (current-error-port))
(eprintf "Maximal failures:\n")
(pretty-write maximal-fs-sexpr (current-error-port))
(old-failure-handler ctx fs))))

4
parse/experimental/reflect.rkt
View File

@ -8,5 +8,7 @@
(my-include "reflect.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "reflect.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "reflect.rkt-6-90-0-29")]
[else
(my-include "reflect.rkt-6-90-0-29")])
(my-include "reflect.rkt-7-0-0-20")])

147
parse/experimental/reflect.rkt-7-0-0-20 Normal file
View File

@ -0,0 +1,147 @@
#lang racket/base
(require (for-syntax racket/base
racket/lazy-require
racket/syntax
syntax/parse/private/residual-ct) ;; keep abs.path
racket/contract/base
racket/contract/combinator
syntax/parse/private/minimatch
syntax/parse/private/keywords
"../private/runtime-reflect.rkt"
syntax/parse/private/kws)
(begin-for-syntax
(lazy-require
[syntax/parse/private/rep-data ;; keep abs. path
(get-stxclass)]))
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
;; Without this, dependencies don't get collected.
(require racket/runtime-path (for-meta 2 '#%kernel))
(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data)
(define-syntax (reify-syntax-class stx)
(if (eq? (syntax-local-context) 'expression)
(syntax-case stx ()
[(rsc sc)
(with-disappeared-uses
(let* ([stxclass (get-stxclass #'sc)]
[splicing? (stxclass-splicing? stxclass)])
(unless (scopts-delimit-cut? (stxclass-opts 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)
[(arity minpos maxpos _ _)
(to-procedure-arity minpos maxpos)]))
(define (reified-syntax-class-keywords r)
(match (reified-arity r)
[(arity _ _ minkws maxkws)
(values minkws maxkws)]))
(define (reified-syntax-class-attributes r)
(reified-signature r))
(define reified-syntax-class-curry
(make-keyword-procedure
(lambda (kws1 kwargs1 r . rest1)
(match r
[(reified name parser arity1 sig)
(let ()
(check-curry arity1 (length rest1) kws1
(lambda (msg)
(raise-mismatch-error 'reified-syntax-class-curry
(string-append msg ": ") r)))
(let* ([curried-arity
(match arity1
[(arity minpos maxpos minkws maxkws)
(let* ([rest1-length (length rest1)]
[minpos* (- minpos rest1-length)]
[maxpos* (- maxpos rest1-length)]
[minkws* (sort (remq* kws1 minkws) keyword<?)]
[maxkws* (sort (remq* kws1 maxkws) keyword<?)])
(arity minpos* maxpos* minkws* maxkws*))])]
[curried-parser
(make-keyword-procedure
(lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
(keyword-apply parser kws kwargs x cx pr es undos fh cp rl success
(append rest1 rest2)))))]
[ctor
(cond [(reified-syntax-class? r)
reified-syntax-class]
[(reified-splicing-syntax-class? r)
reified-splicing-syntax-class]
[else
(error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])])
(ctor name curried-parser curried-arity sig)))]))))
(define (merge2 kws1 kws2 kwargs1 kwargs2)
(cond [(null? kws1)
(values kws2 kwargs2)]
[(null? kws2)
(values kws1 kwargs1)]
[(keyword<? (car kws1) (car kws2))
(let-values ([(m-kws m-kwargs)
(merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)])
(values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))]
[else
(let-values ([(m-kws m-kwargs)
(merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))])
(values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))]))
;; ----
(provide reify-syntax-class
~reflect
~splicing-reflect)
(provide/contract
[reified-syntax-class?
(-> any/c boolean?)]
[reified-splicing-syntax-class?
(-> any/c boolean?)]
[reified-syntax-class-attributes
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
(listof (list/c symbol? exact-nonnegative-integer?)))]
[reified-syntax-class-arity
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
procedure-arity?)]
[reified-syntax-class-keywords
(-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
(values (listof keyword?)
(listof keyword?)))]
[reified-syntax-class-curry
(make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c))
(#:<kw> any/c ...)
#:rest list?
(or/c reified-syntax-class? reified-splicing-syntax-class/c))
#:late-neg-projection
(lambda (blame)
(let ([check-reified
((contract-late-neg-projection
(or/c reified-syntax-class? reified-splicing-syntax-class?))
(blame-swap blame))])
(lambda (f neg-party)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(make-keyword-procedure
(lambda (kws kwargs r . args)
(keyword-apply f kws kwargs (check-reified r neg-party) args)))
(raise-blame-error
blame #:missing-party neg-party
f
"expected a procedure of at least one argument, given ~e"
f)))))
#:first-order
(lambda (f) (procedure? f)))])

4
parse/pre.rkt
View File

@ -8,5 +8,7 @@
(my-include "pre.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "pre.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "pre.rkt-6-90-0-29")]
[else
(my-include "pre.rkt-6-90-0-29")])
(my-include "pre.rkt-7-0-0-20")])

49
parse/pre.rkt-7-0-0-20 Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require "private/sc.rkt"
"private/litconv.rkt"
"private/lib.rkt"
"private/residual.rkt")
(provide (except-out (all-from-out "private/sc.rkt")
define-integrable-syntax-class
syntax-parser/template)
(all-from-out "private/litconv.rkt")
(all-from-out "private/lib.rkt")
syntax-parse-state-ref
syntax-parse-state-set!
syntax-parse-state-update!
syntax-parse-state-cons!
syntax-parse-track-literals)
(define not-given (gensym))
(define (state-ref who key default)
(define state (current-state))
(if (eq? default not-given)
(if (hash-has-key? state key)
(hash-ref state key)
(error who "no value found for key\n key: ~e" key))
(hash-ref state key default)))
(define (syntax-parse-state-ref key [default not-given])
(state-ref 'syntax-parse-state-ref key default))
(define (check-update who)
(unless (current-state-writable?)
(error who "cannot update syntax-parse state outside of ~~do/#:do block")))
(define (syntax-parse-state-set! key value)
(check-update 'syntax-parse-state-set!)
(current-state (hash-set (current-state) key value)))
(define (syntax-parse-state-update! key update [default not-given])
(check-update 'syntax-parse-state-update!)
(define old (state-ref 'syntax-parse-state-update! key default))
(current-state (hash-set (current-state) key (update old))))
(define (syntax-parse-state-cons! key value [default null])
(check-update 'syntax-parse-state-cons!)
(define old (hash-ref (current-state) key default))
(current-state (hash-set (current-state) key (cons value old))))
(define (syntax-parse-track-literals stx #:introduce? [introduce? #t])
(track-literals 'syntax-parse-track-literals stx #:introduce? introduce?))

430
parse/private/opt.rkt-7-0-0-20 Normal file
View File

@ -0,0 +1,430 @@
#lang racket/base
(require racket/syntax
racket/pretty
syntax/parse/private/residual-ct ;; keep abs. path
syntax/parse/private/minimatch
syntax/parse/private/rep-patterns
syntax/parse/private/kws)
(provide (struct-out pk1)
(rename-out [optimize-matrix0 optimize-matrix]))
;; controls debugging output for optimization successes and failures
(define DEBUG-OPT-SUCCEED #f)
(define DEBUG-OPT-FAIL #f)
;; ----
;; A Matrix is a (listof PK) where each PK has same number of columns
;; A PK is one of
;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix
;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out
;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded
;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded
(struct pk1 (patterns k) #:prefab)
(struct pk/same (pattern inner) #:prefab)
(struct pk/pair (inner) #:prefab)
(struct pk/and (inner) #:prefab)
(define (pk-columns pk)
(match pk
[(pk1 patterns k) (length patterns)]
[(pk/same p inner) (add1 (pk-columns inner))]
[(pk/pair inner) (sub1 (pk-columns inner))]
[(pk/and inner) (sub1 (pk-columns inner))]))
;; Can factor pattern P given clauses like
;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ]
; [ P PN ... | eN] [ | [PN ... | eN] ]
;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking)
;; Can unfold pair patterns as follows:
;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ]
;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
;; Can unfold ~and patterns similarly; ~and patterns can hide
;; factoring opportunities.
;; ----
(define (optimize-matrix0 rows)
(define now (current-inexact-milliseconds))
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
(eprintf "\n%% optimizing (~s):\n" (length rows))
(pretty-write (matrix->sexpr rows) (current-error-port)))
(define result (optimize-matrix rows))
(define then (current-inexact-milliseconds))
(when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
(cond [(= (length result) (length rows))
(eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
[else
(eprintf "==> (~s ms)\n" (floor (- then now)))
(pretty-write (matrix->sexpr result) (current-error-port))
(eprintf "\n")]))
result)
;; optimize-matrix : (listof pk1) -> Matrix
(define (optimize-matrix rows)
(cond [(null? rows) null]
[(null? (cdr rows)) rows] ;; no opportunities for 1 row
[(null? (pk1-patterns (car rows))) rows]
[else
;; first unfold and-patterns
(let-values ([(col1 col2)
(for/lists (col1 col2) ([row (in-list rows)])
(unfold-and (car (pk1-patterns row)) null))])
(cond [(ormap pair? col2)
(list
(pk/and
(optimize-matrix*
(for/list ([row (in-list rows)]
[col1 (in-list col1)]
[col2 (in-list col2)])
(pk1 (list* col1
(make-and-pattern col2)
(cdr (pk1-patterns row)))
(pk1-k row))))))]
[else (optimize-matrix* rows)]))]))
;; optimize-matrix* : (listof pk1) -> Matrix
;; The matrix is nonempty, and first column has no unfoldable pat:and.
;; Split into submatrixes (sequences of rows) starting with similar patterns,
;; handle according to similarity, then recursively optimize submatrixes.
(define (optimize-matrix* rows)
(define row1 (car rows))
(define pat1 (car (pk1-patterns row1)))
(define k1 (pk1-k row1))
;; Now accumulate rows starting with patterns like pat1
(define-values (like? combine) (pattern->partitioner pat1))
(let loop ([rows (cdr rows)] [rrows (list row1)])
(cond [(null? rows)
(cons (combine (reverse rrows)) null)]
[else
(define row1 (car rows))
(define pat1 (car (pk1-patterns row1)))
(cond [(like? pat1)
(loop (cdr rows) (cons row1 rrows))]
[else
(cons (combine (reverse rrows))
(optimize-matrix* rows))])])))
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
(define (pattern->partitioner pat1)
(match pat1
[(pat:pair head tail)
(values (lambda (p) (pat:pair? p))
(lambda (rows)
(when DEBUG-OPT-SUCCEED
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1)
(pk/pair (optimize-matrix
(for/list ([row (in-list rows)])
(let* ([patterns (pk1-patterns row)]
[pat1 (car patterns)])
(pk1 (list* (pat:pair-head pat1)
(pat:pair-tail pat1)
(cdr patterns))
(pk1-k row))))))]
[else (car rows)])))]
[(? pattern-factorable?)
(values (lambda (pat2) (pattern-equal? pat1 pat2))
(lambda (rows)
(when DEBUG-OPT-SUCCEED
(eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1)))
(cond [(> (length rows) 1)
(pk/same pat1
(optimize-matrix
(for/list ([row (in-list rows)])
(pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
[else (car rows)])))]
[_
(values (lambda (pat2)
(when DEBUG-OPT-FAIL
(when (pattern-equal? pat1 pat2)
(eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2))))
#f)
(lambda (rows)
;; (length rows) = 1
(car rows)))]))
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
(define (unfold-and p onto)
(match p
[(pat:and subpatterns)
;; pat:and is worth unfolding if first subpattern is not pat:action
;; if first subpattern is also pat:and, keep unfolding
(let* ([first-sub (car subpatterns)]
[rest-subs (cdr subpatterns)])
(cond [(not (pat:action? first-sub))
(when #f ;; DEBUG-OPT-SUCCEED
(eprintf ">> unfolding: ~e\n" p))
(unfold-and first-sub (*append rest-subs onto))]
[else (values p onto)]))]
[_ (values p onto)]))
(define (pattern-factorable? p)
;; Can factor out p if p can succeed at most once, does not cut
;; - if p can succeed multiple times, then factoring changes success order
;; - if p can cut, then factoring changes which choice points are discarded (too few)
(match p
[(pat:any) #t]
[(pat:svar _n) #t]
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
;; commit? implies delimit-cut
commit?]
[(? pat:integrated?) #t]
[(pat:literal _lit _ip _lp) #t]
[(pat:datum _datum) #t]
[(pat:action _act _pat) #f]
[(pat:head head tail)
(and (pattern-factorable? head)
(pattern-factorable? tail))]
[(pat:dots heads tail)
;; Conservative approximation for common case: one head pattern
;; In general, check if heads don't overlap, don't overlap with tail.
(and (= (length heads) 1)
(let ([head (car heads)])
(and (pattern-factorable? head)))
(equal? tail (pat:datum '())))]
[(pat:and patterns)
(andmap pattern-factorable? patterns)]
[(pat:or _ patterns _) #f]
[(pat:not pattern) #f] ;; FIXME: ?
[(pat:pair head tail)
(and (pattern-factorable? head)
(pattern-factorable? tail))]
[(pat:vector pattern)
(pattern-factorable? pattern)]
[(pat:box pattern)
(pattern-factorable? pattern)]
[(pat:pstruct key pattern)
(pattern-factorable? pattern)]
[(pat:describe pattern _desc _trans _role)
(pattern-factorable? pattern)]
[(pat:delimit pattern)
(pattern-factorable? pattern)]
[(pat:commit pattern) #t]
[(? pat:reflect?) #f]
[(pat:ord pattern _ _)
(pattern-factorable? pattern)]
[(pat:post pattern)
(pattern-factorable? pattern)]
;; ----
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
commit?]
[(hpat:seq inner)
(pattern-factorable? inner)]
[(hpat:commit inner) #t]
;; ----
[(ehpat _ head repc _)
(and (equal? repc #f)
(pattern-factorable? head))]
;; ----
[else #f]))
(define (subpatterns-equal? as bs)
(and (= (length as) (length bs))
(for/and ([a (in-list as)]
[b (in-list bs)])
(pattern-equal? a b))))
(define (pattern-equal? a b)
(define result
(cond [(and (pat:any? a) (pat:any? b)) #t]
[(and (pat:svar? a) (pat:svar? b))
(bound-identifier=? (pat:svar-name a) (pat:svar-name b))]
[(and (pat:var/p? a) (pat:var/p? b))
(and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
(bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b))
(equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b))
(equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
(expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
[(and (pat:integrated? a) (pat:integrated? b))
(and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b))
(free-identifier=? (pat:integrated-predicate a)
(pat:integrated-predicate b))
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
[(and (pat:literal? a) (pat:literal? b))
;; literals are hard to compare, so compare gensyms attached to
;; literal ids (see rep.rkt) instead
(let ([ka (syntax-property (pat:literal-id a) 'literal)]
[kb (syntax-property (pat:literal-id b) 'literal)])
(and ka kb (eq? ka kb)))]
[(and (pat:datum? a) (pat:datum? b))
(equal? (pat:datum-datum a)
(pat:datum-datum b))]
[(and (pat:head? a) (pat:head? b))
(and (pattern-equal? (pat:head-head a) (pat:head-head b))
(pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
[(and (pat:dots? a) (pat:dots? b))
(and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
(pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
[(and (pat:and? a) (pat:and? b))
(subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
[(and (pat:or? a) (pat:or? b))
(subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
[(and (pat:not? a) (pat:not? b))
(pattern-equal? (pat:not-pattern a) (pat:not-pattern b))]
[(and (pat:pair? a) (pat:pair? b))
(and (pattern-equal? (pat:pair-head a) (pat:pair-head b))
(pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))]
[(and (pat:vector? a) (pat:vector? b))
(pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))]
[(and (pat:box? a) (pat:box? b))
(pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
[(and (pat:pstruct? a) (pat:pstruct? b))
(and (equal? (pat:pstruct-key a)
(pat:pstruct-key b))
(pattern-equal? (pat:pstruct-pattern a)
(pat:pstruct-pattern b)))]
[(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
[(and (pat:delimit? a) (pat:delimit? b))
(pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
[(and (pat:commit? a) (pat:commit? b))
(pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
[(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
[(and (pat:ord? a) (pat:ord? b))
(and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b))
(equal? (pat:ord-group a) (pat:ord-group b))
(equal? (pat:ord-index a) (pat:ord-index b)))]
[(and (pat:post? a) (pat:post? b))
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
;; ---
[(and (hpat:var/p? a) (hpat:var/p? b))
(and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
(bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
(equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b))
(equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
(expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
[(and (hpat:seq? a) (hpat:seq? b))
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
;; ---
[(and (ehpat? a) (ehpat? b))
(and (equal? (ehpat-repc a) #f)
(equal? (ehpat-repc b) #f)
(pattern-equal? (ehpat-head a) (ehpat-head b)))]
;; FIXME: more?
[else #f]))
(when DEBUG-OPT-FAIL
(when (and (eq? result #f)
(equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
(eprintf "** pattern-equal? failed on ~e\n" a)))
result)
(define (equal-iattrs? as bs)
(and (= (length as) (length bs))
;; assumes attrs in same order
(for/and ([aa (in-list as)]
[ba (in-list bs)])
(and (bound-identifier=? (attr-name aa) (attr-name ba))
(equal? (attr-depth aa) (attr-depth ba))
(equal? (attr-syntax? aa) (attr-syntax? ba))))))
(define (expr-equal? a b)
;; Expression equality is undecidable in general. Especially difficult for unexpanded
;; code, but it would be very difficult to set up correct env for local-expand because of
;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
;; FIXME: any other common cases?
(cond [(not (and (syntax? a) (syntax? b)))
(equal? a b)]
[(and (identifier? a) (identifier? b))
;; note: "vars" might be identifier macros (unsafe to consider equal),
;; so check var has no compile-time binding
(and (free-identifier=? a b)
(let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
[(syntax-case (list a b) (quote)
[((quote ad) (quote bd))
(cons (syntax->datum #'ad) (syntax->datum #'bd))]
[_ #f])
=> (lambda (ad+bd)
(equal? (car ad+bd) (cdr ad+bd)))]
[else
;; approx: equal? only if both simple data (bool, string, etc), no inner stx
(let ([ad (syntax-e a)]
[bd (syntax-e b)])
(and (equal? ad bd)
(free-identifier=? (datum->syntax a '#%datum) #'#%datum)
(free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
(define (equal-argu? a b)
(define (unwrap-arguments x)
(match x
[(arguments pargs kws kwargs)
(values pargs kws kwargs)]))
(define (list-equal? as bs inner-equal?)
(and (= (length as) (length bs))
(andmap inner-equal? as bs)))
(let-values ([(apargs akws akwargs) (unwrap-arguments a)]
[(bpargs bkws bkwargs) (unwrap-arguments b)])
(and (list-equal? apargs bpargs expr-equal?)
(equal? akws bkws)
(list-equal? akwargs bkwargs expr-equal?))))
(define (free-id/f-equal? a b)
(or (and (eq? a #f)
(eq? b #f))
(and (identifier? a)
(identifier? b)
(free-identifier=? a b))))
(define (bound-id/f-equal? a b)
(or (and (eq? a #f)
(eq? b #f))
(and (identifier? a)
(identifier? b)
(bound-identifier=? a b))))
(define (make-and-pattern subs)
(cond [(null? subs) (pat:any)] ;; shouldn't happen
[(null? (cdr subs)) (car subs)]
[else (pat:and subs)]))
(define (*append a b) (if (null? b) a (append a b)))
(define (stx-e x) (if (syntax? x) (syntax-e x) x))
;; ----
(define (matrix->sexpr rows)
(cond [(null? rows) ;; shouldn't happen
'(FAIL)]
[(null? (cdr rows))
(pk->sexpr (car rows))]
[else
(cons 'TRY (map pk->sexpr rows))]))
(define (pk->sexpr pk)
(match pk
[(pk1 pats k)
(cons 'MATCH (map pattern->sexpr pats))]
[(pk/same pat inner)
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
[(pk/pair inner)
(list 'PAIR (matrix->sexpr inner))]
[(pk/and inner)
(list 'AND (matrix->sexpr inner))]))
(define (pattern->sexpr p)
(match p
[(pat:any) '_]
[(pat:integrated name pred desc _)
(format-symbol "~a:~a" (or name '_) desc)]
[(pat:svar name)
(syntax-e name)]
[(pat:var/p name parser _ _ _ _)
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
=> (lambda (m)
(format-symbol "~a:~a" (or name '_) (cadr m)))]
[else
(if name (syntax-e name) '_)])]
[(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))]
[(pat:datum datum) datum]
[(? pat:action?) 'ACTION]
[(pat:pair head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:head head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:dots (list eh) tail)
(list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
[(ehpat _as hpat '#f _cn)
(pattern->sexpr hpat)]
[_ 'PATTERN]))

4
parse/private/parse.rkt
View File

@ -8,5 +8,7 @@
(my-include "parse.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "parse.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "parse.rkt-6-90-0-29")]
[else
(my-include "parse.rkt-6-90-0-29")])
(my-include "parse.rkt-7-0-0-20")])

1248
parse/private/parse.rkt-7-0-0-20 Normal file
View File

File diff suppressed because it is too large Load Diff

4
parse/private/rep.rkt
View File

@ -8,5 +8,7 @@
(my-include "rep.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "rep.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "rep.rkt-6-90-0-29")]
[else
(my-include "rep.rkt-6-90-0-29")])
(my-include "rep.rkt-7-0-0-20")])

1829
parse/private/rep.rkt-7-0-0-20 Normal file
View File

File diff suppressed because it is too large Load Diff

4
parse/private/residual.rkt
View File

@ -8,5 +8,7 @@
(my-include "residual.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "residual.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "residual.rkt-6-90-0-29")]
[else
(my-include "residual.rkt-6-90-0-29")])
(my-include "residual.rkt-7-0-0-20")])

302
parse/private/residual.rkt-7-0-0-20 Normal file
View File

@ -0,0 +1,302 @@
#lang racket/base
(require (for-syntax racket/base)
racket/stxparam
racket/lazy-require
racket/private/promise)
;; ============================================================
;; Compile-time
(require (for-syntax racket/private/sc syntax/parse/private/residual-ct))
(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
(require racket/private/template)
(provide (for-syntax attribute-mapping attribute-mapping?))
;; ============================================================
;; Run-time
(require "runtime-progress.rkt"
"3d-stx.rkt"
auto-syntax-e
syntax/stx
stxparse-info/current-pvars)
(provide (all-from-out "runtime-progress.rkt")
this-syntax
this-role
this-context-syntax
attribute
attribute-binding
check-attr-value
stx-list-take
stx-list-drop/cx
datum->syntax/with-clause
check-literal*
error/null-eh-match
begin-for-syntax/once
name->too-few/once
name->too-few
name->too-many
normalize-context
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)))
(define-syntax-parameter this-role
(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
(list (syntax-local-introduce #'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)
(if (attribute-mapping-check value) #f #t)))
#'(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 : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any))
(define (check-attr-value v0 depth0 base? ctx)
(define (bad kind v)
(raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx))
(define (depthloop depth v)
(if (zero? depth)
(if base? (baseloop v) v)
(let listloop ([v v] [root? #t])
(cond [(null? v) null]
[(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))]
[new-cdr (listloop (cdr v) #f)])
(cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v]
[else (cons new-car new-cdr)]))]
[(promise? v) (listloop (force v) root?)]
[(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))]
[else (bad 'list v)]))))
(define (baseloop v)
(cond [(syntax? v) v]
[(promise? v) (baseloop (force v))]
[(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))]
[else (bad 'syntax v)]))
(depthloop depth0 v0))
;; datum->syntax/with-clause : any -> syntax
(define (datum->syntax/with-clause x)
(cond [(syntax? x) x]
[(2d-stx? x #:traverse-syntax? #f)
(datum->syntax #f x #f)]
[else
(error 'datum->syntax/with-clause
(string-append
"implicit conversion to 3D syntax\n"
" right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n"
" value: ~e")
x)]))
;; 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)))
;; error/null-eh-match : -> (escapes)
(define (error/null-eh-match)
(error 'syntax-parse "an ellipsis-head pattern matched an empty sequence"))
;; (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
;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax)
(define (normalize-context who ctx stx)
(cond [(syntax? ctx)
(list #f ctx)]
[(symbol? ctx)
(list ctx stx)]
[(eq? ctx #f)
(list #f stx)]
[(and (list? ctx)
(= (length ctx) 2)
(or (symbol? (car ctx)) (eq? #f (car ctx)))
(syntax? (cadr ctx)))
ctx]
[else (error who "bad #:context argument\n expected: ~s\n given: ~e"
'(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?))
ctx)]))
;; == parse.rkt
(lazy-require
["runtime-report.rkt"
(call-current-failure-handler)])
;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes
(define ((syntax-patterns-fail ctx) undos fs)
(unwind-to undos null)
(call-current-failure-handler ctx fs))
;; == specialized ellipsis parser
;; returns (values 'ok attr-values) or (values 'fail failure)
(provide predicate-ellipsis-parser)
(define (predicate-ellipsis-parser x cx pr es pred? desc rl)
(let ([elems (stx->list x)])
(if (and elems (list? elems) (andmap pred? elems))
(values 'ok elems)
(let loop ([x x] [cx cx] [i 0])
(cond [(syntax? x)
(loop (syntax-e x) x i)]
[(pair? x)
(if (pred? (car x))
(loop (cdr x) cx (add1 i))
(let* ([pr (ps-add-cdr pr i)]
[pr (ps-add-car pr)]
[es (es-add-thing pr desc #t rl es)])
(values 'fail (failure pr es))))]
[else ;; not null, because stx->list failed
(let ([pr (ps-add-cdr pr i)]
#|
;; Don't extend es! That way we don't get spurious "expected ()"
;; that *should* have been cancelled out by ineffable pair failures.
|#)
(values 'fail (failure pr es)))])))))
(provide illegal-cut-error)
(define (illegal-cut-error . _)
(error 'syntax-parse "illegal use of cut"))
;; ----
(provide unwind-to
maybe-add-state-undo
current-state
current-state-writable?
state-cons!
track-literals)
(define (unwind-to undos base)
;; PRE: undos = (list* proc/hash ... base)
(unless (eq? undos base)
(let ([top-undo (car undos)])
(cond [(procedure? top-undo) (top-undo)]
[(hash? top-undo) (current-state top-undo)]))
(unwind-to (cdr undos) base)))
(define (maybe-add-state-undo init-state new-state undos)
(if (eq? init-state new-state)
undos
(cons init-state undos)))
;; To make adding undos to rewind current-state simpler, only allow updates
;; in a few contexts:
;; - literals (handled automatically)
;; - in ~do/#:do blocks (sets current-state-writable? = #t)
(define current-state (make-parameter (hasheq)))
(define current-state-writable? (make-parameter #f))
(define (state-cons! key value)
(define state (current-state))
(current-state (hash-set state key (cons value (hash-ref state key null)))))
(define (track-literals who v #:introduce? [introduce? #t])
(unless (syntax? v)
(raise-argument-error who "syntax?" v))
(let* ([literals (hash-ref (current-state) 'literals '())])
(if (null? literals)
v
(let ([literals* (if (and introduce? (syntax-transforming?) (list? literals))
(for/list ([literal (in-list literals)])
(if (identifier? literal)
(syntax-local-introduce literal)
literal))
literals)]
[old-val (syntax-property v 'disappeared-use)])
(syntax-property v 'disappeared-use
(if old-val
(cons literals* old-val)
literals*))))))

4
parse/private/sc.rkt
View File

@ -8,5 +8,7 @@
(my-include "sc.rkt-6-11")]
[(version< (version) "6.90.0.29")
(my-include "sc.rkt-6-12")]
[(version< (version) "7.0.0.20")
(my-include "sc.rkt-6-90-0-29")]
[else
(my-include "sc.rkt-6-90-0-29")])
(my-include "sc.rkt-7-0-0-20")])

32
parse/private/sc.rkt-7-0-0-20 Normal file
View File

@ -0,0 +1,32 @@
#lang racket/base
(require racket/lazy-require
syntax/parse/private/keywords
"residual.rkt")
(lazy-require-syntax
["parse.rkt"
(define-syntax-class
define-splicing-syntax-class
define-integrable-syntax-class
syntax-parse
syntax-parser
define/syntax-parse
syntax-parser/template
define-eh-alternative-set)])
(provide define-syntax-class
define-splicing-syntax-class
define-integrable-syntax-class
syntax-parse
syntax-parser
define/syntax-parse
(except-out (all-from-out syntax/parse/private/keywords)
~reflect
~splicing-reflect
~eh-var)
attribute
this-syntax
syntax-parser/template
define-eh-alternative-set)