139 lines
4.6 KiB
Racket
139 lines
4.6 KiB
Racket
#lang racket/base
|
|
(provide begin
|
|
let
|
|
#%intdef-begin
|
|
(rename-out [app #%app])
|
|
??
|
|
?if
|
|
?cond
|
|
?attr
|
|
?@
|
|
?@@
|
|
splice-append
|
|
splice-append*
|
|
splicing-list?
|
|
splicing-list
|
|
splicing-list-l)
|
|
|
|
(require racket/list
|
|
subtemplate/private/ddd
|
|
stxparse-info/case
|
|
stxparse-info/parse
|
|
phc-toolkit/untyped
|
|
(prefix-in - (only-in racket/base
|
|
begin let lambda define))
|
|
(prefix-in - (only-in stxparse-info/case
|
|
define/with-syntax))
|
|
(for-syntax racket/base
|
|
racket/list
|
|
stxparse-info/parse
|
|
stxparse-info/parse/experimental/template
|
|
phc-toolkit/untyped)
|
|
(for-meta 2 racket/base)
|
|
(for-meta 2 phc-toolkit/untyped)
|
|
(for-meta 2 stxparse-info/parse))
|
|
|
|
(begin-for-syntax
|
|
(define (-nest* before after -v -ooo* [depth 0])
|
|
(if (stx-null? -ooo*)
|
|
-v
|
|
(-nest* before
|
|
after
|
|
#`(#,@(syntax->list before) #,-v . #,after)
|
|
(stx-cdr -ooo*)
|
|
(add1 depth))))
|
|
|
|
(define-syntax nest*
|
|
(syntax-parser
|
|
[(self (before … {~datum %} . after) v ooo*)
|
|
(with-syntax ([s (datum->syntax #'self 'syntax)])
|
|
#'(-nest* (s ((… …) (before …))) (s ((… …) after)) (s v) (s ooo*)))]))
|
|
|
|
(define-syntax ddd*
|
|
(syntax-parser
|
|
[(_ e ooo*)
|
|
#'(with-syntax ([dotted (nest* (ddd %) e ooo*)])
|
|
(nest* (append* %)
|
|
(list dotted)
|
|
ooo*))]))
|
|
|
|
(define-syntax-class ooo
|
|
(pattern {~and ooo {~literal …}}))
|
|
|
|
(define-splicing-syntax-class ooo+
|
|
#:attributes (ooo*)
|
|
(pattern {~seq {~and ooo {~literal …}} …+}
|
|
#:with ooo* #'(ooo …)))
|
|
|
|
(define-syntax-class not-macro-id
|
|
#:attributes ()
|
|
(pattern id:id
|
|
#:when (not (syntax-local-value #'id (λ () #f))))
|
|
(pattern id:id
|
|
#:when (syntax-pattern-variable?
|
|
(syntax-local-value #'id (λ () #f)))))
|
|
|
|
(define-syntax-class not-macro-expr
|
|
#:attributes ()
|
|
(pattern :not-macro-id)
|
|
(pattern (:not-macro-id . _)))
|
|
|
|
(define-splicing-syntax-class stmt
|
|
#:literals (define define/with-syntax)
|
|
(pattern {~seq (define name:id e:expr) :ooo+}
|
|
#:with expanded
|
|
#`(-define name
|
|
#,(nest* (ddd %) e ooo*)))
|
|
(pattern {~seq (define/with-syntax pat e:expr) :ooo+}
|
|
#:with expanded
|
|
#`(-define/with-syntax #,(nest* (% …) pat ooo*)
|
|
#,(nest* (ddd %) e ooo*)))
|
|
(pattern {~seq e :ooo+}
|
|
;#:with expanded #`(apply values #,(ddd* e ooo*))
|
|
#:with expanded #`(splicing-list #,(ddd* e ooo*)))
|
|
(pattern other
|
|
#:with expanded #'other)))
|
|
|
|
(define-syntax/parse (begin stmt:stmt …)
|
|
(template (-begin (?@ stmt.expanded) …)))
|
|
|
|
(define-syntax #%intdef-begin (make-rename-transformer #'begin))
|
|
|
|
(define-syntax/parse (let {~optional name:id} ([var . val] …) . body)
|
|
(template (-let (?? name) ([var (begin . val)] …) (#%intdef-begin . body))))
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class arg
|
|
(pattern {~seq e:expr ooo*:ooo+}
|
|
#:with expanded #`(splicing-list #,(ddd* e ooo*)))
|
|
(pattern other
|
|
;#:with expanded #'(#%app list other)
|
|
#:with expanded #'other))
|
|
(define-syntax-class not-stx-pair
|
|
(pattern () #:with v #''())
|
|
(pattern {~and v {~not (_ . _)}})))
|
|
(define-syntax app
|
|
(syntax-parser
|
|
[{~and (_ fn arg:arg … . rest:not-stx-pair)
|
|
{~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
|
|
;#'(#%app apply fn (#%app append arg.expanded …))
|
|
(syntax/top-loc this-syntax
|
|
(#%app apply fn (#%app splice-append arg.expanded … #:rest rest.v)))]
|
|
[(_ arg:arg … . rest:not-stx-pair) ;; shorthand for list creation
|
|
;#'(#%app apply list (#%app append arg.expanded …))
|
|
(syntax/top-loc this-syntax
|
|
(#%app apply list (#%app splice-append arg.expanded … #:rest rest.v)))]))
|
|
|
|
(define (splice-append #:rest [rest '()] . l*)
|
|
(splice-append* (if (null? rest) l* (append l* rest))))
|
|
(define (splice-append* l*)
|
|
(cond
|
|
[(pair? l*)
|
|
(if (splicing-list? (car l*))
|
|
(splice-append* (append (splicing-list-l (car l*))
|
|
(cdr l*)))
|
|
(cons (car l*) (splice-append* (cdr l*))))]
|
|
[(splicing-list? l*)
|
|
(splice-append* (splicing-list-l l*))]
|
|
[else ;; should be null.
|
|
l*])) |