ef1f77c33f
cleaned up representation of big (localaction) contexts unitized hiding impl added (broken/experimental) navigation tools (jump, zoom) svn: r5468
124 lines
3.9 KiB
Scheme
124 lines
3.9 KiB
Scheme
|
|
(module steps mzscheme
|
|
(require "deriv.ss")
|
|
|
|
;; A ReductionSequence is a (list-of Reduction)
|
|
|
|
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context)
|
|
|
|
;; A Context is a list of Frames
|
|
;; A Frame is (syntax -> syntax)
|
|
|
|
;; A BigContext is (list-of BigFrame)
|
|
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
|
|
(define-struct bigframe (deriv ctx foci e))
|
|
|
|
;; A Reduction is one of
|
|
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
|
|
;; - (make-misstep ... Syntax Syntax Exception)
|
|
|
|
(define-struct protostep (deriv lctx type ctx) #f)
|
|
|
|
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
|
|
(define-struct (misstep protostep) (foci1 e1 exn) #f)
|
|
|
|
;; context-fill : Context Syntax -> Syntax
|
|
(define (context-fill ctx stx)
|
|
(let loop ([ctx ctx] [stx stx])
|
|
(if (null? ctx)
|
|
stx
|
|
(loop (cdr ctx) ((car ctx) stx)))))
|
|
|
|
(define (step-term1 s)
|
|
(context-fill (protostep-ctx s) (step-e1 s)))
|
|
(define (step-term2 s)
|
|
(context-fill (protostep-ctx s) (step-e2 s)))
|
|
|
|
(define (misstep-term1 s)
|
|
(context-fill (protostep-ctx s) (misstep-e1 s)))
|
|
|
|
(define (bigframe-term bf)
|
|
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
|
|
|
|
;; A StepType is a simple in the following alist.
|
|
|
|
(define step-type-meanings
|
|
'((macro-step . "Macro transformation")
|
|
|
|
(rename-lambda . "Rename formal parameters")
|
|
(rename-case-lambda . "Rename formal parameters")
|
|
(rename-let-values . "Rename bound variables")
|
|
(rename-letrec-values . "Rename bound variables")
|
|
(rename-lsv . "Rename bound variables")
|
|
(lsv-remove-syntax . "Remove syntax bindings")
|
|
|
|
(resolve-variable . "Resolve variable (remove extra marks)")
|
|
(tag-module-begin . "Tag #%module-begin")
|
|
(tag-app . "Tag application")
|
|
(tag-datum . "Tag datum")
|
|
(tag-top . "Tag top-level variable")
|
|
(capture-lifts . "Capture lifts")
|
|
|
|
(local-lift . "Macro lifted expression to top-level")
|
|
(module-lift . "Macro lifted declaration to end of module")
|
|
(block->letrec . "Transform block to letrec")
|
|
(splice-block . "Splice block-level begin")
|
|
(splice-module . "Splice module-level begin")
|
|
(splice-lifts . "Splice definitions from lifted expressions")
|
|
(splice-module-lifts . "Splice lifted module declarations")
|
|
|
|
(error . "Error")))
|
|
|
|
(define (step-type->string x)
|
|
(cond [(assq x step-type-meanings) => cdr]
|
|
[(string? x) x]
|
|
[else (error 'step-type->string "not a step type: ~s" x)]))
|
|
|
|
(define (rename-step? x)
|
|
(memq (protostep-type x)
|
|
'(rename-lambda
|
|
rename-case-lambda
|
|
rename-let-values
|
|
rename-letrec-values
|
|
rename-lsv)))
|
|
|
|
(define (rewrite-step? x)
|
|
(and (step? x) (not (rename-step? x))))
|
|
|
|
(provide (all-defined))
|
|
|
|
#;(begin
|
|
(require (lib "contract.ss"))
|
|
(provide rewrite-step?
|
|
rename-step?)
|
|
(provide/contract
|
|
[step-type->string (any/c . -> . string?)]
|
|
[step-term1 (step? . -> . syntax?)]
|
|
[step-term2 (step? . -> . syntax?)]
|
|
[misstep-term1 (misstep? . -> . syntax?)]
|
|
[context-fill ((listof procedure?) syntax? . -> . syntax?)]
|
|
(struct protostep
|
|
([deriv deriv?]
|
|
[lctx list?]
|
|
[type (or/c symbol? boolean?)]
|
|
[ctx (listof procedure?)]))
|
|
(struct (step protostep)
|
|
([deriv deriv?]
|
|
[lctx list?]
|
|
[type (or/c symbol? boolean?)]
|
|
[ctx (listof procedure?)]
|
|
[foci1 (listof syntax?)]
|
|
[foci2 (listof syntax?)]
|
|
[e1 syntax?]
|
|
[e2 syntax?]))
|
|
(struct (misstep protostep)
|
|
([deriv deriv?]
|
|
[lctx list?]
|
|
[type (or/c symbol? boolean?)]
|
|
[ctx (listof procedure?)]
|
|
[foci1 (listof syntax?)]
|
|
[e1 syntax?]
|
|
[exn exn?])))
|
|
)
|
|
)
|