3aa16f2c26
Can't do check completely statically, because phase of comparison is expression (and even default is slightly unpredictable). So instead compute whether check would succeed for likely phase offsets, and use list of ok offsets as run-time fast path (memv instead of identifier-binding).
395 lines
14 KiB
Racket
395 lines
14 KiB
Racket
#lang racket/base
|
|
(require racket/list
|
|
racket/stxparam
|
|
unstable/syntax
|
|
"runtime-progress.rkt"
|
|
"runtime-failure.rkt"
|
|
(for-syntax racket/base
|
|
racket/list
|
|
syntax/kerncase
|
|
racket/private/sc
|
|
racket/syntax
|
|
"rep-data.rkt"
|
|
"rep-attrs.rkt"))
|
|
|
|
(provide (all-from-out "runtime-progress.rkt")
|
|
(all-from-out "runtime-failure.rkt")
|
|
|
|
this-syntax
|
|
this-context-syntax
|
|
|
|
stx-list-take
|
|
stx-list-drop/cx
|
|
|
|
let-attributes
|
|
let-attributes*
|
|
let/unpack
|
|
defattrs/unpack
|
|
attribute
|
|
attribute-binding
|
|
check-list^depth)
|
|
|
|
;; == Syntax Parameters
|
|
|
|
;; 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")))
|
|
|
|
;; 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")))
|
|
|
|
;; == with ==
|
|
|
|
(provide 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 ==
|
|
|
|
(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")))
|
|
(define-syntax-parameter cut-prompt
|
|
(lambda (stx)
|
|
(wrong-syntax stx "internal error: used out of context")))
|
|
|
|
(define-syntax-rule (wrap-user-code e)
|
|
(with ([fail-handler #f]
|
|
[cut-prompt #t])
|
|
e))
|
|
|
|
(define-syntax-rule (fail fs)
|
|
(fail-handler 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 ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)]
|
|
[(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)])
|
|
#'(let* ([fh (lambda (fs1)
|
|
(with ([fail-handler
|
|
(lambda (fs2)
|
|
(next-fh (cons fs1 fs2)))])
|
|
re))]
|
|
...)
|
|
(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?)]))
|
|
|
|
(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) (make-attribute-mapping (quote-syntax vtmp)
|
|
'name 'depth 'syntax?)] ...)
|
|
([(vtmp) value] ...)
|
|
(letrec-syntaxes+values
|
|
([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
|
|
()
|
|
. 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
|
|
(make-attribute-mapping (quote-syntax vtmp)
|
|
'name 'depth 'syntax?))
|
|
...
|
|
(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 ()
|
|
[(_ a expr)
|
|
(with-syntax ([#s(attr name depth syntax?) #'a])
|
|
(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
|
|
free-identifier=?/phases)
|
|
|
|
;; (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
|
|
(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)))
|
|
|
|
;; free-identifier=?/phases : id phase-level id phase-level -> boolean
|
|
;; Determines whether x has the same binding at phase-level phase-x
|
|
;; that y has at phase-level y.
|
|
;; At least one of the identifiers MUST have a binding (module or lexical)
|
|
(define (free-identifier=?/phases x phase-x y phase-y)
|
|
(cond [(eqv? phase-x phase-y)
|
|
(free-identifier=? x y phase-x)]
|
|
[else
|
|
(let ([bx (identifier-binding x phase-x)]
|
|
[by (identifier-binding y phase-y)])
|
|
(cond [(and (pair? bx) (pair? by))
|
|
(let ([mpix (first bx)]
|
|
[namex (second bx)]
|
|
[defphasex (fifth bx)]
|
|
[mpiy (first by)]
|
|
[namey (second by)]
|
|
[defphasey (fifth by)])
|
|
(and (eq? namex namey)
|
|
;; resolved-module-paths are interned
|
|
(eq? (module-path-index-resolve mpix)
|
|
(module-path-index-resolve mpiy))
|
|
(eqv? defphasex defphasey)))]
|
|
[else
|
|
;; Module is only way to get phase-shift; phases differ, so
|
|
;; if not module-bound names, no way can refer to same binding.
|
|
#f]))]))
|
|
|
|
;; ----
|
|
|
|
(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 ()
|
|
[(_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]))]))
|
|
|
|
;; ----
|
|
|
|
(provide curried-stxclass-parser
|
|
app-argu)
|
|
|
|
(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 fh cp success)
|
|
(app-argu parser x cx pr es fh cp 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 ...))]))
|