Added events for lift-to-let
Added rename-tracking to macro hiding svn: r4339
This commit is contained in:
Ryan Culpepper
parent
883d5e6bd5
commit
4c41e5515d
|
|
@ -6,9 +6,11 @@
|
|||
;; - a PRule
|
||||
;; - (make-mrule syntax syntax Transformation Derivation)
|
||||
;; - (make-lift-deriv syntax syntax Derivation syntax Derivation)
|
||||
;; - (make-lift/let-deriv syntax syntax Derivation syntax Derivation)
|
||||
(define-struct deriv (e1 e2) #f)
|
||||
(define-struct (mrule deriv) (transformation next) #f)
|
||||
(define-struct (lift-deriv deriv) (first lift-stx second) #f)
|
||||
(define-struct (lift/let-deriv deriv) (first lift-stx second) #f)
|
||||
|
||||
;; A Transformation is
|
||||
;; (make-transformation syntax syntax (listof identifier) syntax syntax (listof LocalAction))
|
||||
|
|
@ -85,9 +87,9 @@
|
|||
|
||||
;; A Subterm is one of
|
||||
;; - (make-s:subterm Path Derivation)
|
||||
;; - (make-s:rename Path Syntax Syntax)
|
||||
(define-struct s:subterm (path deriv) #f)
|
||||
|
||||
|
||||
(define-struct s:rename (path before after) #f)
|
||||
|
||||
;; A ListDerivation is (make-lderiv Syntaxes Syntaxes (listof Derivation))
|
||||
(define-struct lderiv (es1 es2 derivs) #f)
|
||||
|
|
|
|||
|
|
@ -77,6 +77,20 @@
|
|||
(let ([initial (deriv-e1 $1)]
|
||||
[final (and (deriv? $3) (deriv-e2 $3))])
|
||||
(make-lift-deriv initial final $1 $2 $3))])
|
||||
|
||||
|
||||
;; Expand/LetLifts
|
||||
;; Expand/LetLifts Answer = Derivation (I)
|
||||
;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly)
|
||||
(EE/LetLifts
|
||||
(#:no-wrap)
|
||||
[((? EE)) $1]
|
||||
[((? EE/LetLifts+)) $1])
|
||||
(EE/LetLifts+
|
||||
[(EE lift/let-loop (? EE/LetLifts))
|
||||
(let ([initial (deriv-e1 $1)]
|
||||
[final (and (deriv? $3) (deriv-e2 $3))])
|
||||
(make-lift/let-deriv initial final $1 $2 $3))])
|
||||
|
||||
;; Evaluation
|
||||
(Eval
|
||||
|
|
@ -133,7 +147,7 @@
|
|||
(make-local-lift (car $1) (cdr $1))]
|
||||
[(lift-statement)
|
||||
(make-local-lift-end $1)]
|
||||
[(phase-up (? EE/Lifts))
|
||||
[(phase-up (? EE/LetLifts))
|
||||
(make-local-bind $2)])
|
||||
|
||||
;; Multiple calls to local-expand
|
||||
|
|
@ -240,7 +254,7 @@
|
|||
(ModulePass1/Prim
|
||||
[(enter-prim prim-define-values ! exit-prim)
|
||||
(make-p:define-values $1 $4 null #f)]
|
||||
[(enter-prim prim-define-syntaxes ! phase-up (? EE/Lifts) exit-prim)
|
||||
[(enter-prim prim-define-syntaxes ! phase-up (? EE/LetLifts) exit-prim)
|
||||
(make-p:define-syntaxes $1 $6 null $5)]
|
||||
[(enter-prim prim-require ! exit-prim)
|
||||
(make-p:require $1 $4 null)]
|
||||
|
|
@ -276,7 +290,7 @@
|
|||
;; Definitions
|
||||
(PrimDefineSyntaxes
|
||||
(#:args e1 e2 rs)
|
||||
[(prim-define-syntaxes ! (? EE/Lifts))
|
||||
[(prim-define-syntaxes ! (? EE/LetLifts))
|
||||
(make-p:define-syntaxes e1 e2 rs $3)])
|
||||
|
||||
(PrimDefineValues
|
||||
|
|
@ -447,7 +461,7 @@
|
|||
|
||||
;; BindSyntaxes Answer = Derivation
|
||||
(BindSyntaxes
|
||||
[(phase-up (? EE/Lifts) Eval) $2])
|
||||
[(phase-up (? EE/LetLifts) Eval) $2])
|
||||
|
||||
;; NextBindSyntaxess Answer = (list-of Derivation)
|
||||
(NextBindSyntaxess
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@
|
|||
EOF ; .
|
||||
syntax-error ; exn
|
||||
lift-loop ; syntax
|
||||
lift/let-loop ; syntax
|
||||
lift-end-loop ; syntax
|
||||
lift ; (cons syntax id)
|
||||
lift-statement ; syntax
|
||||
|
|
@ -128,6 +129,7 @@
|
|||
(133 . ,token-local-post)
|
||||
(134 . ,token-lift-statement)
|
||||
(135 . ,token-lift-end-loop)
|
||||
(136 . ,token-lift/let-loop)
|
||||
))
|
||||
|
||||
(define (tokenize sig-n val pos)
|
||||
|
|
|
|||
|
|
@ -51,6 +51,12 @@
|
|||
[first deriv?]
|
||||
[lift-stx syntax?]
|
||||
[second (anyq deriv?)]))
|
||||
(struct (lift/let-deriv deriv)
|
||||
([e1 syntax?]
|
||||
[e2 syntax/f]
|
||||
[first deriv?]
|
||||
[lift-stx syntax?]
|
||||
[second (anyq deriv?)]))
|
||||
(struct transformation
|
||||
([e1 syntax?]
|
||||
[e2 syntax/f]
|
||||
|
|
@ -86,6 +92,7 @@
|
|||
(provide ;(struct deriv (e1 e2))
|
||||
;(struct mrule (transformation next))
|
||||
;(struct lift-deriv (first lift-stx second))
|
||||
;(struct lift/let-deriv (first lift-stx second))
|
||||
|
||||
;(struct transformation (e1 e2 resolves me1 me2 locals))
|
||||
|
||||
|
|
@ -127,6 +134,7 @@
|
|||
|
||||
(struct p:synth (subterms))
|
||||
(struct s:subterm (path deriv))
|
||||
(struct s:rename (path before after))
|
||||
|
||||
;(struct lderiv (es1 es2 derivs))
|
||||
(struct bderiv (es1 es2 pass1 trans pass2))
|
||||
|
|
|
|||
|
|
@ -12,10 +12,11 @@
|
|||
#;
|
||||
(provide hide/policy
|
||||
hide
|
||||
seek/syntax
|
||||
macro-policy)
|
||||
#;seek/syntax
|
||||
macro-policy
|
||||
current-hiding-warning-handler)
|
||||
|
||||
;; hide : Derivation (identifier -> boolean) -> (values Derivation syntax)
|
||||
;; hide/policy : Derivation (identifier -> boolean) -> (values Derivation syntax)
|
||||
(define (hide/policy deriv show-macro?)
|
||||
(parameterize ((macro-policy show-macro?))
|
||||
(hide deriv)))
|
||||
|
|
@ -200,29 +201,43 @@
|
|||
#f)]))))]
|
||||
[(AnyQ p:lambda (e1 e2 rs renames body))
|
||||
(>>P d (make-p:lambda renames body)
|
||||
(lambda formals . BODY)
|
||||
([for-bderiv BODY body]))]
|
||||
|
||||
(lambda FORMALS . BODY)
|
||||
([for-rename (FORMALS . _B) renames]
|
||||
[for-bderiv BODY body]))]
|
||||
|
||||
[(AnyQ p:case-lambda (e1 e2 rs renames+bodies))
|
||||
(>>P d (make-p:case-lambda renames+bodies)
|
||||
(case-lambda [formals . BODY] ...)
|
||||
([for-cdr-bderivs (BODY ...) renames+bodies]))]
|
||||
(let ([var-renames (map car renames+bodies)])
|
||||
(>>P d (make-p:case-lambda renames+bodies)
|
||||
(case-lambda [FORMALS . BODY] ...)
|
||||
([for-renames (FORMALS ...) var-renames]
|
||||
[for-cdr-bderivs (BODY ...) renames+bodies])))]
|
||||
|
||||
[(AnyQ p:let-values (e1 e2 rs renames rhss body))
|
||||
(>>P d (make-p:let-values renames rhss body)
|
||||
(let-values ([VARS RHS] ...) . BODY)
|
||||
([for-derivs (RHS ...) rhss] [for-bderiv BODY body]))]
|
||||
(let ([var-renames (map stx-car (stx-car renames))])
|
||||
(>>P d (make-p:let-values renames rhss body)
|
||||
(let-values ([VARS RHS] ...) . BODY)
|
||||
([for-renames (VARS ...) var-renames]
|
||||
[for-derivs (RHS ...) rhss]
|
||||
[for-bderiv BODY body])))]
|
||||
|
||||
[(AnyQ p:letrec-values (e1 e2 rs renames rhss body))
|
||||
(>>P d (make-p:letrec-values renames rhss body)
|
||||
(letrec-values ([VARS RHS] ...) . BODY)
|
||||
([for-derivs (RHS ...) rhss] [for-bderiv BODY body]))]
|
||||
(let ([var-renames (map stx-car (stx-car renames))])
|
||||
(>>P d (make-p:letrec-values renames rhss body)
|
||||
(letrec-values ([VARS RHS] ...) . BODY)
|
||||
([for-renames (VARS ...) var-renames]
|
||||
[for-derivs (RHS ...) rhss]
|
||||
[for-bderiv BODY body])))]
|
||||
|
||||
[(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
|
||||
(>>Pn d (make-p:letrec-syntaxes+values srenames srhss vrenames vrhss body)
|
||||
(letrec-syntaxes+values ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY)
|
||||
([for-derivs (SRHS ...) srhss]
|
||||
[for-derivs (VRHS ...) vrhss]
|
||||
[for-bderiv BODY body]))]
|
||||
(let ([svar-renames (map stx-car (stx-car srenames))]
|
||||
[vvar-renames (map stx-car (stx-car vrenames))])
|
||||
(>>Pn d (make-p:letrec-syntaxes+values srenames srhss vrenames vrhss body)
|
||||
(letrec-syntaxes+values ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY)
|
||||
([for-renames (SVARS ...) svar-renames]
|
||||
[for-renames (VVARS ...) vvar-renames]
|
||||
[for-derivs (SRHS ...) srhss]
|
||||
[for-derivs (VRHS ...) vrhss]
|
||||
[for-bderiv BODY body])))]
|
||||
[(AnyQ p:#%datum (e1 e2 rs tagged-stx))
|
||||
(cond [(or (eq? tagged-stx e1) (show-macro? #'#%datum))
|
||||
(values d e2)]
|
||||
|
|
@ -279,6 +294,14 @@
|
|||
|
||||
[#f (values #f #f)]))
|
||||
|
||||
;; for-rename : Rename -> (values Rename syntax)
|
||||
(define (for-rename rename)
|
||||
(values rename rename))
|
||||
|
||||
;; for-renames : (list-of Rename) -> (values (list-of Rename) syntaxes)
|
||||
(define (for-renames renames)
|
||||
(values renames renames))
|
||||
|
||||
;; for-derivs : (list-of Derivation) -> (values (list-of Derivation) (list-of syntax))
|
||||
(define (for-derivs derivs)
|
||||
(let ([results
|
||||
|
|
@ -342,6 +365,7 @@
|
|||
;; Does track the syntax through renaming, however.
|
||||
;; Returns the whole derivation followed by the subterm derivation.
|
||||
;; If there is no subderivation for that syntax, returns #f.
|
||||
#;
|
||||
(define (seek/syntax stx deriv)
|
||||
(let ([subterms (gather-one-subterm (deriv-e1 deriv) stx)])
|
||||
(parameterize ((subterms-table subterms))
|
||||
|
|
@ -379,14 +403,14 @@
|
|||
|
||||
;; create-synth-deriv : syntax (list-of Subterm) -> Derivation
|
||||
(define (create-synth-deriv e1 subterm-derivs)
|
||||
(define (error? x) (and (s:subterm? x) (not (s:subterm-path x))))
|
||||
(let ([errors
|
||||
(map s:subterm-deriv
|
||||
(filter (lambda (x) (not (s:subterm-path x))) subterm-derivs))]
|
||||
[subterm-derivs (filter s:subterm-path subterm-derivs)])
|
||||
(map s:subterm-deriv (filter error? subterm-derivs))]
|
||||
[subterms (filter (lambda (x) (not (error? x))) subterm-derivs)])
|
||||
;(printf "subterm paths:~n~s~n" (map s:subterm-path subterm-derivs))
|
||||
;(printf "subterms:~n~s~n" subterm-derivs)
|
||||
(let ([e2 (substitute-subterms e1 subterm-derivs)])
|
||||
(let ([d (make-p:synth e1 e2 null subterm-derivs)])
|
||||
(let ([e2 (substitute-subterms e1 subterms)])
|
||||
(let ([d (make-p:synth e1 e2 null subterms)])
|
||||
(if (pair? errors)
|
||||
(make-error-wrap (error-wrap-exn (car errors))
|
||||
(error-wrap-tag (car errors))
|
||||
|
|
@ -455,48 +479,48 @@
|
|||
(for-lderiv lderiv))]
|
||||
[(AnyQ p:#%app (e1 e2 rs tagges-stx lderiv))
|
||||
(>>Seek (for-lderiv lderiv))]
|
||||
[(AnyQ p:lambda (e1 e2 rs renames body))
|
||||
[(AnyQ p:lambda (e1 e2 rs renames body) exni)
|
||||
;; 1 Make a new table
|
||||
;; Can narrow table to things that only occur in the renames
|
||||
;; 2 Search body
|
||||
;; 3 Make a "renaming" step... FIXME, how to represent?
|
||||
(>>Seek [#:table (table-restrict/lambda e1 renames)]
|
||||
(>>Seek [! exni]
|
||||
[#:rename (do-rename/lambda e1 renames)]
|
||||
(for-bderiv body))]
|
||||
[(AnyQ p:case-lambda (e1 e2 rs renames+bodies))
|
||||
;; Like lambda
|
||||
(with-syntax ([(?case-lambda ?clause ...) e1])
|
||||
(apply append
|
||||
(map (lambda (rename+body clause-stx)
|
||||
(let ([new-table (table-restrict/case-lambda clause-stx (car rename+body))])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(for-bderiv (cdr rename+body)))))
|
||||
renames+bodies
|
||||
(syntax->list #'(?clause ...)))))]
|
||||
(let ()
|
||||
(define (handle-clause clause-stx rename body)
|
||||
(>>Seek [#:rename (do-rename/case-lambda clause-stx rename)]
|
||||
(for-bderiv body)))
|
||||
(let loop ([clauses (syntax->list #'(?clause ...))]
|
||||
[renames+bodies renames+bodies])
|
||||
(if (pair? renames+bodies)
|
||||
(append (handle-clause (car clauses)
|
||||
(caar renames+bodies)
|
||||
(cdar renames+bodies))
|
||||
(loop (cdr clauses) (cdr renames+bodies)))
|
||||
null))))]
|
||||
[(AnyQ p:let-values (e1 e2 rs renames rhss body))
|
||||
(append (apply append (map for-deriv rhss))
|
||||
(let ([new-table (table-restrict/let e1 renames)])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(for-bderiv body))))]
|
||||
(>>Seek [#:append (map for-deriv rhss)]
|
||||
[#:rename (do-rename/let e1 renames)]
|
||||
(for-bderiv body))]
|
||||
[(AnyQ p:letrec-values (e1 e2 rs renames rhss body))
|
||||
(let ([new-table (table-restrict/let e1 renames)])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(append (apply append (map for-deriv rhss))
|
||||
(for-bderiv body))))]
|
||||
(>>Seek [#:rename (do-rename/let e1 renames)]
|
||||
[#:append (map for-deriv rhss)]
|
||||
(for-bderiv body))]
|
||||
[(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body))
|
||||
(let ([new-table (table-restrict/lsv1 e1 srenames)])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(append (apply append (map for-deriv srhss))
|
||||
(let ([new-table (table-restrict/lsv2 e1 vrenames)])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(append (apply append (map for-deriv vrhss))
|
||||
(for-bderiv body)))))))]
|
||||
(>>Seek [#:rename (do-rename/lsv1 e1 srenames)]
|
||||
[#:append (map for-deriv srhss)]
|
||||
[#:rename (do-rename/lsv2 srenames vrenames)]
|
||||
[#:append (map for-deriv vrhss)]
|
||||
(for-bderiv body))]
|
||||
[(AnyQ p::STOP (e1 e2 rs))
|
||||
null]
|
||||
;; synth (should synth be idempotent?... heh, no point for now)
|
||||
[(AnyQ p:rename (e1 e2 rs rename inner))
|
||||
(let ([new-table (table-restrict/rename (car rename) (cdr rename))])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(for-deriv inner)))]
|
||||
(>>Seek [#:rename (do-rename (car rename) (cdr rename))]
|
||||
(for-deriv inner))]
|
||||
|
||||
;; Macros
|
||||
|
||||
|
|
@ -523,22 +547,31 @@
|
|||
;; FIXME: and we'll also need to account for *that* marking, too...
|
||||
(unless (null? locals)
|
||||
(raise (make-localactions)))
|
||||
(parameterize ((subterms-table (table-restrict/rename e1 me1)))
|
||||
(let ([sss (map for-local locals)])
|
||||
(values (apply append sss)
|
||||
(table-restrict/rename me2 e2))))]))
|
||||
;(let* ([table-at-end #f]
|
||||
; [subterms
|
||||
; (>>Seek [#:rename (do-rename e1 me1)]
|
||||
; [#:append (map for-local locals)]
|
||||
; [#:rename (do-rename me2 e2)]
|
||||
; (begin (set! table-at-end (subterms-table))
|
||||
; null))])
|
||||
; (values subterms table-at-end))
|
||||
(let-values ([(rename-subterms1 table1) (do-rename e1 me1)])
|
||||
(parameterize ((subterms-table table1))
|
||||
(let ([sss (map for-local locals)])
|
||||
(let-values ([(rename-subterms2 table2) (do-rename me2 e2)])
|
||||
;; FIXME: Including these seems to produce evil results
|
||||
;; ie, parts of the hidden macro use appear as marked
|
||||
;; when they shouldn't
|
||||
(values (append #;rename-subterms1
|
||||
(apply append sss)
|
||||
#;rename-subterms2)
|
||||
table2)))))]))
|
||||
|
||||
;; for-local : LocalAction -> (list-of Subterm)
|
||||
(define (for-local local)
|
||||
(match local
|
||||
[(IntQ local-expansion (e1 e2 me1 me2 deriv))
|
||||
(parameterize ((subterms-table (table-restrict/rename e1 me1)))
|
||||
(let ([ss (for-deriv deriv)])
|
||||
;;
|
||||
'(for-each (lambda (s) (s:subterm-deriv s))
|
||||
ss)
|
||||
'(table-restrict/rename me2 e2)
|
||||
ss))]
|
||||
(error 'unimplemented)]
|
||||
;; Also need to handle local-bind
|
||||
;; ...
|
||||
[else null]))
|
||||
|
|
@ -561,13 +594,13 @@
|
|||
|
||||
|
||||
;; check-nonlinear-subterms : (list-of Subterm) -> void
|
||||
;; FIXME: How to handle nonlinear subterms?
|
||||
;; Option 1: escape and recover by making the macro transparent (include explanation?)
|
||||
;; Option 2: return special composite *thing* and somehow display both parts?
|
||||
;; FIXME: No checking on renamings... need to add
|
||||
;; Note: Make sure subterm contexts are *disjoint*, not just *distinct*
|
||||
(define (check-nonlinear-subterms subterm-derivs)
|
||||
(check-nonlinear-paths (map s:subterm-path subterm-derivs)))
|
||||
|
||||
(check-nonlinear-paths
|
||||
(map s:subterm-path
|
||||
(filter s:subterm? subterm-derivs))))
|
||||
|
||||
;; check-nonlinear-paths : (list-of Path) -> void
|
||||
;; FIXME: This is overly conservative for now, but probably
|
||||
;; okay given the way I construct paths.
|
||||
|
|
@ -612,19 +645,27 @@
|
|||
(hash-table-map t (lambda (k v) v))))
|
||||
|
||||
;; substitute-subterms : Syntax (list-of Subterm) -> Syntax
|
||||
;; List of subterm contexts is guaranteed to be disjoint.
|
||||
;; - s:subterm contexts guaranteed to be disjoint.
|
||||
;; - s:renames replace syntax with syntax of same structure
|
||||
;; FIXME: Could do this more efficiently using the structure of contexts...
|
||||
(define (substitute-subterms stx subterm-derivs)
|
||||
(cond [(null? subterm-derivs)
|
||||
stx]
|
||||
[else
|
||||
[(s:subterm? (car subterm-derivs))
|
||||
(let* ([subterm0 (car subterm-derivs)]
|
||||
[path0 (s:subterm-path subterm0)]
|
||||
[deriv0 (s:subterm-deriv subterm0)])
|
||||
(substitute-subterms (if path0
|
||||
(path-replace stx path0 (deriv-e2 deriv0))
|
||||
stx)
|
||||
(cdr subterm-derivs)))]))
|
||||
(substitute-subterms
|
||||
(if path0 (path-replace stx path0 (deriv-e2 deriv0)) stx)
|
||||
(cdr subterm-derivs)))]
|
||||
[(s:rename? (car subterm-derivs))
|
||||
(let ([subterm0 (car subterm-derivs)])
|
||||
(substitute-subterms
|
||||
(path-replace stx
|
||||
(s:rename-path subterm0)
|
||||
(s:rename-after subterm0))
|
||||
(cdr subterm-derivs)))]
|
||||
[else (error 'substitute-subterms)]))
|
||||
|
||||
;; gather-one-subterm : syntax syntax -> SubtermTable
|
||||
(define (gather-one-subterm whole part)
|
||||
|
|
@ -1120,46 +1161,55 @@
|
|||
(define (table-get table stx)
|
||||
(hash-table-get table stx (lambda () null)))
|
||||
|
||||
;; table-restrict/rename : syntax syntax -> Table
|
||||
(define (table-restrict/rename stx rename)
|
||||
;; do-rename : syntax syntax -> (values (list-of Subterm) Table)
|
||||
(define (do-rename stx rename)
|
||||
(let ([t (make-hash-table)]
|
||||
[old (subterms-table)])
|
||||
;; loop : syntax syntax -> void
|
||||
(define (loop stx rename)
|
||||
;; loop : syntax syntax -> (list-of Subterm)
|
||||
;; Puts things into the new table, too
|
||||
;; If active? is #f, always returns null
|
||||
(define (loop stx rename active?)
|
||||
(cond [(and (syntax? stx) (syntax? rename))
|
||||
(let ([paths (table-get old stx)])
|
||||
(when (pair? paths)
|
||||
(hash-table-put! t rename paths)))
|
||||
(loop (syntax-e stx) (syntax-e rename))]
|
||||
(if (pair? paths)
|
||||
(begin (hash-table-put! t rename paths)
|
||||
(loop (syntax-e stx) (syntax-e rename) #f)
|
||||
(if active?
|
||||
(map (lambda (p) (make-s:rename p stx rename))
|
||||
paths)
|
||||
null))
|
||||
(loop (syntax-e stx) (syntax-e rename) active?)))]
|
||||
[(syntax? rename)
|
||||
(loop stx (syntax-e rename))]
|
||||
(loop stx (syntax-e rename) active?)]
|
||||
[(and (pair? stx) (pair? rename))
|
||||
(loop (car stx) (car rename))
|
||||
(loop (cdr stx) (cdr rename))]
|
||||
(append
|
||||
(loop (car stx) (car rename) active?)
|
||||
(loop (cdr stx) (cdr rename) active?))]
|
||||
[else
|
||||
(void)]))
|
||||
(loop stx rename)
|
||||
t))
|
||||
null]))
|
||||
(let ([subterms (loop stx rename #t)])
|
||||
(values subterms t))))
|
||||
|
||||
(define (table-restrict/lambda stx rename)
|
||||
(define (do-rename/lambda stx rename)
|
||||
(with-syntax ([(?lambda ?formals . ?body) stx])
|
||||
(table-restrict/rename (cons #'?formals #'?body) rename)))
|
||||
(do-rename (cons #'?formals #'?body) rename)))
|
||||
|
||||
(define (table-restrict/let stx rename)
|
||||
(define (do-rename/let stx rename)
|
||||
(with-syntax ([(?let ?bindings . ?body) stx])
|
||||
(table-restrict/rename (cons #'?bindings #'?body) rename)))
|
||||
(do-rename (cons #'?bindings #'?body) rename)))
|
||||
|
||||
(define (table-restrict/case-lambda stx rename)
|
||||
(define (do-rename/case-lambda stx rename)
|
||||
(with-syntax ([(?formals . ?body) stx])
|
||||
(table-restrict/rename (cons #'?formals #'?body) rename)))
|
||||
(do-rename (cons #'?formals #'?body) rename)))
|
||||
|
||||
(define (table-restrict/lsv1 stx rename)
|
||||
(define (do-rename/lsv1 stx rename)
|
||||
(with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
|
||||
(table-restrict/rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename)))
|
||||
(do-rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename)))
|
||||
|
||||
(define (table-restrict/lsv2 stx rename)
|
||||
(define (do-rename/lsv2 old-rename rename)
|
||||
(if rename
|
||||
(with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
|
||||
(table-restrict/rename (cons #'?vbindings #'?body) rename))
|
||||
(subterms-table)))
|
||||
(with-syntax ([(?sbindings ?vbindings . ?body) old-rename])
|
||||
(do-rename (cons #'?vbindings #'?body) rename))
|
||||
(values null
|
||||
(subterms-table))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -105,8 +105,8 @@
|
|||
[#:bind (?formals* . ?body*) renames]
|
||||
[#:pattern (?lambda ?formals . ?body)]
|
||||
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
|
||||
#'?formals #'?formals*
|
||||
"Rename formal parameters"]
|
||||
#'?formals #'?formals*
|
||||
"Rename formal parameters"]
|
||||
[Block ?body body])]
|
||||
[(struct p:case-lambda (e1 e2 rs renames+bodies))
|
||||
#;
|
||||
|
|
@ -221,7 +221,7 @@
|
|||
(if exn
|
||||
(list (stumble term exn))
|
||||
null))]
|
||||
[(pair? subterms)
|
||||
[(s:subterm? (car subterms))
|
||||
(let* ([subterm0 (car subterms)]
|
||||
[path0 (s:subterm-path subterm0)]
|
||||
[deriv0 (s:subterm-deriv subterm0)])
|
||||
|
|
@ -229,7 +229,15 @@
|
|||
(append (with-context ctx
|
||||
(reductions deriv0))
|
||||
(loop (path-replace term path0 (deriv-e2 deriv0))
|
||||
(cdr subterms)))))]))]
|
||||
(cdr subterms)))))]
|
||||
[(s:rename? (car subterms))
|
||||
(let* ([subterm0 (car subterms)])
|
||||
;; FIXME: add renaming steps?
|
||||
;; FIXME: if so, coalesce?
|
||||
(loop (path-replace term
|
||||
(s:rename-path subterm0)
|
||||
(s:rename-after subterm0))
|
||||
(cdr subterms)))]))]
|
||||
|
||||
;; FIXME
|
||||
[(IntQ p:rename (e1 e2 rs rename inner))
|
||||
|
|
|
|||
|
|
@ -87,15 +87,23 @@
|
|||
new-e2))))))))]))
|
||||
|
||||
(define-syntax >>Seek
|
||||
(syntax-rules (!)
|
||||
(syntax-rules (! =>)
|
||||
[(>>Seek) null]
|
||||
[(>>Seek [! tag exni] . more)
|
||||
(if (and (pair? exni) (eq? tag (car exni)))
|
||||
null
|
||||
(>>Seek . more))]
|
||||
[(>>Seek [! exni] . more)
|
||||
(if (pair? exni) null (>>Seek . more))]
|
||||
[(>>Seek [#:append expr] . more)
|
||||
(append (apply append expr) (>>Seek . more))]
|
||||
[(>>Seek [#:table t] . more)
|
||||
(parameterize ((subterms-table t)) (>>Seek . more))]
|
||||
[(>>Seek [#:rename expr] . more)
|
||||
(let-values ([(subterms new-table) expr])
|
||||
(parameterize ((subterms-table new-table))
|
||||
(append subterms (>>Seek . more))))]
|
||||
[(>>Seek expr . more)
|
||||
(append expr (>>Seek . more))]))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user