552 lines
16 KiB
Racket
552 lines
16 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base)
|
|
syntax/stx
|
|
"yacc-ext.rkt"
|
|
"yacc-interrupted.rkt"
|
|
"deriv.rkt"
|
|
"deriv-util.rkt"
|
|
"deriv-tokens.rkt")
|
|
(provide parse-derivation)
|
|
|
|
(define (deriv-error ok? name value start end)
|
|
(if ok?
|
|
(error 'derivation-parser
|
|
"error on token #~a: <~s, ~s>"
|
|
start name value)
|
|
(error 'derivation-parser "bad token #~a" start)))
|
|
|
|
;; PARSER
|
|
|
|
(define-production-splitter production/I values values)
|
|
|
|
(define-syntax (productions/I stx)
|
|
(syntax-case stx ()
|
|
[(productions/I def ...)
|
|
#'(begin (production/I def) ...)]))
|
|
|
|
(define parse-derivation
|
|
(parser
|
|
(options (start Expansion)
|
|
(src-pos)
|
|
(tokens basic-tokens prim-tokens renames-tokens)
|
|
(end EOF)
|
|
#|(debug "/tmp/ryan/DEBUG-PARSER.txt")|#
|
|
(error deriv-error))
|
|
|
|
;; tokens
|
|
(skipped-token-values
|
|
visit resolve next next-group return
|
|
enter-macro macro-pre-transform macro-post-transform exit-macro
|
|
enter-prim exit-prim
|
|
enter-block block->list block->letrec splice
|
|
enter-list exit-list
|
|
enter-check exit-check
|
|
local-post exit-local exit-local/expr
|
|
local-bind enter-bind exit-bind
|
|
local-value-result
|
|
phase-up module-body
|
|
renames-lambda
|
|
renames-case-lambda
|
|
renames-let
|
|
renames-letrec-syntaxes
|
|
renames-block
|
|
rename-one
|
|
rename-list
|
|
tag
|
|
IMPOSSIBLE
|
|
start
|
|
top-non-begin)
|
|
|
|
;; Entry point
|
|
(productions
|
|
(Expansion
|
|
[(start EE/Lifts) $2]
|
|
[(start EE/Lifts/Interrupted) $2]
|
|
[(start ExpandCTE) $2]
|
|
[(start ExpandCTE/Interrupted) $2]))
|
|
|
|
(productions/I
|
|
|
|
(ExpandCTE
|
|
;; The first 'Eval' is there for---I believe---lazy phase 1 initialization.
|
|
[(visit start (? Eval) (? CheckImmediateMacro/Lifts)
|
|
top-non-begin start (? EE) (? Eval) return)
|
|
(make ecte $1 $9 $3 $4 $7 $8)]
|
|
[(visit start Eval CheckImmediateMacro/Lifts
|
|
top-begin (? NextExpandCTEs) return)
|
|
(begin
|
|
(unless (list? $6)
|
|
(error "NextExpandCTEs returned non-list ~s" $6))
|
|
(make ecte $1 $7 $3 $4
|
|
(make p:begin $5 $7 (list (stx-car $5)) #f
|
|
(make lderiv (cdr (stx->list $5))
|
|
(and $7 (cdr (stx->list $7)))
|
|
#f
|
|
$6))
|
|
null))])
|
|
|
|
(CheckImmediateMacro/Lifts
|
|
[((? CheckImmediateMacro))
|
|
$1]
|
|
[(CheckImmediateMacro lift-loop)
|
|
(let ([e1 (wderiv-e1 $1)]
|
|
[e2 $2])
|
|
(make lift-deriv e1 e2 $1 $2 (make p:stop $2 $2 null #f)))])
|
|
|
|
(NextExpandCTEs
|
|
(#:skipped null)
|
|
[() null]
|
|
[(next (? ExpandCTE) (? NextExpandCTEs)) (cons $2 $3)])
|
|
|
|
;; Expand with possible lifting
|
|
(EE/Lifts
|
|
[((? EE)) $1]
|
|
[(EE lift-loop (? EE/Lifts))
|
|
(let ([e1 (wderiv-e1 $1)]
|
|
[e2 (wderiv-e2 $3)])
|
|
(make lift-deriv e1 e2 $1 $2 $3))])
|
|
|
|
;; Expand, convert lifts to let (rhs of define-syntaxes, mostly)
|
|
(EE/LetLifts
|
|
[((? EE)) $1]
|
|
[(EE lift/let-loop (? EE/LetLifts))
|
|
(let ([initial (wderiv-e1 $1)]
|
|
[final (wderiv-e2 $3)])
|
|
(make lift/let-deriv initial final $1 $2 $3))])
|
|
|
|
;; Evaluation
|
|
;; Answer = (listof LocalAction)
|
|
(Eval
|
|
[((? LocalActions)) $1])
|
|
|
|
;; Expansion of an expression to primitive form
|
|
(CheckImmediateMacro
|
|
[(enter-check (? CheckImmediateMacro/Inner) exit-check)
|
|
($2 $1 $3)])
|
|
(CheckImmediateMacro/Inner
|
|
(#:args le1 e2)
|
|
[(!)
|
|
(make p:stop le1 e2 null $1)]
|
|
[(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))
|
|
($3 $1 $2 ($5 $4 e2))]
|
|
[(visit Resolves tag (? MacroStep) return (? CheckImmediateMacro/Inner))
|
|
(let ([mnode ($4 $3 $2 ($6 $5 e2))])
|
|
(make tagrule $1 (wderiv-e2 mnode) $3 mnode))])
|
|
|
|
;; Expansion of multiple expressions, next-separated
|
|
(NextEEs
|
|
(#:skipped null)
|
|
[() null]
|
|
[(next (? EE) (? NextEEs)) (cons $2 $3)])
|
|
|
|
;; EE
|
|
|
|
;; Expand expression (term)
|
|
(EE
|
|
[(visit Resolves (? EE/k))
|
|
($3 $1 $2)]
|
|
[(visit Resolves tag (? EE/k))
|
|
(let ([next ($4 $3 $2)])
|
|
(make tagrule $1 (wderiv-e2 next) $3 next))])
|
|
|
|
(EE/k
|
|
(#:args e1 rs)
|
|
[(!!)
|
|
(make p:unknown e1 #f rs $1)]
|
|
[(variable return)
|
|
(make p:variable e1 $2 rs #f)]
|
|
[(enter-prim (? Prim) exit-prim return)
|
|
(begin
|
|
(unless (eq? $3 $4)
|
|
(fprintf (current-error-port)
|
|
"warning: exit-prim and return differ:\n~s\n~s\n"
|
|
$3 $4))
|
|
($2 $1 $3 rs))]
|
|
[((? MacroStep) (? EE))
|
|
($1 e1 rs $2)])
|
|
|
|
(MacroStep
|
|
(#:args e1 rs next)
|
|
[(enter-macro ! macro-pre-transform (? LocalActions)
|
|
macro-post-transform ! exit-macro)
|
|
(make mrule e1 (and next (wderiv-e2 next)) rs $2
|
|
$3 $4 $5 $6 $7 next)])
|
|
|
|
;; Keyword resolution
|
|
(Resolves
|
|
[() null]
|
|
[(resolve Resolves) (cons $1 $2)])
|
|
|
|
;; Local actions taken by macro
|
|
;; LocalAction Answer = (list-of LocalAction)
|
|
(LocalActions
|
|
(#:skipped null)
|
|
[() null]
|
|
[((? LocalAction) (? LocalActions)) (cons $1 $2)])
|
|
|
|
(LocalAction
|
|
[(!!) (make local-exn $1)]
|
|
[(enter-local OptPhaseUp
|
|
local-pre (? LocalExpand/Inner) OptLifted local-post
|
|
OptOpaqueExpr exit-local)
|
|
(make local-expansion $1 $8 $2 $3 $4 $5 $6 $7)]
|
|
[(lift)
|
|
(make local-lift (cdr $1) (car $1))]
|
|
[(lift-statement)
|
|
(make local-lift-end $1)]
|
|
[(lift-require)
|
|
(make local-lift-require (car $1) (cadr $1) (cddr $1))]
|
|
[(lift-provide)
|
|
(make local-lift-provide $1)]
|
|
[(local-bind ! rename-list)
|
|
(make local-bind $1 $2 $3 #f)]
|
|
[(local-bind rename-list (? BindSyntaxes))
|
|
(make local-bind $1 #f $2 $3)]
|
|
[(track-origin)
|
|
(make track-origin (car $1) (cdr $1))]
|
|
[(local-value ! Resolves local-value-result)
|
|
(make local-value $1 $2 $3 $4)]
|
|
[(local-remark)
|
|
(make local-remark $1)]
|
|
[(local-artificial-step)
|
|
(let ([ids (list-ref $1 0)]
|
|
[before (list-ref $1 1)]
|
|
[mbefore (list-ref $1 2)]
|
|
[mafter (list-ref $1 3)]
|
|
[after (list-ref $1 4)])
|
|
(make local-expansion
|
|
before after #f mbefore
|
|
(make mrule mbefore mafter ids #f
|
|
before null after #f mafter
|
|
(make p:stop mafter mafter null #f))
|
|
#f after #f))]
|
|
;; -- Not really local actions, but can occur during evaluation
|
|
;; called 'expand' (not 'local-expand') within transformer
|
|
[(start (? EE)) #f]
|
|
[(start (? CheckImmediateMacro)) #f])
|
|
|
|
(LocalExpand/Inner
|
|
[(start (? EE)) $2]
|
|
[((? CheckImmediateMacro)) $1])
|
|
|
|
(OptLifted
|
|
[(lift-loop) $1]
|
|
[() #f])
|
|
(OptOpaqueExpr
|
|
[(opaque) $1]
|
|
[() #f])
|
|
(OptPhaseUp
|
|
[(phase-up) #t]
|
|
[() #f])
|
|
|
|
(Prim
|
|
(#:args e1 e2 rs)
|
|
[((? PrimModule)) ($1 e1 e2 rs)]
|
|
[((? Prim#%ModuleBegin)) ($1 e1 e2 rs)]
|
|
[((? PrimDefineSyntaxes)) ($1 e1 e2 rs)]
|
|
[((? PrimDefineValues)) ($1 e1 e2 rs)]
|
|
[((? PrimExpression)) ($1 e1 e2 rs)]
|
|
[((? Prim#%App)) ($1 e1 e2 rs)]
|
|
[((? Prim#%Datum)) ($1 e1 e2 rs)]
|
|
[((? Prim#%Top)) ($1 e1 e2 rs)]
|
|
[((? PrimIf)) ($1 e1 e2 rs)]
|
|
[((? PrimWCM)) ($1 e1 e2 rs)]
|
|
[((? PrimSet)) ($1 e1 e2 rs)]
|
|
[((? PrimBegin)) ($1 e1 e2 rs)]
|
|
[((? PrimBegin0)) ($1 e1 e2 rs)]
|
|
[((? PrimLambda)) ($1 e1 e2 rs)]
|
|
[((? PrimCaseLambda)) ($1 e1 e2 rs)]
|
|
[((? PrimLetValues)) ($1 e1 e2 rs)]
|
|
[((? PrimLet*Values)) ($1 e1 e2 rs)]
|
|
[((? PrimLetrecValues)) ($1 e1 e2 rs)]
|
|
[((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)]
|
|
[((? PrimSTOP)) ($1 e1 e2 rs)]
|
|
[((? PrimQuote)) ($1 e1 e2 rs)]
|
|
[((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
|
|
[((? PrimRequire)) ($1 e1 e2 rs)]
|
|
[((? PrimProvide)) ($1 e1 e2 rs)]
|
|
[((? PrimVarRef)) ($1 e1 e2 rs)]
|
|
[((? PrimStratifiedBody)) ($1 e1 e2 rs)])
|
|
|
|
(PrimModule
|
|
(#:args e1 e2 rs)
|
|
[(prim-module ! next (? Eval) OptTag rename-one
|
|
(? OptCheckImmediateMacro) OptTag !
|
|
(? EE) rename-one)
|
|
(make p:module e1 e2 rs $2 $4 $5 $6 $7 $8 $9 $10 $11)])
|
|
(OptTag
|
|
[() #f]
|
|
[(tag) $1])
|
|
(OptCheckImmediateMacro
|
|
[() #f]
|
|
[((? CheckImmediateMacro)) $1])
|
|
|
|
(Prim#%ModuleBegin
|
|
(#:args e1 e2 rs)
|
|
[(prim-#%module-begin ! rename-one
|
|
(? ModulePass1) next-group (? ModulePass2) !)
|
|
(make p:#%module-begin e1 e2 rs $2 $3 $4 $6 $7)])
|
|
|
|
(ModulePass1
|
|
(#:skipped null)
|
|
[() null]
|
|
[(next (? ModulePass1-Part) (? ModulePass1))
|
|
(cons $2 $3)]
|
|
[(module-lift-end-loop (? ModulePass1))
|
|
(cons (make mod:lift-end $1) $2)])
|
|
|
|
(ModulePass1-Part
|
|
[((? EE) rename-one (? ModulePass1/Prim))
|
|
(make mod:prim $1 $2 ($3 $2))]
|
|
[(EE rename-one ! splice)
|
|
(make mod:splice $1 $2 $3 $4)]
|
|
[(EE rename-list module-lift-loop)
|
|
(make mod:lift $1 $2 $3)])
|
|
|
|
(ModulePass1/Prim
|
|
(#:args e1)
|
|
[(enter-prim prim-define-values ! exit-prim)
|
|
(make p:define-values $1 $4 null $3 #f)]
|
|
[(enter-prim prim-define-syntaxes !
|
|
phase-up (? EE/LetLifts) (? Eval) exit-prim)
|
|
(make p:define-syntaxes $1 $7 null $3 $5 $6)]
|
|
[(enter-prim prim-require (? Eval) exit-prim)
|
|
(make p:require $1 $4 null #f $3)]
|
|
[()
|
|
(make p:stop e1 e1 null #f)])
|
|
|
|
(ModulePass2
|
|
(#:skipped null)
|
|
[() null]
|
|
[(next (? ModulePass2-Part) (? ModulePass2))
|
|
(cons $2 $3)]
|
|
[(module-lift-end-loop (? ModulePass2))
|
|
(cons (make mod:lift-end $1) $2)])
|
|
|
|
(ModulePass2-Part
|
|
;; not normal; already handled
|
|
[()
|
|
(make mod:skip)]
|
|
;; provide: special
|
|
[(enter-prim prim-provide (? ModuleProvide/Inner) ! exit-prim)
|
|
(make mod:cons (make p:provide $1 $5 null #f $3 $4))]
|
|
;; normal: expand completely
|
|
[((? EE))
|
|
(make mod:cons $1)]
|
|
;; catch lifts
|
|
[(EE module-lift-loop)
|
|
(make mod:lift $1 #f $2)])
|
|
|
|
(ModuleProvide/Inner
|
|
(#:skipped null)
|
|
[() null]
|
|
[((? EE) (? ModuleProvide/Inner))
|
|
(cons $1 $2)])
|
|
|
|
;; Definitions
|
|
(PrimDefineSyntaxes
|
|
(#:args e1 e2 rs)
|
|
[(prim-define-syntaxes ! (? EE/LetLifts) (? Eval))
|
|
(make p:define-syntaxes e1 e2 rs $2 $3 $4)])
|
|
|
|
(PrimDefineValues
|
|
(#:args e1 e2 rs)
|
|
[(prim-define-values ! (? EE))
|
|
(make p:define-values e1 e2 rs $2 $3)])
|
|
|
|
;; Simple expressions
|
|
(PrimExpression
|
|
(#:args e1 e2 rs)
|
|
[(prim-expression ! (? EE))
|
|
(make p:#%expression e1 e2 rs $2 $3 #f)]
|
|
[(prim-expression EE tag)
|
|
(make p:#%expression e1 e2 rs #f $2 $3)])
|
|
|
|
(PrimIf
|
|
(#:args e1 e2 rs)
|
|
[(prim-if ! (? EE) next (? EE) next (? EE))
|
|
(make p:if e1 e2 rs $2 $3 $5 $7)])
|
|
|
|
(PrimWCM
|
|
(#:args e1 e2 rs)
|
|
[(prim-wcm ! (? EE) next (? EE) next (? EE))
|
|
(make p:wcm e1 e2 rs $2 $3 $5 $7)])
|
|
|
|
;; Sequence-containing expressions
|
|
(PrimBegin
|
|
(#:args e1 e2 rs)
|
|
[(prim-begin ! (? EL))
|
|
(make p:begin e1 e2 rs $2 $3)])
|
|
|
|
(PrimBegin0
|
|
(#:args e1 e2 rs)
|
|
[(prim-begin0 ! next (? EE) next (? EL))
|
|
(make p:begin0 e1 e2 rs $2 $4 $6)])
|
|
|
|
(Prim#%App
|
|
(#:args e1 e2 rs)
|
|
[(prim-#%app !)
|
|
(make p:#%app e1 e2 rs $2 #f)]
|
|
[(prim-#%app (? EL))
|
|
(make p:#%app e1 e2 rs #f $2)])
|
|
|
|
;; Binding expressions
|
|
(PrimLambda
|
|
(#:args e1 e2 rs)
|
|
[(prim-lambda ! renames-lambda (? EB))
|
|
(make p:lambda e1 e2 rs $2 $3 $4)])
|
|
|
|
(PrimCaseLambda
|
|
(#:args e1 e2 rs)
|
|
[(prim-case-lambda ! (? NextCaseLambdaClauses))
|
|
(make p:case-lambda e1 e2 rs $2 $3)])
|
|
|
|
(NextCaseLambdaClauses
|
|
(#:skipped null)
|
|
[(next (? CaseLambdaClause) (? NextCaseLambdaClauses))
|
|
(cons $2 $3)]
|
|
[() null])
|
|
|
|
(CaseLambdaClause
|
|
[(! renames-case-lambda (? EB))
|
|
(make clc $1 $2 $3)])
|
|
|
|
(PrimLetValues
|
|
(#:args e1 e2 rs)
|
|
[(prim-let-values ! renames-let (? NextEEs) next-group (? EB))
|
|
(make p:let-values e1 e2 rs $2 $3 $4 $6)])
|
|
|
|
(PrimLet*Values
|
|
(#:args e1 e2 rs)
|
|
;; let*-values with bindings is "macro-like"
|
|
[(prim-let*-values !!)
|
|
(make mrule e1 e2 rs $2 #f null #f #f #f #f)]
|
|
[(prim-let*-values (? EE))
|
|
(let* ([next-e1 (wderiv-e1 $2)])
|
|
(make mrule e1 e2 rs #f e1 null next-e1 #f next-e1 $2))]
|
|
;; No bindings... model as "let"
|
|
[(prim-let*-values renames-let (? NextEEs) next-group (? EB))
|
|
(make p:let-values e1 e2 rs #f $2 $3 $5)])
|
|
|
|
(PrimLetrecValues
|
|
(#:args e1 e2 rs)
|
|
[(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB))
|
|
(make p:letrec-values e1 e2 rs $2 $3 $4 $6)])
|
|
|
|
(PrimLetrecSyntaxes+Values
|
|
(#:args e1 e2 rs)
|
|
[(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
|
|
(? NextBindSyntaxess) next-group (? EB) OptTag)
|
|
(make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6 $7)]
|
|
[(prim-letrec-syntaxes+values renames-letrec-syntaxes
|
|
NextBindSyntaxess next-group
|
|
prim-letrec-values
|
|
renames-let (? NextEEs) next-group (? EB) OptTag)
|
|
(make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $6 $7 $9 $10)])
|
|
|
|
;; Atomic expressions
|
|
(Prim#%Datum
|
|
(#:args e1 e2 rs)
|
|
[(prim-#%datum !) (make p:#%datum e1 e2 rs $2)])
|
|
|
|
(Prim#%Top
|
|
(#:args e1 e2 rs)
|
|
[(prim-#%top !) (make p:#%top e1 e2 rs $2)])
|
|
|
|
(PrimSTOP
|
|
(#:args e1 e2 rs)
|
|
[(prim-stop !) (make p:stop e1 e2 rs $2)])
|
|
|
|
(PrimQuote
|
|
(#:args e1 e2 rs)
|
|
[(prim-quote !) (make p:quote e1 e2 rs $2)])
|
|
|
|
(PrimQuoteSyntax
|
|
(#:args e1 e2 rs)
|
|
[(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)])
|
|
|
|
(PrimRequire
|
|
(#:args e1 e2 rs)
|
|
[(prim-require (? Eval))
|
|
(make p:require e1 e2 rs #f $2)])
|
|
|
|
(PrimProvide
|
|
(#:args e1 e2 rs)
|
|
[(prim-provide !) (make p:provide e1 e2 rs $2 null #f)])
|
|
|
|
(PrimVarRef
|
|
(#:args e1 e2 rs)
|
|
[(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)])
|
|
|
|
(PrimStratifiedBody
|
|
(#:args e1 e2 rs)
|
|
[(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)])
|
|
|
|
(PrimSet
|
|
(#:args e1 e2 rs)
|
|
;; Unrolled to avoid shift/reduce
|
|
[(prim-set! ! resolve Resolves ! next (? EE))
|
|
(make p:set! e1 e2 rs $2 (cons $3 $4) $5 $7)]
|
|
[(prim-set! Resolves (? MacroStep) (? EE))
|
|
(make p:set!-macro e1 e2 rs #f ($3 e1 $2 $4))])
|
|
|
|
;; Blocks
|
|
;; EB Answer = BlockDerivation
|
|
(EB
|
|
[(enter-block (? BlockPass1) block->list (? EL))
|
|
(make bderiv $1 (and $4 (wlderiv-es2 $4))
|
|
$2 'list $4)]
|
|
[(enter-block BlockPass1 block->letrec (? EL))
|
|
(make bderiv $1 (and $4 (wlderiv-es2 $4))
|
|
$2 'letrec $4)])
|
|
|
|
;; BlockPass1 Answer = (list-of BRule)
|
|
(BlockPass1
|
|
(#:skipped null)
|
|
[() null]
|
|
[((? BRule) (? BlockPass1))
|
|
(cons $1 $2)])
|
|
|
|
;; BRule Answer = BRule
|
|
(BRule
|
|
[(next !!)
|
|
(make b:error $2)]
|
|
[(next renames-block (? CheckImmediateMacro))
|
|
(make b:expr $2 $3)]
|
|
[(next renames-block CheckImmediateMacro prim-begin ! splice !)
|
|
(make b:splice $2 $3 $5 $6 $7)]
|
|
[(next renames-block CheckImmediateMacro prim-define-values ! rename-one !)
|
|
(make b:defvals $2 $3 $5 $6 $7)]
|
|
[(next renames-block CheckImmediateMacro
|
|
prim-define-syntaxes ! rename-one ! (? BindSyntaxes))
|
|
(make b:defstx $2 $3 $5 $6 $7 $8)])
|
|
|
|
;; BindSyntaxes Answer = Derivation
|
|
(BindSyntaxes
|
|
[(enter-bind (? EE/LetLifts) next (? Eval) exit-bind)
|
|
(make bind-syntaxes $2 $4)])
|
|
|
|
;; NextBindSyntaxess Answer = (list-of Derivation)
|
|
(NextBindSyntaxess
|
|
(#:skipped null)
|
|
[() null]
|
|
[(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)])
|
|
|
|
;; Lists
|
|
;; EL Answer = ListDerivation
|
|
(EL
|
|
(#:skipped #f)
|
|
[(enter-list ! (? EL*) exit-list)
|
|
;; FIXME: Workaround for bug in events
|
|
(if (null? $3)
|
|
(make lderiv null null $2 $3)
|
|
(make lderiv $1 $4 $2 $3))])
|
|
|
|
;; EL* Answer = (listof Derivation)
|
|
(EL*
|
|
(#:skipped null)
|
|
[() null]
|
|
[(next (? EE) (? EL*)) (cons $2 $3)])
|
|
|
|
)))
|