/racket-5-0-2-bin-i386-osx-mac-dmg/collects/macro-debugger/model/yacc-interrupted.rkt
Racket | 298 lines | 269 code | 21 blank | 8 comment | 16 complexity | ea88c5a638892c65a0a73faacc8e4a15 MD5 | raw file
Possible License(s): LGPL-2.0
- #lang racket/base
- (require (for-syntax racket/base
- unstable/syntax)
- "yacc-ext.rkt")
- (provide ! ? !!
- define-production-splitter
- skipped-token-values
- %skipped
- %action)
- ;; Grammar macros for "interrupted parses"
- (define-syntax !
- (lambda (stx)
- (raise-syntax-error #f "keyword ! used out of context" stx)))
- (define-syntax !!
- (lambda (stx)
- (raise-syntax-error #f "keyword !! used out of context" stx)))
- (define-syntax ?
- (lambda (stx)
- (raise-syntax-error #f "keyword ? used out of context" stx)))
- (define-syntax define-production-splitter
- (syntax-rules ()
- [(define-production-splitter name ok intW)
- (define-syntax name
- (make-production-splitter #'ok #'intW))]))
- (define-for-syntax (partition-options/alternates forms)
- (let loop ([forms forms] [options null] [alts null])
- (if (pair? forms)
- (syntax-case (car forms) ()
- [(#:args . args)
- (loop (cdr forms) (cons (cons '#:args #'args) options) alts)]
- [(#:skipped expr)
- (loop (cdr forms) (cons (cons '#:skipped #'expr) options) alts)]
- [(#:wrap)
- (loop (cdr forms) (cons (cons '#:wrap #t) options) alts)]
- [(#:no-wrap)
- (loop (cdr forms) (cons (cons '#:no-wrap #t) options) alts)]
- [(kw . args)
- (keyword? (syntax-e #'kw))
- (raise-syntax-error 'split "bad keyword" (car forms))]
- [(pattern action)
- (loop (cdr forms) options (cons (cons #'pattern #'action) alts))]
- [other
- (raise-syntax-error 'split "bad grammar option or alternate" #'other)])
- (values options (reverse alts)))))
- (define-for-syntax (I symbol)
- (syntax-local-introduce
- (syntax-local-get-shadower (datum->syntax #f symbol))))
- (define-for-syntax ($name n)
- (I (format-symbol "$~a" n)))
- (define-for-syntax (interrupted-name id)
- (I (format-symbol "~a/Interrupted" (syntax-e id))))
- (define-for-syntax (skipped-name id)
- (I (format-symbol "~a/Skipped" (syntax-e id))))
- (define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
- (define-values (new-tail new-arguments)
- (let loop ([parts tail] [position position] [rtail null] [arguments null])
- (syntax-case parts (? ! !!)
- [()
- (values (reverse rtail) (reverse arguments))]
- [(! . parts-rest)
- (loop #'parts-rest position rtail (cons #'#f arguments))]
- [(!! . parts-rest)
- (raise-syntax-error 'split
- "cannot have !! after potential error"
- #'!!)]
- [((? NT) . parts-rest)
- (loop #'(NT . parts-rest) position rtail arguments)]
- [(NT . parts-rest)
- (identifier? #'NT)
- (loop #'parts-rest
- (add1 position)
- (cons (skipped-name #'NT) rtail)
- (cons ($name position) arguments))])))
- (define arguments (append (reverse args) new-arguments))
- (cons #`(#,head . #,new-tail)
- (mk-action arguments)))
- (define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
- (define pattern (car alt))
- (define action-function (cdr alt))
- (define-values (new-patterns arguments)
- (let loop ([parts pattern] [rpattern null] [position 1] [args null])
- (syntax-case parts (? ! !!)
- [() (values (list (reverse rpattern)) (reverse args))]
- [(! . parts-rest)
- (loop #'parts-rest rpattern position (cons #'#f args))]
- [(!!)
- (values null null)]
- [((? NT) . parts-rest)
- (loop (cons #'NT #'parts-rest) rpattern position args)]
- [(NT . parts-rest)
- (identifier? #'NT)
- (loop #'parts-rest (cons #'NT rpattern)
- (add1 position) (cons ($name position) args))])))
- (map (lambda (new-pattern)
- (cons (datum->syntax #f new-pattern pattern)
- #`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
- new-patterns))
- (define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
- (define pattern (car alt))
- (define action-function (cdr alt))
- (define (int-action args)
- (let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)])
- #`(#,action-function #,wrapf #,@args)))
- (let loop ([parts pattern] [position 1] [args null])
- (syntax-case parts (? ! !!)
- [()
- ;; Can't be interrupted
- null]
- [(! . parts-rest)
- (cons
- ;; Error occurs
- (elaborate-skipped-tail (I 'syntax-error)
- #'parts-rest
- (add1 position)
- (cons ($name position) args)
- int-action)
- ;; Error doesn't occur
- (loop #'parts-rest position (cons #'#f args)))]
- [(!!)
- (cons
- (elaborate-skipped-tail (I 'syntax-error)
- #'()
- (add1 position)
- (cons ($name position) args)
- int-action)
- null)]
- [((? NT) . parts-rest)
- (cons
- ;; NT is interrupted
- (elaborate-skipped-tail (interrupted-name #'NT)
- #'parts-rest
- (add1 position)
- (cons ($name position) args)
- int-action)
- ;; NT is not interrupted
- (loop #'(NT . parts-rest) position args))]
- [(part0 . parts-rest)
- (identifier? #'part0)
- (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
- (loop #'parts-rest (add1 position) (cons ($name position) args)))])))
- (define-for-syntax (generate-action-name nt pos)
- (syntax-local-get-shadower
- (format-id #f "action-for-~a/~a" (syntax-e nt) pos)))
- (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
- (define pattern (car alt))
- (define action (cdr alt))
- (define-values (var-indexes non-var-indexes)
- (let loop ([pattern pattern] [n 1] [vars null] [nonvars null])
- (syntax-case pattern ()
- [(first . more)
- (syntax-case #'first (! ? !!)
- [!
- (loop #'more (add1 n) (cons n vars) nonvars)]
- [(! . _)
- (raise-syntax-error 'split
- "misuse of ! grammar form"
- pattern #'first)]
- [!!
- (when (pair? (syntax-e #'more))
- (raise-syntax-error 'split
- "nothing may follow !!"
- pattern))
- (loop #'more (add1 n) (cons n vars) nonvars)]
- [(!! . _)
- (raise-syntax-error 'split
- "misuse of !! grammar form"
- pattern #'first)]
- [(? NT)
- (identifier? #'NT)
- (loop #'more (add1 n) (cons n vars) nonvars)]
- [(? . _)
- (raise-syntax-error 'split
- "misuse of ? grammar form"
- pattern #'first)]
- [NT
- (identifier? #'NT)
- (loop #'more (add1 n) (cons n vars) nonvars)]
- [other
- (raise-syntax-error 'rewrite-pattern
- "invalid grammar pattern"
- pattern #'first)])]
- [()
- (values (reverse vars) (reverse nonvars))])))
- (define variables (map $name var-indexes))
- (define non-var-names (map $name non-var-indexes))
- (define action-function (generate-action-name nt pos))
- (cons (cons pattern action-function)
- (with-syntax ([(var ...) variables]
- [(nonvar ...) non-var-names]
- [action-function action-function]
- [action action])
- #`(define (action-function wrap var ...)
- (let-syntax ([nonvar invalid-$name-use] ...)
- #,(if args-spec
- #`(lambda #,args-spec (wrap action))
- #`(wrap action)))))))
- (define-for-syntax (invalid-$name-use stx)
- (raise-syntax-error #f "no value for positional variable" stx))
- ;; An alternate is (cons pattern action-expr)
- ;; An alternate* is (cons pattern action-function-name)
- (define-for-syntax ((make-production-splitter okW intW) stx)
- (syntax-case stx ()
- [(_ (name form ...))
- (let ()
- (define-values (options alternates0)
- (partition-options/alternates (syntax->list #'(form ...))))
- (define wrap?
- (let ([wrap? (assq '#:wrap options)]
- [no-wrap? (assq '#:no-wrap options)])
- (when (and wrap? no-wrap?)
- (raise-syntax-error 'split
- "cannot specify both #:wrap and #:no-wrap"
- stx))
- #;
- (unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
- (raise-syntax-error 'split
- "must specify exactly one of #:wrap, #:no-wrap"
- stx))
- (and wrap? #t)))
- (define args-spec
- (let ([p (assq '#:args options)]) (and p (cdr p))))
- (define rewrite-alt+def (make-rewrite-alt+def #'name args-spec))
- (define alternates+definitions
- (map rewrite-alt+def alternates0 (build-list (length alternates0) add1)))
- (define alternates (map car alternates+definitions))
- (define action-definitions (map cdr alternates+definitions))
- (define elaborate-successful-alternate
- (make-elaborate-successful-alternate wrap? okW))
- (define elaborate-interrupted-alternate
- (make-elaborate-interrupted-alternate wrap? intW))
- (define successful-alternates
- (apply append (map elaborate-successful-alternate alternates)))
- (define interrupted-alternates
- (apply append (map elaborate-interrupted-alternate alternates)))
- (with-syntax ([((success-pattern . success-action) ...)
- successful-alternates]
- [((interrupted-pattern . interrupted-action) ...)
- interrupted-alternates]
- [skip-spec (assq '#:skipped options)]
- [args-spec (assq '#:args options)]
- [name/Skipped (skipped-name #'name)]
- [name/Interrupted (interrupted-name #'name)]
- [%action ((syntax-local-certifier) #'%action)])
- #`(begin
- (definitions #,@action-definitions)
- (productions
- (name [success-pattern success-action] ...)
- #,(if (pair? interrupted-alternates)
- #'(name/Interrupted [interrupted-pattern interrupted-action]
- ...)
- #'(name/Interrupted [(IMPOSSIBLE) #f]))
- (name/Skipped [() (%skipped args-spec skip-spec)])))))]))
- (define-syntax (skipped-token-values stx)
- (syntax-case stx ()
- [(skipped-token-values)
- #'(begin)]
- [(skipped-token-values name . more)
- (identifier? #'name)
- (with-syntax ([name/Skipped (skipped-name #'name)])
- #'(begin (productions (name/Skipped [() #f]))
- (skipped-token-values . more)))]
- [(skipped-token-values (name value) . more)
- (with-syntax ([name/Skipped (skipped-name #'name)])
- #'(begin (productions (name/Skipped [() value]))
- (skipped-token-values . more)))]))
- (define-syntax (%skipped stx)
- (syntax-case stx ()
- [(%skipped args (#:skipped . expr))
- #'(%action args expr)]
- [(%skipped args #f)
- #'(%action args #f)]))
- (define-syntax (%action stx)
- (syntax-case stx ()
- [(%action (#:args . args) action)
- #'(lambda args action)]
- [(%action #f action)
- #'action]))