steps.rkt (3724B)
1 #lang racket/base 2 (provide (struct-out protostep) 3 (struct-out step) 4 (struct-out misstep) 5 (struct-out remarkstep) 6 (struct-out state) 7 (struct-out bigframe) 8 context-fill 9 state-term 10 step-term1 11 step-term2 12 misstep-term1 13 bigframe-term 14 step-type? 15 step-type->string 16 rewrite-step? 17 rename-step?) 18 19 ;; A ReductionSequence is (listof Step) 20 ;; A Step is one of 21 ;; - (make-step StepType State State) 22 ;; - (make-misstep StepType State exn) 23 ;; - (make-remarkstep StepType State (listof (U string syntax 'arrow))) 24 (define-struct protostep (type s1) #:transparent) 25 (define-struct (step protostep) (s2) #:transparent) 26 (define-struct (misstep protostep) (exn) #:transparent) 27 (define-struct (remarkstep protostep) (contents) #:transparent) 28 29 ;; A State is 30 ;; (make-state stx stxs Context BigContext (listof id) (listof id) (listof stx) nat/#f) 31 (define-struct state (e foci ctx lctx binders uses frontier seq) #:transparent) 32 33 ;; A Context is a list of Frames 34 ;; A Frame is (syntax -> syntax) 35 36 ;; A BigContext is (list-of BigFrame) 37 ;; A BigFrame is (make-bigframe Context Syntaxes Syntax) 38 (define-struct bigframe (ctx foci e)) 39 40 ;; context-fill : Context Syntax -> Syntax 41 (define (context-fill ctx stx) 42 (datum->syntax 43 #f 44 (let loop ([ctx ctx] [stx stx]) 45 (if (null? ctx) 46 stx 47 (let ([frame0 (car ctx)]) 48 (loop (cdr ctx) (frame0 stx))))))) 49 50 (define (state-term s) 51 (context-fill (state-ctx s) (state-e s))) 52 53 (define (step-term1 s) 54 (state-term (protostep-s1 s))) 55 (define (step-term2 s) 56 (state-term (step-s2 s))) 57 58 (define (misstep-term1 s) 59 (state-term (protostep-s1 s))) 60 61 (define (bigframe-term bf) 62 (context-fill (bigframe-ctx bf) (bigframe-e bf))) 63 64 ;; A StepType is a simple in the following alist. 65 66 (define step-type-meanings 67 '((macro . "Macro transformation") 68 69 (rename-lambda . "Rename formal parameters") 70 (rename-case-lambda . "Rename formal parameters") 71 (rename-let-values . "Rename bound variables") 72 (rename-letrec-values . "Rename bound variables") 73 (rename-lsv . "Rename bound variables") 74 (lsv-remove-syntax . "Remove syntax bindings") 75 76 (resolve-variable . "Resolve variable (remove extra marks)") 77 (tag-module-begin . "Tag #%module-begin") 78 (tag-app . "Tag application") 79 (tag-datum . "Tag datum") 80 (tag-top . "Tag top-level variable") 81 (capture-lifts . "Capture lifts") 82 (provide . "Expand provide-specs") 83 84 (local-lift . "Macro lifted expression to top-level") 85 (module-lift . "Macro lifted declaration to end of module") 86 (block->letrec . "Transform block to letrec") 87 (splice-block . "Splice block-level begin") 88 (splice-module . "Splice module-level begin") 89 (splice-lifts . "Splice definitions from lifted expressions") 90 (splice-module-lifts . "Splice lifted module declarations") 91 92 (remark . "Macro made a remark") 93 (track-origin . "Macro called syntax-track-origin") 94 95 (error . "Error"))) 96 97 (define (step-type->string x) 98 (cond [(assq x step-type-meanings) => cdr] 99 [(string? x) x] 100 [else (error 'step-type->string "not a step type: ~s" x)])) 101 102 (define step-type? 103 (let ([step-types (map car step-type-meanings)]) 104 (lambda (x) 105 (and (memq x step-types) #t)))) 106 107 (define (rename-step? x) 108 (memq (protostep-type x) 109 '(rename-lambda 110 rename-case-lambda 111 rename-let-values 112 rename-letrec-values 113 rename-lsv 114 track-origin))) 115 116 (define (rewrite-step? x) 117 (and (step? x) (not (rename-step? x))))