551 lines
18 KiB
Scheme
551 lines
18 KiB
Scheme
|
|
#lang scheme/base
|
|
(require scheme/match
|
|
"stx-util.ss"
|
|
"deriv-util.ss"
|
|
"context.ss"
|
|
"deriv.ss"
|
|
"reductions-engine.ss")
|
|
|
|
(provide reductions
|
|
reductions+)
|
|
|
|
;; Setup for reduction-engines
|
|
|
|
(define (Expr) reductions*)
|
|
(define (List) list-reductions)
|
|
(define (Block) block-reductions)
|
|
(define (Transformation)
|
|
transformation-reductions)
|
|
(define (BindSyntaxes)
|
|
bind-syntaxes-reductions)
|
|
(define (CaseLambdaClauses)
|
|
case-lambda-clauses-reductions)
|
|
(define (SynthItems)
|
|
synth-items-reductions)
|
|
(define (BRules)
|
|
brules-reductions)
|
|
(define (ModulePass)
|
|
mbrules-reductions)
|
|
|
|
;; Syntax
|
|
|
|
(define-syntax match/with-derivation
|
|
(syntax-rules ()
|
|
[(match/with-derivation d . clauses)
|
|
(let ([dvar d])
|
|
(with-derivation dvar
|
|
(match dvar . clauses)))]))
|
|
|
|
;; Reductions
|
|
|
|
;; reductions : WDeriv -> ReductionSequence
|
|
(define (reductions d)
|
|
(let-values ([(steps definites estx exn) (reductions+ d)])
|
|
steps))
|
|
|
|
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
|
|
(define (reductions+ d)
|
|
(parameterize ((current-definites null)
|
|
(current-frontier null))
|
|
(when d (add-frontier (list (wderiv-e1 d))))
|
|
(let-values ([(steps stx exn) (reductions* d (wderiv-e1 d))])
|
|
(values steps (current-definites) stx exn))))
|
|
|
|
;; reductions* : WDeriv Syntax -> RS(stx)
|
|
(define (reductions* d init-e1)
|
|
(match d
|
|
[(Wrap deriv (e1 e2))
|
|
(begin (blaze-frontier e1)
|
|
(unless (eq? init-e1 e1)
|
|
(void)
|
|
#;(fprintf (current-error-port)
|
|
"starting points don't match:\n~s\n~s\n"
|
|
init-e1 e1)
|
|
#;(error 'reductions* "starting points don't match for: ~s" d)))]
|
|
[_ (void)])
|
|
(match d
|
|
[(Wrap prule (e1 e2 rs ?1))
|
|
(and rs (learn-definites rs))]
|
|
[_ (void)])
|
|
(match/with-derivation d
|
|
;; Primitives
|
|
[(Wrap p:variable (e1 e2 rs ?1))
|
|
(R e1
|
|
[#:learn (list e2)]
|
|
[#:when/np (not (bound-identifier=? e1 e2))
|
|
[#:walk e2 'resolve-variable]])]
|
|
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?module ?name ?language . ?body-parts)]
|
|
#;[#:frontier null (list #'?language #'?body-parts)]
|
|
[! ?2]
|
|
#;[#:frontier (list #'?language) null]
|
|
[#:when/np tag
|
|
[#:walk/ctx ?body-parts
|
|
(list tag)
|
|
'tag-module-begin]]
|
|
[#:pattern (?module ?name ?language ?body)]
|
|
[#:rename* ?body rename]
|
|
[#:when/np check
|
|
[Expr ?body check]]
|
|
[#:when/np tag2
|
|
[#:walk/ctx ?body
|
|
tag2
|
|
'tag-module-begin]]
|
|
[! ?3]
|
|
[Expr ?body body]
|
|
[#:pattern ?form]
|
|
[#:rename* ?form shift])]
|
|
[(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
|
|
(R e1
|
|
[! ?1]
|
|
#;[#:let-values (_) (printf "#%module-begin:\n~s\n" me)]
|
|
[#:pattern ?form]
|
|
[#:rename* ?form me]
|
|
[#:pattern (?module-begin . ?forms)]
|
|
#;[#:frontier (syntax->list #'?forms)]
|
|
#;[#:let-values (_) (printf "#%module-begin ?forms:\n~s\n" #'?forms)]
|
|
[ModulePass ?forms pass1]
|
|
[ModulePass ?forms pass2]
|
|
[! ?1])]
|
|
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?define-syntaxes formals ?rhs)]
|
|
[#:frontier (list #'?rhs)]
|
|
[Expr ?rhs rhs]
|
|
[! ?2])]
|
|
[(Wrap p:define-values (e1 e2 rs ?1 rhs))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?define-values ?formals ?rhs)]
|
|
[#:frontier (list #'?rhs)]
|
|
;; RHS can be #f (eg, modprim)
|
|
[#:when/np rhs
|
|
[Expr ?rhs rhs]])]
|
|
[(Wrap p:#%expression (e1 e2 rs ?1 inner))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?expr ?inner)]
|
|
[#:frontier (list #'?inner)]
|
|
[Expr ?inner inner])]
|
|
[(Wrap p:if (e1 e2 rs ?1 test then else))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?if TEST THEN ELSE)]
|
|
[#:frontier (list #'TEST #'THEN #'ELSE)]
|
|
[Expr TEST test]
|
|
[Expr THEN then]
|
|
[Expr ELSE else])]
|
|
[(Wrap p:wcm (e1 e2 rs ?1 key mark body))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?wcm KEY MARK BODY)]
|
|
[#:frontier (list #'KEY #'MARK #'BODY)]
|
|
[Expr KEY key]
|
|
[Expr MARK mark]
|
|
[Expr BODY body])]
|
|
[(Wrap p:begin (e1 e2 rs ?1 lderiv))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?begin . ?lderiv)]
|
|
[#:frontier (stx->list* #'?lderiv)]
|
|
[List ?lderiv lderiv])]
|
|
[(Wrap p:begin0 (e1 e2 rs ?1 first lderiv))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?begin0 FIRST . LDERIV)]
|
|
[#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
|
|
[Expr FIRST first]
|
|
[List LDERIV lderiv])]
|
|
[(Wrap p:#%app (e1 e2 rs ?1 lderiv))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?app . LDERIV)]
|
|
[#:frontier (stx->list* #'LDERIV)]
|
|
[List LDERIV lderiv])]
|
|
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?lambda ?formals . ?body)]
|
|
[#:frontier (stx->list* #'?body)]
|
|
[#:rename* (?formals . ?body) renames 'rename-lambda]
|
|
[Block ?body body])]
|
|
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?case-lambda . ?clauses)]
|
|
[#:frontier (stx->list* #'?clauses)]
|
|
[CaseLambdaClauses ?clauses clauses])]
|
|
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
|
|
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
|
|
[#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
|
|
[Expr (?rhs ...) rhss]
|
|
[Block ?body body])]
|
|
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
|
|
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
|
|
[#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
|
|
[Expr (?rhs ...) rhss]
|
|
[Block ?body body])]
|
|
[(Wrap p:letrec-syntaxes+values
|
|
(e1 e2 rs ?1 srenames srhss vrenames vrhss body))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
|
|
[#:frontier (append (syntax->list #'(?srhs ...))
|
|
(syntax->list #'(?vrhs ...))
|
|
(stx->list* #'?body))]
|
|
[#:rename* (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) srenames
|
|
'rename-lsv]
|
|
[BindSyntaxes (?srhs ...) srhss]
|
|
;; If vrenames is #f, no var bindings to rename
|
|
[#:when/np vrenames
|
|
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
|
|
[#:rename* (((?vars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
|
|
[Expr (?vrhs ...) vrhss]
|
|
[Block ?body body]
|
|
[#:pattern ?form]
|
|
[#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison?
|
|
[#:walk e2 'lsv-remove-syntax]])]
|
|
|
|
[(Wrap p:#%datum (e1 e2 rs ?1))
|
|
(R e1
|
|
[! ?1]
|
|
[#:walk e2 'macro])]
|
|
[(Wrap p:#%top (e1 e2 rs ?1))
|
|
(R e1
|
|
[#:pattern (?top . ?var)]
|
|
[#:learn (list #'?var)]
|
|
[! ?1])]
|
|
|
|
[(Wrap p:provide (e1 e2 rs ?1))
|
|
(R e1
|
|
[! ?1]
|
|
[#:walk e2 'provide])]
|
|
|
|
;; The rest of the automatic primitives
|
|
[(Wrap p::STOP (e1 e2 rs ?1))
|
|
(R e1
|
|
[! ?1])]
|
|
|
|
[(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
|
|
(R e1
|
|
[! ?1]
|
|
[#:frontier (list e1)]
|
|
[#:pattern ?form]
|
|
[Expr ?form deriv])]
|
|
[(Wrap p:set! (e1 e2 rs ?1 id-rs rhs))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern (?set! ?var ?rhs)]
|
|
[#:frontier (list #'?rhs)]
|
|
[#:learn id-rs]
|
|
[Expr ?rhs rhs])]
|
|
|
|
;; Synthetic primitives
|
|
;; These have their own subterm replacement mechanisms
|
|
[(Wrap p:synth (e1 e2 rs ?1 subterms ?2))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern ?form]
|
|
[#:frontier
|
|
;; Compute the frontier based on the expanded subterms
|
|
;; Run through the renames in reverse order to get the
|
|
;; pre-renamed terms
|
|
(parameterize ((current-frontier null))
|
|
(let loop ([subterms subterms])
|
|
(cond [(null? subterms)
|
|
(void)]
|
|
[(s:subterm? (car subterms))
|
|
(loop (cdr subterms))
|
|
(add-frontier
|
|
(list (wderiv-e1 (s:subterm-deriv (car subterms)))))]
|
|
[(s:rename? (car subterms))
|
|
(loop (cdr subterms))
|
|
(rename-frontier (s:rename-after (car subterms))
|
|
(s:rename-before (car subterms)))]))
|
|
(current-frontier))]
|
|
[SynthItems ?form subterms]
|
|
[! ?2])]
|
|
|
|
;; FIXME: elimiate => ??
|
|
[(Wrap p:rename (e1 e2 rs ?1 rename inner))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern ?form]
|
|
=>
|
|
(lambda (e)
|
|
(rename-frontier (car rename) (cdr rename))
|
|
(reductions* inner (wderiv-e1 inner))))]
|
|
|
|
;; Macros
|
|
[(Wrap mrule (e1 e2 transformation next))
|
|
(R e1
|
|
[#:pattern ?form]
|
|
[Transformation ?form transformation]
|
|
[#:frontier (list (wderiv-e1 next))]
|
|
[Expr ?form next])]
|
|
|
|
[(Wrap tagrule (e1 e2 tagged-stx next))
|
|
(R e1
|
|
[#:pattern ?form]
|
|
[#:walk tagged-stx
|
|
(case (syntax-e (stx-car tagged-stx))
|
|
((#%app) 'tag-app)
|
|
((#%datum) 'tag-datum)
|
|
((#%top) 'tag-top)
|
|
(else
|
|
(error 'reductions "unknown tagged syntax: ~s" tagged-stx)))]
|
|
[Expr ?form next])]
|
|
|
|
;; Lifts
|
|
|
|
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
|
|
(R e1
|
|
[#:pattern ?form]
|
|
[Expr ?form first]
|
|
[#:frontier (list lifted-stx)]
|
|
[#:walk lifted-stx 'capture-lifts]
|
|
[Expr ?form second])]
|
|
|
|
[(Wrap lift/let-deriv (e1 e2 first lifted-stx second))
|
|
(R e1
|
|
[#:pattern ?form]
|
|
[Expr ?form first]
|
|
[#:frontier (list lifted-stx)]
|
|
[#:walk lifted-stx 'capture-lifts]
|
|
[Expr ?form second])]
|
|
|
|
;; Skipped
|
|
[#f (RSunit init-e1)]))
|
|
|
|
;; case-lambda-clauses-reductions :
|
|
;; (list-of (W (list ?exn rename (W BDeriv)))) stxs -> (RS stxs)
|
|
(define (case-lambda-clauses-reductions clauses es1)
|
|
(blaze-frontier es1)
|
|
(match clauses
|
|
['()
|
|
(RSunit null)]
|
|
[(cons (Wrap clc (?1 rename body)) rest)
|
|
(R es1
|
|
[! ?1]
|
|
[#:pattern ((?formals . ?body) . ?rest)]
|
|
[#:frontier (list #'?body #'?rest)]
|
|
[#:rename* (?formals . ?body) rename 'rename-case-lambda]
|
|
[Block ?body body]
|
|
[CaseLambdaClauses ?rest rest])]))
|
|
|
|
;; synth-items-reductions : (list-of SynthItem) syntax -> (RS syntax)
|
|
(define (synth-items-reductions subterms e1)
|
|
(let loop ([term e1] [subterms subterms])
|
|
(cond [(null? subterms)
|
|
(RSunit e1)]
|
|
[(s:subterm? (car subterms))
|
|
(let* ([subterm0 (car subterms)]
|
|
[path0 (s:subterm-path subterm0)]
|
|
[deriv0 (s:subterm-deriv subterm0)])
|
|
(let ([ctx (lambda (x) (path-replace term path0 x))]
|
|
;; unused: may not be the same, due to mark/unmark???
|
|
[init-e (path-get term path0)])
|
|
(RSseq (lambda ()
|
|
(with-context ctx
|
|
(reductions* deriv0 (wderiv-e1 deriv0))))
|
|
(lambda ()
|
|
(loop (path-replace term path0 (wderiv-e2 deriv0))
|
|
(cdr subterms))))))]
|
|
[(s:rename? (car subterms))
|
|
(let* ([subterm0 (car subterms)])
|
|
;; FIXME: add renaming steps?
|
|
;; FIXME: if so, coalesce?
|
|
(rename-frontier (s:rename-before subterm0)
|
|
(s:rename-after subterm0))
|
|
(loop (path-replace term
|
|
(s:rename-path subterm0)
|
|
(s:rename-after subterm0))
|
|
(cdr subterms)))])))
|
|
|
|
;; transformation-reductions : Transformation stx -> (RS Stx)
|
|
(define (transformation-reductions tx init-e1)
|
|
(match tx
|
|
[(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 seq))
|
|
(R e1
|
|
[! ?1]
|
|
[#:pattern ?form]
|
|
[#:learn rs]
|
|
[#:reductions (reductions-locals e1 locals)]
|
|
[! ?2]
|
|
[#:walk e2 'macro])]))
|
|
|
|
;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
|
|
(define (reductions-locals stx locals)
|
|
(with-new-local-context stx
|
|
(RSforeach reductions-local locals)))
|
|
|
|
;; reductions-local : LocalAction -> (RS void)
|
|
(define (reductions-local local)
|
|
(match/with-derivation local
|
|
[(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque))
|
|
;; FIXME
|
|
;; When lifted is present, need to locally rearrange lifts!
|
|
(when (or lifted opaque)
|
|
(fprintf (current-error-port)
|
|
"reductions: local-expand-expr not fully implemented"))
|
|
(reductions* deriv me1)]
|
|
[(struct local-lift (expr id))
|
|
(RSadd (list (walk expr id 'local-lift))
|
|
RSzero)]
|
|
[(struct local-lift-end (decl))
|
|
(RSadd (list (walk/mono decl 'module-lift))
|
|
RSzero)]
|
|
[(struct local-bind (names bindrhs))
|
|
(bind-syntaxes-reductions bindrhs)]))
|
|
|
|
;; list-reductions : ListDerivation stxs -> (RS Stxs)
|
|
(define (list-reductions ld init-es1)
|
|
(match/with-derivation ld
|
|
[(Wrap lderiv (es1 es2 ?1 derivs))
|
|
(R es1
|
|
[! ?1]
|
|
[#:pattern (?form ...)]
|
|
[Expr (?form ...) derivs])]
|
|
[#f (RSunit null)]))
|
|
|
|
;; block-reductions : BlockDerivation stxs -> (RS Stxs)
|
|
(define (block-reductions bd init-es1)
|
|
(match/with-derivation bd
|
|
[(Wrap bderiv (es1 es2 pass1 trans pass2))
|
|
(R es1
|
|
[#:pattern ?form]
|
|
[BRules ?form pass1]
|
|
[#:when/np (eq? trans 'letrec)
|
|
[#:walk (wlderiv-es1 pass2) 'block->letrec]]
|
|
[#:frontier (stx->list* (wlderiv-es1 pass2))]
|
|
[#:pattern ?form]
|
|
[List ?form pass2])]
|
|
[#f (RSunit null)]))
|
|
|
|
;; brules-reductions : (list-of BRule) stxs -> (RS Stxs)
|
|
(define (brules-reductions brules es1)
|
|
(match brules
|
|
['()
|
|
(RSunit null)]
|
|
[(cons (Wrap b:expr (renames head)) rest)
|
|
(R es1
|
|
[#:pattern (?first . ?rest)]
|
|
[#:bind ?first* (cdr renames)]
|
|
[#:rename/no-step ?first (car renames) (cdr renames)]
|
|
[Expr ?first head]
|
|
[BRules ?rest rest])]
|
|
[(cons (Wrap b:defvals (renames head ?1)) rest)
|
|
(R es1
|
|
[#:pattern (?first . ?rest)]
|
|
[#:bind ?first* (cdr renames)]
|
|
[#:rename/no-step ?first (car renames) (cdr renames)]
|
|
[Expr ?first head]
|
|
[! ?1]
|
|
[#:pattern ((?define-values ?vars ?rhs) . ?rest)]
|
|
[#:learn (syntax->list #'?vars)]
|
|
[BRules ?rest rest])]
|
|
[(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest)
|
|
(R es1
|
|
[#:pattern (?first . ?rest)]
|
|
[#:bind ?first* (cdr renames)]
|
|
[#:rename/no-step ?first (car renames) (cdr renames)]
|
|
[Expr ?first head]
|
|
[! ?1]
|
|
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
|
|
[#:learn (syntax->list #'?vars)]
|
|
[BindSyntaxes ?rhs bindrhs]
|
|
[BRules ?rest rest])]
|
|
[(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
|
|
(R es1
|
|
[#:pattern (?first . ?rest)]
|
|
[#:bind ?first* (cdr renames)]
|
|
[#:rename/no-step ?first (car renames) (cdr renames)]
|
|
[Expr ?first head]
|
|
[! ?1]
|
|
[#:walk/foci tail
|
|
(list #'?first)
|
|
(stx-take tail (- (stx-improper-length tail)
|
|
(stx-improper-length #'?rest)))
|
|
'splice-block]
|
|
[! ?2]
|
|
[#:pattern ?forms]
|
|
[BRules ?forms rest])]
|
|
[(cons (Wrap b:error (exn)) rest)
|
|
(R es1
|
|
[! exn])]))
|
|
|
|
;; bind-syntaxes-reductions : BindSyntaxes stx -> (RS stx)
|
|
(define (bind-syntaxes-reductions bindrhs init-e1)
|
|
(match bindrhs
|
|
[(Wrap bind-syntaxes (rhs ?1))
|
|
(R (wderiv-e1 rhs)
|
|
[#:pattern ?form]
|
|
[Expr ?form rhs]
|
|
[! ?1])]))
|
|
|
|
;; mbrules-reductions : -> (list-of MBRule) stxs -> (RS stxs)
|
|
(define (mbrules-reductions mbrules es1)
|
|
(match mbrules
|
|
['()
|
|
(RSunit null)]
|
|
[(cons (Wrap mod:prim (head rename prim)) rest)
|
|
(R es1
|
|
[#:pattern (?firstP . ?rest)]
|
|
[Expr ?firstP head]
|
|
[#:rename* ?firstP rename]
|
|
[Expr ?firstP prim]
|
|
[ModulePass ?rest rest])]
|
|
[(cons (Wrap mod:splice (head rename ?1 tail)) rest)
|
|
(R es1
|
|
[#:pattern (?firstB . ?rest)]
|
|
[Expr ?firstB head]
|
|
[#:rename* ?firstB rename]
|
|
[! ?1]
|
|
[#:walk/foci tail
|
|
(list #'?firstB)
|
|
(stx-take tail (- (stx-improper-length tail)
|
|
(stx-improper-length #'?rest)))
|
|
'splice-module]
|
|
[#:pattern ?forms]
|
|
[ModulePass ?forms rest])]
|
|
[(cons (Wrap mod:lift (head renames stxs)) rest)
|
|
(R es1
|
|
[#:pattern (?firstL . ?rest)]
|
|
[Expr ?firstL head]
|
|
[#:pattern ?forms]
|
|
[#:when/np renames
|
|
[#:rename* ?forms renames]]
|
|
[#:walk/foci (append stxs #'?forms)
|
|
null
|
|
stxs
|
|
'splice-lifts]
|
|
[ModulePass ?forms rest])]
|
|
[(cons (Wrap mod:lift-end (stxs)) rest)
|
|
(R es1
|
|
[#:pattern ?forms]
|
|
[#:when/np (pair? stxs)
|
|
[#:walk/foci (append stxs #'?forms)
|
|
null
|
|
stxs
|
|
'splice-module-lifts]]
|
|
[ModulePass ?forms rest])]
|
|
[(cons (Wrap mod:skip ()) rest)
|
|
(R es1
|
|
[#:pattern (?firstS . ?rest)]
|
|
[ModulePass ?rest rest])]
|
|
[(cons (Wrap mod:cons (head)) rest)
|
|
(R es1
|
|
[#:pattern (?firstC . ?rest)]
|
|
[Expr ?firstC head]
|
|
[ModulePass ?rest rest])]))
|