ddd-forms.rkt (6142B)
1 #lang racket/base 2 (provide begin 3 let 4 #%intdef-begin 5 (rename-out [app #%app]) 6 ?? 7 ?if 8 ?cond 9 ?attr 10 ?@ 11 ?@@ 12 splice-append 13 splice-append* 14 splicing-list? 15 splicing-list 16 splicing-list-l) 17 18 (require racket/list 19 subtemplate/private/ddd 20 stxparse-info/case 21 stxparse-info/parse 22 phc-toolkit/untyped 23 subtemplate/private/copy-attribute 24 (for-meta -2 subtemplate/private/syntax-case-as-syntax-parse) 25 (for-meta -1 subtemplate/private/syntax-case-as-syntax-parse) 26 (for-meta 0 subtemplate/private/syntax-case-as-syntax-parse) 27 (for-meta 1 subtemplate/private/syntax-case-as-syntax-parse) 28 (for-meta 2 subtemplate/private/syntax-case-as-syntax-parse) 29 (for-meta 3 subtemplate/private/syntax-case-as-syntax-parse) 30 (prefix-in - (only-in racket/base 31 begin let lambda define)) 32 (prefix-in - (only-in stxparse-info/case 33 define/with-syntax)) 34 (prefix-in - (only-in stxparse-info/parse 35 define/syntax-parse 36 syntax-parse)) 37 (for-syntax racket/base 38 racket/list 39 stxparse-info/parse 40 stxparse-info/parse/experimental/template 41 phc-toolkit/untyped) 42 (for-meta 2 racket/base) 43 (for-meta 2 phc-toolkit/untyped) 44 (for-meta 2 stxparse-info/parse)) 45 46 (begin-for-syntax 47 (define (-nest* wrapper -v -ooo* [depth 0]) 48 (if (stx-null? -ooo*) 49 -v 50 (-nest* wrapper 51 (wrapper -v) 52 (stx-cdr -ooo*) 53 (add1 depth)))) 54 55 (define-syntax nest* 56 (syntax-parser 57 [(self wrapper-stx v ooo*) 58 (with-syntax ([s (datum->syntax #'self 'syntax)] 59 [qs (datum->syntax #'self 'quasisyntax)]) 60 #`(-nest* (λ (new-v) 61 (with-syntax ([#,(datum->syntax #'self '%) new-v]) 62 (qs wrapper-stx))) 63 (s v) 64 (s ooo*)))])) 65 66 (define-syntax ddd* 67 (syntax-parser 68 [(_ e ooo*) 69 #'(with-syntax ([dotted (nest* (ddd %) e ooo*)]) 70 (nest* (append* %) 71 (list dotted) 72 ooo*))])) 73 74 (define-syntax-class ooo 75 (pattern {~and ooo {~literal …}})) 76 77 (define-splicing-syntax-class ooo+ 78 #:attributes (ooo*) 79 (pattern {~seq {~and ooo {~literal …}} …+} 80 #:with ooo* #'(ooo …))) 81 82 (define-syntax-class not-macro-id 83 #:attributes () 84 (pattern id:id 85 #:when (not (syntax-local-value #'id (λ () #f)))) 86 (pattern id:id 87 #:when (syntax-pattern-variable? 88 (syntax-local-value #'id (λ () #f))))) 89 90 (define-syntax-class not-macro-expr 91 #:attributes () 92 (pattern :not-macro-id) 93 (pattern (:not-macro-id . _))) 94 95 (define-splicing-syntax-class stmt 96 #:literals (define define/with-syntax -define/syntax-parse) 97 (pattern {~seq (define name:id e:expr) :ooo+} 98 #:with expanded 99 #`(-define name 100 #,(nest* (ddd %) e ooo*))) 101 (pattern {~seq (define/with-syntax pat e:expr) :ooo+} 102 #:with expanded 103 #`(-define/syntax-parse 104 #,(nest* (… {~and {~or (% …) #f}}) ({~syntax-case pat}) ooo*) 105 #,(nest* (ddd % #:allow-missing) (list e) ooo*))) 106 (pattern {~seq (-define/syntax-parse pat e:expr) :ooo+} 107 ;; Same as above, except that pat is not wrapped with ~syntax-case. 108 #:with expanded 109 #`(-define/syntax-parse 110 #,(nest* (… {~and {~or (% …) #f}}) (pat) ooo*) 111 #,(nest* (ddd % #:allow-missing) (list e) ooo*))) 112 (pattern {~seq e :ooo+} 113 ;#:with expanded #`(apply values #,(ddd* e ooo*)) 114 #:with expanded #`(splicing-list #,(ddd* e ooo*))) 115 (pattern other 116 #:with expanded #'other))) 117 118 (define-syntax/parse (begin stmt:stmt …) 119 (template (-begin (?@ stmt.expanded) …))) 120 121 (define-syntax #%intdef-begin (make-rename-transformer #'begin)) 122 123 (define-syntax/parse (let {~optional name:id} ([var . val] …) . body) 124 (template (-let (?? name) ([var (begin . val)] …) (#%intdef-begin . body)))) 125 126 (begin-for-syntax 127 (define-splicing-syntax-class arg 128 (pattern {~seq e:expr ooo*:ooo+} 129 #:with expanded #`(splicing-list #,(ddd* e ooo*))) 130 (pattern other 131 ;#:with expanded #'(#%app list other) 132 #:with expanded #'other)) 133 (define-syntax-class not-stx-pair 134 (pattern () #:with v #''()) 135 (pattern {~and v {~not (_ . _)}}))) 136 (define-syntax app 137 (syntax-parser 138 [{~and (_ fn arg:arg … . rest:not-stx-pair) 139 {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a … 140 ;#'(#%app apply fn (#%app append arg.expanded …)) 141 (syntax/top-loc this-syntax 142 (#%plain-app apply fn (#%plain-app splice-append-nokw rest.v arg.expanded …)))] 143 [(_ arg:arg … . rest:not-stx-pair) ;; shorthand for list creation 144 ;#'(#%app apply list (#%app append arg.expanded …)) 145 #;(syntax/top-loc this-syntax 146 (#%plain-app apply list 147 (#%plain-app splice-append-nokw rest.v arg.expanded …))) 148 ;; (apply list v) is a no-op asside from error handling. 149 (syntax/top-loc this-syntax 150 (#%plain-app splice-append-nokw rest.v arg.expanded …))])) 151 152 (define (splice-append #:rest [rest '()] . l*) 153 (splice-append* (if (null? rest) l* (append l* rest)))) 154 (define (splice-append-nokw rest . l*) 155 (splice-append* (if (null? rest) l* (append l* rest)))) 156 (define (splice-append* l*) 157 (cond 158 [(pair? l*) 159 (if (splicing-list? (car l*)) 160 (splice-append* (append (splicing-list-l (car l*)) 161 (cdr l*))) 162 (cons (car l*) (splice-append* (cdr l*))))] 163 [(splicing-list? l*) 164 (splice-append* (splicing-list-l l*))] 165 [else ;; should be null. 166 l*]))