292 lines
10 KiB
Racket
292 lines
10 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
racket/private/sc
|
|
unstable/syntax
|
|
unstable/struct
|
|
"minimatch.ss"
|
|
"../util/txlift.ss"
|
|
"rep-data.ss"
|
|
"rep.ss")
|
|
racket/list
|
|
syntax/stx
|
|
"parse.ss"
|
|
"runtime.ss"
|
|
"runtime-prose.ss")
|
|
|
|
(provide define-syntax-class
|
|
define-splicing-syntax-class
|
|
|
|
define-literal-set
|
|
define-conventions
|
|
syntax-class-parse
|
|
syntax-class-attributes
|
|
syntax-class-possible-errors
|
|
|
|
debug-rhs
|
|
debug-pattern
|
|
debug-parse
|
|
|
|
syntax-parse
|
|
syntax-parser
|
|
|
|
pattern
|
|
~var
|
|
~datum
|
|
~literal
|
|
~and
|
|
~or
|
|
~not
|
|
~seq
|
|
~between
|
|
~once
|
|
~optional
|
|
~rest
|
|
~describe
|
|
~!
|
|
~bind
|
|
~fail
|
|
;; ~early-fail
|
|
~parse
|
|
...+
|
|
|
|
attribute
|
|
this-syntax)
|
|
|
|
(begin-for-syntax
|
|
(define (defstxclass stx name args rhss splicing?)
|
|
(with-syntax ([name name]
|
|
[(arg ...) args]
|
|
[rhss rhss])
|
|
(let ([the-rhs
|
|
(parameterize ((current-syntax-context stx))
|
|
(parse-rhs #'rhss #f splicing? #:context stx))])
|
|
(with-syntax ([parser (generate-temporary
|
|
(format-symbol "parse-~a" (syntax-e #'name)))]
|
|
[attrs (rhs-attrs the-rhs)]
|
|
[commit? (rhs-commit? the-rhs)])
|
|
#`(begin (define-syntax name
|
|
(make stxclass 'name '(arg ...)
|
|
'attrs
|
|
((syntax-local-certifier) (quote-syntax parser))
|
|
((syntax-local-certifier) (quote-syntax description))
|
|
'#,splicing?
|
|
'commit?))
|
|
(define-values (parser description)
|
|
(functions/rhs name (arg ...) attrs rhss #,splicing? #,stx))))))))
|
|
|
|
(define-syntax (define-syntax-class stx)
|
|
(syntax-case stx ()
|
|
[(define-syntax-class name . rhss)
|
|
(identifier? #'name)
|
|
(defstxclass stx #'name #'() #'rhss #f)]
|
|
[(define-syntax-class (name arg ...) . rhss)
|
|
(andmap identifier? (syntax->list #'(name arg ...)))
|
|
(defstxclass stx #'name #'(arg ...) #'rhss #f)]))
|
|
|
|
(define-syntax (define-splicing-syntax-class stx)
|
|
(syntax-case stx ()
|
|
[(define-splicing-syntax-class name . rhss)
|
|
(identifier? #'name)
|
|
(defstxclass stx #'name #'() #'rhss #t)]
|
|
[(define-splicing-syntax-class (name arg ...) . rhss)
|
|
(andmap identifier? (syntax->list #'(name arg ...)))
|
|
(defstxclass stx #'name #'(arg ...) #'rhss #t)]))
|
|
|
|
(define-syntax (define-conventions stx)
|
|
(syntax-case stx ()
|
|
[(define-conventions (name param ...) rule ...)
|
|
(let ([params (syntax->list #'(param ...))])
|
|
(for ([x (syntax->list #'(name param ...))])
|
|
(unless (identifier? x)
|
|
(raise-syntax-error #f "expected identifier" stx x)))
|
|
(let ()
|
|
(define rules (check-conventions-rules #'(rule ...) stx))
|
|
(define rxs (map car rules))
|
|
(define dens0 (map cadr rules))
|
|
(define den+defs-list
|
|
(for/list ([den0 dens0])
|
|
(let-values ([(den defs) (create-aux-def den0)])
|
|
(cons den defs))))
|
|
(define dens (map car den+defs-list))
|
|
(define defs (apply append (map cdr den+defs-list)))
|
|
|
|
(define/with-syntax (rx ...) rxs)
|
|
(define/with-syntax (def ...) defs)
|
|
(define/with-syntax (parser ...)
|
|
(map den:delayed-parser dens))
|
|
(define/with-syntax (description ...)
|
|
(map den:delayed-description dens))
|
|
(define/with-syntax (class-name ...)
|
|
(map den:delayed-class dens))
|
|
|
|
#'(begin
|
|
(define-syntax name
|
|
(make-conventions
|
|
(quote-syntax get-procedures)
|
|
(lambda ()
|
|
(let ([class-names (list (quote-syntax class-name) ...)])
|
|
(map list
|
|
(list 'rx ...)
|
|
(map make-den:delayed
|
|
(generate-temporaries class-names)
|
|
(generate-temporaries class-names)
|
|
class-names))))))
|
|
(define get-procedures
|
|
(lambda (param ...)
|
|
def ...
|
|
(values (list parser ...)
|
|
(list description ...)))))))]
|
|
|
|
[(define-conventions name rule ...)
|
|
(identifier? #'name)
|
|
#'(define-conventions (name) rule ...)]))
|
|
|
|
(define-syntax (define-literal-set stx)
|
|
(syntax-case stx ()
|
|
[(define-literal-set name (lit ...))
|
|
(let ([phase-of-definition (syntax-local-phase-level)])
|
|
(unless (identifier? #'name)
|
|
(raise-syntax-error #f "expected identifier" stx #'name))
|
|
(let ([lits (check-literals-list/litset #'(lit ...) stx)])
|
|
(with-syntax ([((internal external) ...) lits])
|
|
#`(begin
|
|
(define phase-of-literals
|
|
(phase-of-enclosing-module))
|
|
(define-syntax name
|
|
(make-literalset
|
|
(list (list 'internal (quote-syntax external)) ...)
|
|
(quote-syntax phase-of-literals)))
|
|
(begin-for-syntax/once
|
|
(for ([x (syntax->list #'(external ...))])
|
|
(unless (identifier-binding x 0)
|
|
(raise-syntax-error #f "literal is unbound in phase 0"
|
|
(quote-syntax #,stx) x))))))))]))
|
|
|
|
(define-syntax (phase-of-enclosing-module stx)
|
|
(syntax-case stx ()
|
|
[(poem)
|
|
(let ([phase-within-module (syntax-local-phase-level)])
|
|
#`(let ([phase-of-this-expression
|
|
(variable-reference->phase (#%variable-reference))])
|
|
(- phase-of-this-expression
|
|
#,(if (zero? phase-within-module) 0 1))))]))
|
|
|
|
#|
|
|
Literal sets: The goal is for literals to refer to their bindings at
|
|
|
|
phase 0 relative to the enclosing module
|
|
|
|
Use cases, explained:
|
|
1) module X with def-lit-set is required-for-syntax
|
|
phase-of-mod-inst = 1
|
|
phase-of-def = 0
|
|
literals looked up at abs phase 1
|
|
which is phase 0 rel to module X
|
|
2) module X with local def-lit-set within define-syntax
|
|
phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax)
|
|
phase-of-def = 1
|
|
literals looked up at abs phase 0
|
|
which is phase 0 rel to module X
|
|
3) module X with def-lit-set in phase-2 position (really uncommon case!)
|
|
phase-of-mod-inst = 1 (not 2, apparently)
|
|
phase-of-def = 2
|
|
literals looked up at abs phase 0
|
|
(that's why the weird (if (z?) 0 1) term)
|
|
|#
|
|
|
|
;; ----
|
|
|
|
(define-syntax (functions/rhs stx)
|
|
(syntax-case stx ()
|
|
[(functions/S-rhs name args 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))])
|
|
#`(let ([get-description
|
|
(lambda args
|
|
#,(or (rhs-description rhs)
|
|
#'(symbol->string 'name)))])
|
|
(values (parse:rhs #,rhs
|
|
attrs
|
|
args
|
|
get-description
|
|
splicing?)
|
|
get-description))))]))
|
|
|
|
(define-syntax (syntax-class-parse stx)
|
|
(syntax-case stx ()
|
|
[(_ s x arg ...)
|
|
(parameterize ((current-syntax-context stx))
|
|
(let* ([arg-count (length (syntax->list #'(arg ...)))]
|
|
[stxclass (get-stxclass/check-arg-count #'s arg-count)]
|
|
[attrs (stxclass-attrs stxclass)])
|
|
(with-syntax ([parser (stxclass-parser-name stxclass)]
|
|
[(name ...) (map attr-name attrs)]
|
|
[(depth ...) (map attr-depth attrs)])
|
|
#'(let ([raw (parser x arg ...)])
|
|
(if (ok? raw)
|
|
(map vector '(name ...) '(depth ...) raw)
|
|
raw)))))]))
|
|
|
|
(define-syntax (syntax-class-attributes stx)
|
|
(syntax-case stx ()
|
|
[(_ s)
|
|
(parameterize ((current-syntax-context stx))
|
|
(let ([attrs (stxclass-attrs (get-stxclass #'s))])
|
|
(with-syntax ([(a ...) (map attr-name attrs)]
|
|
[(depth ...) (map attr-depth attrs)])
|
|
#'(quote ((a depth) ...)))))]))
|
|
|
|
(define-syntax (syntax-class-possible-errors stx)
|
|
(syntax-case stx ()
|
|
[(_ s)
|
|
(parameterize ((current-syntax-context stx))
|
|
(with-syntax ([p (stxclass-parser-name (get-stxclass #'s))])
|
|
#'(remove-duplicates
|
|
(map interpret-error-expression
|
|
(parser-errors p)))))]))
|
|
|
|
(define-syntax (debug-rhs stx)
|
|
(syntax-case stx ()
|
|
[(debug-rhs rhs)
|
|
(let ([rhs (parse-rhs #'rhs #f #f #:context stx)])
|
|
#`(quote #,rhs))]))
|
|
|
|
(define-syntax (debug-pattern stx)
|
|
(syntax-case stx ()
|
|
[(debug-pattern p)
|
|
(let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)])
|
|
#`(quote #,p))]))
|
|
|
|
(define-syntax-rule (debug-parse x p)
|
|
(let/ec escape
|
|
(parameterize ((current-failure-handler
|
|
(lambda (_ f)
|
|
(escape (failure->sexpr f)
|
|
(failure->sexpr (simplify-failure f))))))
|
|
(syntax-parse x [p 'success]))))
|
|
|
|
(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 #,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 #,stx))))]))
|
|
|
|
(define-syntax with-patterns
|
|
(syntax-rules ()
|
|
[(with-patterns () . b)
|
|
(let () . b)]
|
|
[(with-patterns ([p x] . more) . b)
|
|
(syntax-parse x [p (with-patterns more . b)])]))
|