d7a87c79e0
Changed backtracking algorithm, runtime representations
- syntax classes, ~describe no longer implicitly commit
- ~describe no longer delimits effect of cut
Added keyword & optional args for stxclasses
Added ~do and #:do, ~post, ~commit and #:commit,
~delimit-cut and #:no-delimit-cut
Added syntax/parse/debug, syntax/parse/experimental/*
- expr/c for contracting macro sub-expressions
moved from syntax/parse to syntax/parse/experimental/contract
- syntax class reflection (~reflect, ~splicing-reflect)
- eh-alternative-sets (~eh-var)
- provide-syntax-class/contract
(only for params, not attrs so far)
Changed ~fail to not include POST progress (#:fail still does)
old (~fail _) is now (~post (~fail _))
Made msg argument of ~fail optional
Removed generic "repetition constraint violated" msg
Removed atom-in-list stxclass
Removed unnecessary datum->syntax on cdr of pair pattern
massive improvements to long-list microbenchmarks
Optimization: integrable syntax classes (id, expr, keyword)
need better measurements
Optimization: ad hoc elimination of head/tail choice point
for (EH ... . ()) patterns
Added unstable/wrapc (proc version of expr/c)
109 lines
4.5 KiB
Racket
109 lines
4.5 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
"rep-data.rkt")
|
|
"rep-attrs.rkt"
|
|
"kws.rkt")
|
|
(provide (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)
|
|
|
|
#|
|
|
A Reified is
|
|
(reified symbol ParserFunction nat (listof (list symbol nat)))
|
|
|#
|
|
(define-struct reified-base (name) #:transparent)
|
|
(define-struct (reified reified-base) (parser arity signature))
|
|
(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?)
|
|
(define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
|
|
(if splicing?
|
|
(unless (reified-splicing-syntax-class? obj)
|
|
(raise-type-error who "reified splicing-syntax-class" obj))
|
|
(unless (reified-syntax-class? obj)
|
|
(raise-type-error who "reified syntax-class" obj)))
|
|
(check-params who e-arity (reified-arity obj) obj)
|
|
(adapt-parser who
|
|
(for/list ([a (in-list e-attrs)])
|
|
(list (attr-name a) (attr-depth a)))
|
|
(reified-signature obj)
|
|
(reified-parser obj)
|
|
splicing?))
|
|
|
|
(define (check-params who e-arity r-arity obj)
|
|
(let ([e-pos (arity-minpos e-arity)]
|
|
[e-kws (arity-minkws e-arity)])
|
|
(check-arity/neg r-arity e-pos e-kws
|
|
(lambda (msg)
|
|
(raise-mismatch-error who (string-append msg ": ") obj)))))
|
|
|
|
(define (adapt-parser who esig0 rsig0 parser splicing?)
|
|
(if (equal? esig0 rsig0)
|
|
parser
|
|
(let ([indexes
|
|
(let loop ([esig esig0] [rsig rsig0] [index 0])
|
|
(cond [(null? esig)
|
|
null]
|
|
[(and (pair? rsig) (eq? (caar esig) (caar rsig)))
|
|
(unless (= (cadar esig) (cadar rsig))
|
|
(wrong-depth who (car esig) (car rsig)))
|
|
(cons index (loop (cdr esig) (cdr rsig) (add1 index)))]
|
|
[(and (pair? rsig)
|
|
(string>? (symbol->string (caar esig))
|
|
(symbol->string (caar rsig))))
|
|
(loop esig (cdr rsig) (add1 index))]
|
|
[else
|
|
(error who "reified syntax-class is missing declared attribute `~s'"
|
|
(caar esig))]))])
|
|
(define (take-indexes result indexes)
|
|
(let loop ([result result] [indexes indexes] [i 0])
|
|
(cond [(null? indexes) null]
|
|
[(= (car indexes) i)
|
|
(cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))]
|
|
[else
|
|
(loop (cdr result) indexes (add1 i))])))
|
|
(make-keyword-procedure
|
|
(lambda (kws kwargs x cx pr es fh cp success . rest)
|
|
(keyword-apply parser kws kwargs x cx pr es fh cp
|
|
(if splicing?
|
|
(lambda (fh cp x cx . result)
|
|
(apply success fh cp x cx (take-indexes result indexes)))
|
|
(lambda (fh cp . result)
|
|
(apply success fh cp (take-indexes result indexes))))
|
|
rest))))))
|
|
|
|
(define (wrong-depth who a b)
|
|
(error who
|
|
"reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead"
|
|
(car a) (cadr a) (cadr b)))
|