yacc-interrupted.rkt (11849B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 racket/syntax) 4 "yacc-ext.rkt") 5 (provide ! ? !! 6 define-production-splitter 7 skipped-token-values 8 %skipped 9 %action) 10 11 ;; Grammar macros for "interrupted parses" 12 13 (define-syntax ! 14 (lambda (stx) 15 (raise-syntax-error #f "keyword ! used out of context" stx))) 16 17 (define-syntax !! 18 (lambda (stx) 19 (raise-syntax-error #f "keyword !! used out of context" stx))) 20 21 (define-syntax ? 22 (lambda (stx) 23 (raise-syntax-error #f "keyword ? used out of context" stx))) 24 25 (define-syntax define-production-splitter 26 (syntax-rules () 27 [(define-production-splitter name ok intW) 28 (define-syntax name 29 (make-production-splitter #'ok #'intW))])) 30 31 (define-for-syntax (partition-options/alternates forms) 32 (let loop ([forms forms] [options null] [alts null]) 33 (if (pair? forms) 34 (syntax-case (car forms) () 35 [(#:args . args) 36 (loop (cdr forms) (cons (cons '#:args #'args) options) alts)] 37 [(#:skipped expr) 38 (loop (cdr forms) (cons (cons '#:skipped #'expr) options) alts)] 39 [(#:wrap) 40 (loop (cdr forms) (cons (cons '#:wrap #t) options) alts)] 41 [(#:no-wrap) 42 (loop (cdr forms) (cons (cons '#:no-wrap #t) options) alts)] 43 [(kw . args) 44 (keyword? (syntax-e #'kw)) 45 (raise-syntax-error 'split "bad keyword" (car forms))] 46 [(pattern action) 47 (loop (cdr forms) options (cons (cons #'pattern #'action) alts))] 48 [other 49 (raise-syntax-error 'split "bad grammar option or alternate" #'other)]) 50 (values options (reverse alts))))) 51 52 (define-for-syntax (mk-name ctx n) 53 (datum->syntax ctx (string->symbol (format "~a" n)) ctx)) 54 55 (define-for-syntax (mk-$name ctx n) 56 (mk-name ctx (format "$~a" n))) 57 58 (define-for-syntax (interrupted-name id) 59 (datum->syntax id (format-symbol "~a/Interrupted" (syntax-e id)) id)) 60 61 (define-for-syntax (skipped-name id) 62 (datum->syntax id (format-symbol "~a/Skipped" (syntax-e id)) id)) 63 64 (define-for-syntax (elaborate-skipped-tail head tail position args mk-action) 65 (define-values (new-tail new-arguments) 66 (let loop ([parts tail] [position position] [rtail null] [arguments null]) 67 (syntax-case parts (? ! !!) 68 [() 69 (values (reverse rtail) (reverse arguments))] 70 [(! . parts-rest) 71 (loop #'parts-rest position rtail (cons #'#f arguments))] 72 [(!! . parts-rest) 73 (raise-syntax-error 'split 74 "cannot have !! after potential error" 75 #'!!)] 76 [((? NT) . parts-rest) 77 (loop #'(NT . parts-rest) position rtail arguments)] 78 [(NT . parts-rest) 79 (identifier? #'NT) 80 (loop #'parts-rest 81 (add1 position) 82 (cons (skipped-name #'NT) rtail) 83 (cons (mk-$name #'NT position) arguments))]))) 84 (define arguments (append (reverse args) new-arguments)) 85 (cons #`(#,head . #,new-tail) 86 (mk-action arguments))) 87 88 (define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt) 89 (define pattern (car alt)) 90 (define action-function (cdr alt)) 91 (define-values (new-patterns arguments) 92 (let loop ([parts pattern] [rpattern null] [position 1] [args null]) 93 (syntax-case parts (? ! !!) 94 [() (values (list (reverse rpattern)) (reverse args))] 95 [(! . parts-rest) 96 (loop #'parts-rest rpattern position (cons #'#f args))] 97 [(!!) 98 (values null null)] 99 [((? NT) . parts-rest) 100 (loop (cons #'NT #'parts-rest) rpattern position args)] 101 [(NT . parts-rest) 102 (identifier? #'NT) 103 (loop #'parts-rest (cons #'NT rpattern) 104 (add1 position) (cons (mk-$name #'NT position) args))]))) 105 (map (lambda (new-pattern) 106 (cons (datum->syntax #f new-pattern pattern) 107 #`(#,action-function #,(if wrap? okW #'values) #,@arguments))) 108 new-patterns)) 109 110 (define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt) 111 (define pattern (car alt)) 112 (define action-function (cdr alt)) 113 (define (int-action args) 114 (let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)]) 115 #`(#,action-function #,wrapf #,@args))) 116 (let loop ([parts pattern] [position 1] [args null]) 117 (syntax-case parts (? ! !!) 118 [() 119 ;; Can't be interrupted 120 null] 121 [(! . parts-rest) 122 (cons 123 ;; Error occurs 124 (let ([id (mk-name (car (syntax-e parts)) 'syntax-error)]) 125 (elaborate-skipped-tail id 126 #'parts-rest 127 (add1 position) 128 (cons (mk-$name id position) args) 129 int-action)) 130 ;; Error doesn't occur 131 (loop #'parts-rest position (cons #'#f args)))] 132 [(!!) 133 (cons 134 (let ([id (mk-name (car (syntax-e parts)) 'syntax-error)]) 135 (elaborate-skipped-tail id 136 #'() 137 (add1 position) 138 (cons (mk-$name id position) args) 139 int-action)) 140 null)] 141 [((? NT) . parts-rest) 142 (cons 143 ;; NT is interrupted 144 (elaborate-skipped-tail (interrupted-name #'NT) 145 #'parts-rest 146 (add1 position) 147 (cons (mk-$name #'NT position) args) 148 int-action) 149 ;; NT is not interrupted 150 (loop #'(NT . parts-rest) position args))] 151 [(part0 . parts-rest) 152 (identifier? #'part0) 153 (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause))) 154 (loop #'parts-rest (add1 position) (cons (mk-$name #'part0 position) 155 args)))]))) 156 157 (define-for-syntax (generate-action-name nt pos) 158 (syntax-local-get-shadower 159 (format-id #f "action-for-~a/~a" (syntax-e nt) pos))) 160 161 (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) 162 (define pattern (car alt)) 163 (define action (cdr alt)) 164 (define variables 165 (let loop ([pattern pattern] [n 1] [vars null]) 166 (syntax-case pattern () 167 [(first . more) 168 (syntax-case #'first (! ? !!) 169 [! 170 (loop #'more (add1 n) (cons (mk-$name #'first n) vars))] 171 [(! . _) 172 (raise-syntax-error 'split 173 "misuse of ! grammar form" 174 pattern #'first)] 175 [!! 176 (when (pair? (syntax-e #'more)) 177 (raise-syntax-error 'split 178 "nothing may follow !!" 179 pattern)) 180 (loop #'more (add1 n) (cons (mk-$name #'first n) vars))] 181 [(!! . _) 182 (raise-syntax-error 'split 183 "misuse of !! grammar form" 184 pattern #'first)] 185 [(? NT) 186 (identifier? #'NT) 187 (loop #'more (add1 n) (cons (mk-$name #'NT n) vars))] 188 [(? . _) 189 (raise-syntax-error 'split 190 "misuse of ? grammar form" 191 pattern #'first)] 192 [NT 193 (identifier? #'NT) 194 (loop #'more (add1 n) (cons (mk-$name #'NT n) vars))] 195 [other 196 (raise-syntax-error 'rewrite-pattern 197 "invalid grammar pattern" 198 pattern #'first)])] 199 [() 200 (reverse vars)]))) 201 (define action-function (generate-action-name nt pos)) 202 (cons (cons pattern action-function) 203 (with-syntax ([(var ...) variables] 204 [action-function action-function] 205 [action action]) 206 #`(define (action-function wrap var ...) 207 #,(if args-spec 208 #`(lambda #,args-spec (wrap action)) 209 #`(wrap action)))))) 210 211 (define-for-syntax (invalid-$name-use stx) 212 (raise-syntax-error #f "no value for positional variable" stx)) 213 214 ;; An alternate is (cons pattern action-expr) 215 ;; An alternate* is (cons pattern action-function-name) 216 217 (define-for-syntax ((make-production-splitter okW intW) stx) 218 (syntax-case stx () 219 [(_ (name form ...)) 220 (let () 221 (define-values (options alternates0) 222 (partition-options/alternates (syntax->list #'(form ...)))) 223 (define wrap? 224 (let ([wrap? (assq '#:wrap options)] 225 [no-wrap? (assq '#:no-wrap options)]) 226 (when (and wrap? no-wrap?) 227 (raise-syntax-error 'split 228 "cannot specify both #:wrap and #:no-wrap" 229 stx)) 230 #; 231 (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?))) 232 (raise-syntax-error 'split 233 "must specify exactly one of #:wrap, #:no-wrap" 234 stx)) 235 (and wrap? #t))) 236 (define args-spec 237 (let ([p (assq '#:args options)]) (and p (cdr p)))) 238 (define rewrite-alt+def (make-rewrite-alt+def #'name args-spec)) 239 (define alternates+definitions 240 (map rewrite-alt+def alternates0 (build-list (length alternates0) add1))) 241 (define alternates (map car alternates+definitions)) 242 (define action-definitions (map cdr alternates+definitions)) 243 (define elaborate-successful-alternate 244 (make-elaborate-successful-alternate wrap? okW)) 245 (define elaborate-interrupted-alternate 246 (make-elaborate-interrupted-alternate wrap? intW)) 247 (define successful-alternates 248 (apply append (map elaborate-successful-alternate alternates))) 249 (define interrupted-alternates 250 (apply append (map elaborate-interrupted-alternate alternates))) 251 (with-syntax ([((success-pattern . success-action) ...) 252 successful-alternates] 253 [((interrupted-pattern . interrupted-action) ...) 254 interrupted-alternates] 255 [skip-spec (assq '#:skipped options)] 256 [args-spec (assq '#:args options)] 257 [name/Skipped (skipped-name #'name)] 258 [name/Interrupted (interrupted-name #'name)] 259 [%action ((syntax-local-certifier) #'%action)]) 260 #`(begin 261 (definitions #,@action-definitions) 262 (productions 263 (name [success-pattern success-action] ...) 264 #,(if (pair? interrupted-alternates) 265 #'(name/Interrupted [interrupted-pattern interrupted-action] 266 ...) 267 #'(name/Interrupted [(IMPOSSIBLE) #f])) 268 (name/Skipped [() (%skipped args-spec skip-spec)])))))])) 269 270 (define-syntax (skipped-token-values stx) 271 (syntax-case stx () 272 [(skipped-token-values) 273 #'(begin)] 274 [(skipped-token-values name . more) 275 (identifier? #'name) 276 (with-syntax ([name/Skipped (skipped-name #'name)]) 277 #'(begin (productions (name/Skipped [() #f])) 278 (skipped-token-values . more)))] 279 [(skipped-token-values (name value) . more) 280 (with-syntax ([name/Skipped (skipped-name #'name)]) 281 #'(begin (productions (name/Skipped [() value])) 282 (skipped-token-values . more)))])) 283 284 (define-syntax (%skipped stx) 285 (syntax-case stx () 286 [(%skipped args (#:skipped . expr)) 287 #'(%action args expr)] 288 [(%skipped args #f) 289 #'(%action args #f)])) 290 291 (define-syntax (%action stx) 292 (syntax-case stx () 293 [(%action (#:args . args) action) 294 #'(lambda args action)] 295 [(%action #f action) 296 #'action]))