236 lines
8.5 KiB
Racket
236 lines
8.5 KiB
Racket
#lang racket/base
|
|
(require racket/stxparam
|
|
stxparse-info/parse/private/residual ;; keep abs. path
|
|
stxparse-info/current-pvars
|
|
(for-syntax racket/base
|
|
racket/list
|
|
syntax/kerncase
|
|
syntax/strip-context
|
|
racket/private/sc
|
|
auto-syntax-e/utils
|
|
racket/syntax
|
|
syntax/parse/private/rep-data))
|
|
|
|
(provide with
|
|
fail-handler
|
|
cut-prompt
|
|
undo-stack
|
|
wrap-user-code
|
|
|
|
fail
|
|
try
|
|
|
|
let-attributes
|
|
let-attributes*
|
|
let/unpack
|
|
|
|
defattrs/unpack
|
|
|
|
check-literal
|
|
no-shadow
|
|
curried-stxclass-parser
|
|
app-argu)
|
|
|
|
#|
|
|
TODO: rename file
|
|
|
|
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 ==
|
|
|
|
(define-syntax (with stx)
|
|
(syntax-case stx ()
|
|
[(with ([stxparam expr] ...) . body)
|
|
(with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))])
|
|
(syntax/loc stx
|
|
(let ([var expr] ...)
|
|
(syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var)))
|
|
...)
|
|
. body))))]))
|
|
|
|
;; == Control information ==
|
|
|
|
(define-syntax-parameter fail-handler
|
|
(lambda (stx)
|
|
(wrong-syntax stx "internal error: fail-handler used out of context")))
|
|
(define-syntax-parameter cut-prompt
|
|
(lambda (stx)
|
|
(wrong-syntax stx "internal error: cut-prompt used out of context")))
|
|
(define-syntax-parameter undo-stack
|
|
(lambda (stx)
|
|
(wrong-syntax stx "internal error: undo-stack used out of context")))
|
|
|
|
(define-syntax-rule (wrap-user-code e)
|
|
(with ([fail-handler #f]
|
|
[cut-prompt #t]
|
|
[undo-stack null])
|
|
e))
|
|
|
|
(define-syntax-rule (fail fs)
|
|
(fail-handler undo-stack fs))
|
|
|
|
(define-syntax (try stx)
|
|
(syntax-case stx ()
|
|
[(try e0 e ...)
|
|
(with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
|
|
(with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
|
|
(with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)])
|
|
#'(let* ([fh (lambda (undos1 fs1)
|
|
(with ([fail-handler
|
|
(lambda (undos2 fs2)
|
|
(unwind-to undos2 undos1)
|
|
(next-fh undos1 (cons fs1 fs2)))]
|
|
[undo-stack undos1])
|
|
re))]
|
|
...)
|
|
(with ([fail-handler
|
|
(lambda (undos2 fs2)
|
|
(unwind-to undos2 undo-stack)
|
|
(last-fh undo-stack fs2))]
|
|
[undo-stack undo-stack])
|
|
e0)))))]))
|
|
|
|
;; == Attributes
|
|
|
|
(define-for-syntax (parse-attr x)
|
|
(syntax-case x ()
|
|
[#s(attr name depth syntax?) #'(name depth syntax?)]))
|
|
|
|
(define-syntax (let-attributes stx)
|
|
(syntax-case stx ()
|
|
[(let-attributes ([a value] ...) . body)
|
|
(with-syntax ([((name depth syntax?) ...)
|
|
(map parse-attr (syntax->list #'(a ...)))])
|
|
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
|
|
[(stmp ...) (generate-temporaries #'(name ...))])
|
|
#'(letrec-syntaxes+values
|
|
([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth
|
|
(if 'syntax? #f (quote-syntax check-attr-value)))]
|
|
...)
|
|
([(vtmp) value] ...)
|
|
(letrec-syntaxes+values
|
|
([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...)
|
|
()
|
|
(with-pvars (name ...)
|
|
. body)))))]))
|
|
|
|
;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
|
|
;; Special case: empty attrs need not match number of value exprs.
|
|
(define-syntax let-attributes*
|
|
(syntax-rules ()
|
|
[(la* (() _) . body)
|
|
(let () . body)]
|
|
[(la* ((a ...) (val ...)) . body)
|
|
(let-attributes ([a val] ...) . body)]))
|
|
|
|
;; (let/unpack (([id num] ...) expr) expr) : expr
|
|
;; Special case: empty attrs need not match packed length
|
|
(define-syntax (let/unpack stx)
|
|
(syntax-case stx ()
|
|
[(let/unpack (() packed) body)
|
|
#'body]
|
|
[(let/unpack ((a ...) packed) body)
|
|
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
|
|
#'(let-values ([(tmp ...) (apply values packed)])
|
|
(let-attributes ([a tmp] ...) body)))]))
|
|
|
|
(define-syntax (defattrs/unpack stx)
|
|
(syntax-case stx ()
|
|
[(defattrs (a ...) packed)
|
|
(with-syntax ([((name depth syntax?) ...)
|
|
(map parse-attr (syntax->list #'(a ...)))])
|
|
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
|
|
[(stmp ...) (generate-temporaries #'(name ...))])
|
|
#'(begin (define-values (vtmp ...) (apply values packed))
|
|
(define-syntax stmp
|
|
(attribute-mapping (quote-syntax vtmp) 'name 'depth
|
|
(if 'syntax? #f (quote-syntax check-attr-value))))
|
|
...
|
|
(define-syntax name (make-auto-pvar 'depth (quote-syntax stmp)))
|
|
...
|
|
(define-pvars name ...))))]))
|
|
|
|
(define-syntax-rule (phase-of-enclosing-module)
|
|
(variable-reference->module-base-phase
|
|
(#%variable-reference)))
|
|
|
|
;; (check-literal id phase-level-expr ctx) -> void
|
|
(define-syntax (check-literal stx)
|
|
(syntax-case stx ()
|
|
[(check-literal id used-phase-expr ctx)
|
|
(let* ([ok-phases/ct-rel
|
|
;; id is bound at each of ok-phases/ct-rel
|
|
;; (phase relative to the compilation of the module in which the
|
|
;; 'syntax-parse' (or related) form occurs)
|
|
(filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))])
|
|
;; so we can avoid run-time call to identifier-binding if
|
|
;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase
|
|
(with-syntax ([ok-phases/ct-rel ok-phases/ct-rel])
|
|
#`(check-literal* (quote-syntax id)
|
|
used-phase-expr
|
|
(phase-of-enclosing-module)
|
|
'ok-phases/ct-rel
|
|
;; If context is not stripped, racket complains about
|
|
;; being unable to restore bindings for compiled code;
|
|
;; and all we want is the srcloc, etc.
|
|
(quote-syntax #,(strip-context #'ctx)))))]))
|
|
|
|
;; ====
|
|
|
|
(begin-for-syntax
|
|
(define (check-shadow def)
|
|
(syntax-case def ()
|
|
[(_def (x ...) . _)
|
|
(parameterize ((current-syntax-context def))
|
|
(for ([x (in-list (syntax->list #'(x ...)))])
|
|
(let ([v (syntax-local-value x (lambda _ #f))])
|
|
(when (syntax-pattern-variable? v)
|
|
(wrong-syntax
|
|
x
|
|
;; FIXME: customize "~do pattern" vs "#:do block" as appropriate
|
|
"definition in ~~do pattern must not shadow attribute binding")))))])))
|
|
|
|
(define-syntax (no-shadow stx)
|
|
(syntax-case stx ()
|
|
[(no-shadow e)
|
|
(let ([ee (local-expand #'e (syntax-local-context)
|
|
(kernel-form-identifier-list))])
|
|
(syntax-case ee (begin define-values define-syntaxes)
|
|
[(begin d ...)
|
|
#'(begin (no-shadow d) ...)]
|
|
[(define-values . _)
|
|
(begin (check-shadow ee)
|
|
ee)]
|
|
[(define-syntaxes . _)
|
|
(begin (check-shadow ee)
|
|
ee)]
|
|
[_
|
|
ee]))]))
|
|
|
|
(define-syntax (curried-stxclass-parser stx)
|
|
(syntax-case stx ()
|
|
[(_ class argu)
|
|
(with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu])
|
|
(let ([sc (get-stxclass/check-arity #'class #'class
|
|
(length (syntax->list #'(parg ...)))
|
|
(syntax->datum #'(kw ...)))])
|
|
(with-syntax ([parser (stxclass-parser sc)])
|
|
#'(lambda (x cx pr es undos fh cp rl success)
|
|
(app-argu parser x cx pr es undos fh cp rl success argu)))))]))
|
|
|
|
(define-syntax (app-argu stx)
|
|
(syntax-case stx ()
|
|
[(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...)))
|
|
#|
|
|
Use keyword-apply directly?
|
|
#'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null)
|
|
If so, create separate no-keyword clause.
|
|
|#
|
|
;; For now, let #%app handle it.
|
|
(with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)])
|
|
#'(proc kw-part ... ... extra-parg ... parg ...))]))
|