863 lines
46 KiB
Scheme
863 lines
46 KiB
Scheme
(unit/sig stepper:annotate^
|
|
(import [z : zodiac:system^]
|
|
mzlib:function^
|
|
[e : zodiac:interface^]
|
|
[utils : stepper:cogen-utils^]
|
|
stepper:marks^
|
|
[s : stepper:model^]
|
|
stepper:shared^
|
|
stepper:client-procs^)
|
|
|
|
; ANNOTATE SOURCE CODE
|
|
|
|
; gensyms for annotation:
|
|
|
|
; the mutator-gensym is used in building the mutators that go into certain marks.
|
|
; (define mutator-gensym (gensym "mutator-"))
|
|
|
|
; the `closure-temp' symbol is used for the let which wraps created closures, so
|
|
; that we can stuff them into the hash table.
|
|
|
|
; closure-temp: uninterned-symbol
|
|
|
|
(define closure-temp (gensym "closure-temp-"))
|
|
|
|
; dual-map : (('a -> (values 'b 'c)) ('a list)) -> (values ('b list) ('c list))
|
|
|
|
(define (dual-map f . lsts)
|
|
(if (null? (car lsts))
|
|
(values null null)
|
|
(let+ ([val (values a b) (apply f (map car lsts))]
|
|
[val (values a-rest b-rest) (apply dual-map f (map cdr lsts))])
|
|
(values (cons a a-rest) (cons b b-rest)))))
|
|
|
|
; binding-set-union takes some lists of bindings where no element appears twice in one list, and
|
|
; forms a new list which is the union of the sets.
|
|
|
|
(define (binding-set-pair-union a-set b-set)
|
|
(cond [(or (eq? a-set 'all) (eq? b-set 'all)) 'all]
|
|
[else (append a-set (remq* a-set b-set))]))
|
|
|
|
(define binding-set-union
|
|
(lambda args
|
|
(foldl binding-set-pair-union
|
|
null
|
|
args)))
|
|
|
|
(define (binding-set-intersect a-set b-set)
|
|
(remq* (remq* a-set b-set) b-set))
|
|
|
|
(define never-undefined? never-undefined-getter)
|
|
(define (mark-never-undefined parsed) (never-undefined-setter parsed #t))
|
|
|
|
(define (interlace a b)
|
|
(foldr (lambda (a b built)
|
|
(cons a (cons b built)))
|
|
null
|
|
a
|
|
b))
|
|
|
|
(define (closure-key-maker closure)
|
|
closure)
|
|
|
|
; paroptarglist-> ilist and arglist->ilist are used to recreate
|
|
; mzscheme sexp syntax from the parsed zodiac form, so that the
|
|
; resulting expression can be fed to mzscheme.
|
|
|
|
|
|
|
|
; debug-key: this key will be used as a key for the continuation marks.
|
|
|
|
(define debug-key (gensym "debug-key-"))
|
|
|
|
; translate-varref : returns the name the varref will get in the final output
|
|
|
|
(define (translate-varref expr)
|
|
(if (z:top-level-varref? expr) ; top level varrefs
|
|
(z:varref-var expr)
|
|
(get-binding-name (z:bound-varref-binding expr))))
|
|
|
|
; make-debug-info builds the thunk which will be the mark at runtime. It contains
|
|
; a source expression (in the parsed zodiac format) and a set of z:binding/value pairs.
|
|
;((z:parsed (union (list-of z:binding) 'all) (list-of z:binding) symbol) ->
|
|
; debug-info)
|
|
|
|
(define (make-debug-info source tail-bound free-bindings label)
|
|
(let* ([kept-bindings (if (eq? tail-bound 'all)
|
|
free-bindings
|
|
(binding-set-intersect tail-bound
|
|
free-bindings))]
|
|
[var-clauses (map (lambda (x)
|
|
(let ([var (get-binding-name x)])
|
|
(list var x)))
|
|
kept-bindings)])
|
|
(make-full-mark source label var-clauses)))
|
|
|
|
; cheap-wrap for non-debugging annotation
|
|
|
|
(define cheap-wrap
|
|
(lambda (zodiac body)
|
|
(let ([start (z:zodiac-start zodiac)]
|
|
[finish (z:zodiac-finish zodiac)])
|
|
`(#%with-continuation-mark (#%quote ,debug-key)
|
|
,(make-cheap-mark (z:make-zodiac #f start finish))
|
|
,body))))
|
|
|
|
; wrap-struct-form
|
|
|
|
(define (wrap-struct-form names annotated)
|
|
(let* ([arg-temps (build-list (length names) get-arg-binding)]
|
|
[arg-temp-syms (map z:binding-var arg-temps)]
|
|
[struct-proc-names (cdr names)]
|
|
[closure-records (map (lambda (proc-name) `(,make-closure-record
|
|
(#%quote ,proc-name)
|
|
(#%lambda () #f)
|
|
,(eq? proc-name (car struct-proc-names))))
|
|
struct-proc-names)]
|
|
[proc-arg-temp-syms (cdr arg-temp-syms)]
|
|
[setters (map (lambda (arg-temp-sym closure-record)
|
|
`(,closure-table-put! ,arg-temp-sym ,closure-record))
|
|
proc-arg-temp-syms
|
|
closure-records)]
|
|
[full-body (append setters (list `(values ,@arg-temp-syms)))])
|
|
`(#%let-values ((,arg-temp-syms ,annotated)) ,@full-body)))
|
|
|
|
; update-closure-record-name : adds a name to an existing closure table record,
|
|
; if there is one for that value.
|
|
|
|
(define (update-closure-record-name value name)
|
|
(let* ([closure-record (closure-table-lookup value)]
|
|
[old-name (closure-record-name closure-record)])
|
|
(if old-name
|
|
(e:internal-error "closure-record already has a name: ~a" old-name)
|
|
(set-closure-record-name! closure-record name))))
|
|
|
|
|
|
(define initial-env-package null)
|
|
|
|
; annotate takes
|
|
; a) a list of zodiac:read expressions,
|
|
; b) a list of zodiac:parsed expressions,
|
|
; c) a list of previously-defined variables,
|
|
; d) a break routine to be called at breakpoints, and
|
|
; e) a boolean which indicates whether the expression is to be annotated "cheaply".
|
|
;
|
|
; actually, I'm not sure that annotate works for more than one expression, even though
|
|
; it's supposed to take a whole list. I wouldn't count on it. Also, both the red-exprs
|
|
; and break arguments may be #f, the first during a zodiac:elaboration-evaluator call,
|
|
; the second during any non-stepper use.
|
|
|
|
(define (annotate red-exprs parsed-exprs input-struct-proc-names break cheap-wrap?)
|
|
(local
|
|
(
|
|
(define (make-break kind)
|
|
`(#%lambda returned-value-list
|
|
(,break (continuation-mark-set->list
|
|
(current-continuation-marks)
|
|
(#%quote ,debug-key))
|
|
(#%quote ,kind)
|
|
returned-value-list)))
|
|
|
|
; wrap creates the w-c-m expression.
|
|
|
|
(define (simple-wcm-wrap debug-info expr)
|
|
`(#%with-continuation-mark (#%quote ,debug-key) ,debug-info ,expr))
|
|
|
|
(define (wcm-pre-break-wrap debug-info expr)
|
|
(if break
|
|
(simple-wcm-wrap debug-info `(#%begin (,(make-break 'result-break)) ,expr))
|
|
(simple-wcm-wrap debug-info expr)))
|
|
|
|
(define (break-wrap expr)
|
|
(if break
|
|
`(#%begin (,(make-break 'normal-break)) ,expr)
|
|
expr))
|
|
|
|
(define (double-break-wrap expr)
|
|
(if break
|
|
`(#%begin (,(make-break 'double-break)) ,expr)
|
|
expr))
|
|
|
|
(define (simple-wcm-break-wrap debug-info expr)
|
|
(simple-wcm-wrap debug-info (break-wrap expr)))
|
|
|
|
(define (return-value-wrap expr)
|
|
(if break
|
|
`(#%let* ([result ,expr])
|
|
(,(make-break 'result-break) result)
|
|
result)
|
|
expr))
|
|
|
|
; For Multiple Values:
|
|
; `(#%call-with-values
|
|
; (#%lambda ()
|
|
; expr)
|
|
; (#%lambda result-values
|
|
; (,(make-break 'result-break) result-values)
|
|
; (#%apply #%values result-values))))
|
|
|
|
(define (find-read-expr expr)
|
|
(let ([offset (z:location-offset (z:zodiac-start expr))])
|
|
(let search-exprs ([exprs red-exprs])
|
|
(let* ([later-exprs (filter
|
|
(lambda (expr)
|
|
(<= offset (z:location-offset (z:zodiac-finish expr))))
|
|
exprs)]
|
|
[expr
|
|
(car later-exprs)])
|
|
(if (= offset (z:location-offset (z:zodiac-start expr)))
|
|
expr
|
|
(cond
|
|
((z:scalar? expr) (e:static-error "starting offset inside scalar:" offset))
|
|
((z:sequence? expr)
|
|
(let ([object (z:read-object expr)])
|
|
(cond
|
|
((z:list? expr) (search-exprs object))
|
|
((z:vector? expr)
|
|
(search-exprs (vector->list object))) ; can source exprs be here?
|
|
((z:improper-list? expr)
|
|
(search-exprs (search-exprs object))) ; can source exprs be here? (is this a bug?)
|
|
(else (e:static-error "unknown expression type in sequence" expr)))))
|
|
(else (e:static-error "unknown read type" expr))))))))
|
|
|
|
(define (struct-procs-defined expr)
|
|
(if (and (z:define-values-form? expr)
|
|
(z:struct-form? (z:define-values-form-val expr)))
|
|
(map z:varref-var (z:define-values-form-vars expr))
|
|
null))
|
|
|
|
(define struct-proc-names (apply append input-struct-proc-names
|
|
(map struct-procs-defined parsed-exprs)))
|
|
|
|
(define (non-annotated-proc? varref)
|
|
(let ([name (z:varref-var varref)])
|
|
(or (s:check-pre-defined-var name)
|
|
(memq name struct-proc-names))))
|
|
|
|
; annotate/inner takes
|
|
; a) a zodiac expression to annotate
|
|
; b) a list of all findins which this expression is tail w.r.t.
|
|
; or 'all to indicate that this expression is tail w.r.t. _all_ bindings.
|
|
; c) a list of varrefs of 'floating' variables; i.e. lexical bindings NO: TAKEN OUT
|
|
; whose value must be captured in order to reconstruct outer expressions.
|
|
; Necessitated by 'unit', useful for 'letrec*-values'.
|
|
; d) a boolean indicating whether this expression will be the r.h.s. of a reduction
|
|
; (and therefore should be broken before)
|
|
; e) a boolean indicating whether this expression is top-level (and therefore should
|
|
; not be wrapped, if a begin).
|
|
; f) a boolean indicating whether this expression should receive the "cheap wrap" (aka
|
|
; old-style aries annotation) or not. #t => cheap wrap. NOTE: THIS HAS BEEN
|
|
; (TEMPORARILY?) TAKEN OUT/MOVED TO THE TOP LEVEL.
|
|
;
|
|
; it returns
|
|
; a) an annotated s-expression
|
|
; b) a list of varrefs for the variables which occur free in the expression
|
|
;
|
|
;(z:parsed (union (list-of z:varref) 'all) (list-of z:varref) bool bool ->
|
|
; sexp (list-of z:varref))
|
|
|
|
(define (annotate/inner expr tail-bound pre-break? top-level?)
|
|
|
|
(let* ([tail-recur (lambda (expr) (annotate/inner expr tail-bound #t #f))]
|
|
[define-values-recur (lambda (expr) (annotate/inner expr tail-bound #f #f))]
|
|
[non-tail-recur (lambda (expr) (annotate/inner expr null #f #f))]
|
|
[lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))]
|
|
; note: no pre-break for the body of a let; it's handled by the break for the
|
|
; let itself.
|
|
[let-body-recur (lambda (expr bindings) (annotate/inner expr (binding-set-union tail-bound bindings) #f #f))]
|
|
[cheap-wrap-recur (lambda (expr) (let-values ([(ann _) (non-tail-recur expr)]) ann))]
|
|
[make-debug-info-normal (lambda (free-bindings)
|
|
(make-debug-info expr tail-bound free-bindings 'none))]
|
|
[make-debug-info-app (lambda (tail-bound free-bindings label)
|
|
(make-debug-info expr tail-bound free-bindings label))]
|
|
[wcm-wrap (if pre-break?
|
|
wcm-pre-break-wrap
|
|
simple-wcm-wrap)]
|
|
[wcm-break-wrap (lambda (debug-info expr)
|
|
(wcm-wrap debug-info (break-wrap expr)))]
|
|
[expr-cheap-wrap (lambda (annotated) (cheap-wrap expr annotated))])
|
|
|
|
; find the source expression and associate it with the parsed expression
|
|
|
|
(when (and red-exprs (not cheap-wrap?))
|
|
(set-expr-read! expr (find-read-expr expr)))
|
|
|
|
(cond
|
|
|
|
; the variable forms
|
|
|
|
[(z:varref? expr)
|
|
(let* ([v (translate-varref expr)]
|
|
[real-v (if (z:top-level-varref? expr)
|
|
v
|
|
(z:binding-orig-name
|
|
(z:bound-varref-binding expr)))]
|
|
[maybe-undef? (or (and (z:bound-varref? expr)
|
|
(not (never-undefined? (z:bound-varref-binding expr))))
|
|
(utils:is-unit-bound? expr))]
|
|
[truly-top-level? (and (z:top-level-varref? expr) (not (utils:is-unit-bound? expr)))]
|
|
[_ (when truly-top-level?
|
|
(utils:check-for-syntax-or-macro-keyword expr))]
|
|
[free-bindings (if (z:bound-varref? expr)
|
|
(list (z:bound-varref-binding expr))
|
|
null)]
|
|
[debug-info (make-debug-info-normal free-bindings)]
|
|
[annotated (if (and maybe-undef? (utils:signal-undefined))
|
|
`(#%if (#%eq? ,v ,utils:the-undefined-value)
|
|
(#%raise (,utils:make-undefined
|
|
,(format utils:undefined-error-format real-v)
|
|
(#%current-continuation-marks)
|
|
(#%quote ,v)))
|
|
,v)
|
|
v)])
|
|
(values (if cheap-wrap?
|
|
(if (or (and maybe-undef? (utils:signal-undefined)) truly-top-level?)
|
|
(expr-cheap-wrap annotated)
|
|
annotated)
|
|
(wcm-break-wrap debug-info (return-value-wrap annotated))) free-bindings))]
|
|
|
|
[(z:app? expr)
|
|
(let*-values
|
|
([(sub-exprs) (cons (z:app-fun expr) (z:app-args expr))]
|
|
[(annotated-sub-exprs free-bindings-sub-exprs)
|
|
(dual-map non-tail-recur sub-exprs)]
|
|
[(free-bindings) (apply binding-set-union free-bindings-sub-exprs)])
|
|
(if cheap-wrap?
|
|
(values (expr-cheap-wrap annotated-sub-exprs) free-bindings)
|
|
(let* ([arg-temps (build-list (length sub-exprs) get-arg-binding)]
|
|
[arg-temp-syms (map z:binding-var arg-temps)]
|
|
[let-clauses `((,arg-temp-syms
|
|
(#%values ,@(map (lambda (x) `(#%quote ,*unevaluated*)) arg-temps))))]
|
|
[set!-list (map (lambda (arg-symbol annotated-sub-expr)
|
|
`(#%set! ,arg-symbol ,annotated-sub-expr))
|
|
arg-temp-syms annotated-sub-exprs)]
|
|
[new-tail-bound (binding-set-union tail-bound arg-temps)]
|
|
[app-debug-info (make-debug-info-app new-tail-bound arg-temps 'called)]
|
|
[annotate-app? (let ([fun-exp (z:app-fun expr)])
|
|
(and (z:top-level-varref? fun-exp)
|
|
(non-annotated-proc? fun-exp)))]
|
|
[final-app (break-wrap (simple-wcm-wrap app-debug-info
|
|
(if annotate-app?
|
|
(return-value-wrap arg-temp-syms)
|
|
arg-temp-syms)))]
|
|
[debug-info (make-debug-info-app new-tail-bound
|
|
(binding-set-union free-bindings arg-temps)
|
|
'not-yet-called)]
|
|
[let-body (wcm-wrap debug-info `(#%begin ,@set!-list ,final-app))]
|
|
[let-exp `(#%let-values ,let-clauses ,let-body)])
|
|
(values let-exp free-bindings))))]
|
|
|
|
[(z:struct-form? expr)
|
|
(let ([super-expr (z:struct-form-super expr)]
|
|
[raw-type (utils:read->raw (z:struct-form-type expr))]
|
|
[raw-fields (map utils:read->raw (z:struct-form-fields expr))])
|
|
(if super-expr
|
|
(let*-values
|
|
([(annotated-super-expr free-bindings-super-expr)
|
|
(non-tail-recur super-expr)]
|
|
[(annotated)
|
|
`(#%struct
|
|
,(list raw-type annotated-super-expr)
|
|
,raw-fields)]
|
|
[(debug-info) (make-debug-info-normal free-bindings-super-expr)])
|
|
(values (if cheap-wrap?
|
|
(expr-cheap-wrap annotated)
|
|
(wcm-wrap debug-info annotated))
|
|
free-bindings-super-expr))
|
|
(let ([annotated `(#%struct ,raw-type ,raw-fields)])
|
|
(values (if cheap-wrap?
|
|
(expr-cheap-wrap annotated)
|
|
(wcm-wrap (make-debug-info-normal null) annotated))
|
|
null))))]
|
|
|
|
[(z:if-form? expr)
|
|
(let*-values
|
|
([(annotated-test free-bindings-test)
|
|
(non-tail-recur (z:if-form-test expr))]
|
|
[(annotated-then free-bindings-then)
|
|
(tail-recur (z:if-form-then expr))]
|
|
[(annotated-else free-bindings-else)
|
|
(tail-recur (z:if-form-else expr))]
|
|
[(free-bindings) (binding-set-union free-bindings-test
|
|
free-bindings-then
|
|
free-bindings-else)]
|
|
[(if-temp-sym) (z:binding-var if-temp)]
|
|
[(inner-annotated) `(#%if ,if-temp-sym
|
|
,annotated-then
|
|
,annotated-else)]
|
|
[(annotated-2) (if (utils:signal-not-boolean)
|
|
`(#%if (#%boolean? ,if-temp-sym)
|
|
,inner-annotated
|
|
(#%raise (,utils:make-not-boolean
|
|
(#%format ,utils:not-boolean-error-format
|
|
,if-temp-sym)
|
|
(#%current-continuation-marks)
|
|
,if-temp-sym)))
|
|
inner-annotated)])
|
|
(if cheap-wrap?
|
|
(values
|
|
(expr-cheap-wrap (if (utils:signal-not-boolean)
|
|
`(#%let ((,if-temp-sym ,annotated-test)) ,annotated-2)
|
|
`(#%if ,annotated-test ,annotated-then ,annotated-else)))
|
|
free-bindings)
|
|
(let* ([annotated `(#%begin
|
|
(#%set! ,if-temp-sym ,annotated-test)
|
|
,(break-wrap annotated-2))]
|
|
[debug-info (make-debug-info-app (binding-set-union tail-bound (list if-temp))
|
|
(binding-set-union free-bindings (list if-temp))
|
|
'none)]
|
|
[wcm-wrapped (wcm-wrap debug-info annotated)]
|
|
[outer-annotated `(#%let ((,if-temp-sym (#%quote ,*unevaluated*))) ,wcm-wrapped)])
|
|
(values outer-annotated free-bindings))))]
|
|
|
|
[(z:quote-form? expr)
|
|
(let ([annotated `(#%quote ,(utils:read->raw (z:quote-form-expr expr)))])
|
|
(values (if cheap-wrap?
|
|
annotated
|
|
(wcm-wrap (make-debug-info-normal null) annotated))
|
|
null))]
|
|
|
|
[(z:begin-form? expr)
|
|
(if top-level?
|
|
(let*-values
|
|
([(bodies) (z:begin-form-bodies expr)]
|
|
[(annotated-bodies free-bindings)
|
|
(dual-map (lambda (expr)
|
|
(annotate/inner expr 'all #f #t))
|
|
bodies)])
|
|
(values `(#%begin ,@annotated-bodies)
|
|
(apply binding-set-union free-bindings)))
|
|
(let*-values
|
|
([(bodies) (z:begin-form-bodies expr)]
|
|
[(all-but-last-body last-body-list)
|
|
(list-partition bodies (- (length bodies) 1))]
|
|
[(last-body) (car last-body-list)]
|
|
[(annotated-a free-bindings-a)
|
|
(dual-map non-tail-recur all-but-last-body)]
|
|
[(annotated-final free-bindings-final)
|
|
(tail-recur last-body)]
|
|
[(free-bindings) (apply binding-set-union free-bindings-final free-bindings-a)]
|
|
[(debug-info) (make-debug-info-normal free-bindings)]
|
|
[(annotated) `(#%begin ,@(append annotated-a (list annotated-final)))])
|
|
(values (if cheap-wrap?
|
|
(expr-cheap-wrap annotated)
|
|
(wcm-wrap debug-info annotated))
|
|
free-bindings)))]
|
|
|
|
[(z:begin0-form? expr)
|
|
(let*-values
|
|
([(bodies) (z:begin0-form-bodies expr)]
|
|
[(annotated-bodies free-bindings-lists)
|
|
(dual-map non-tail-recur bodies)]
|
|
[(free-bindings) (apply binding-set-union free-bindings-lists)]
|
|
[(debug-info) (make-debug-info-normal free-bindings)]
|
|
[(annotated) `(#%begin0 ,@annotated-bodies)])
|
|
(values (if cheap-wrap?
|
|
(expr-cheap-wrap annotated)
|
|
(wcm-wrap debug-info annotated))
|
|
free-bindings))]
|
|
|
|
; gott in himmel! this transformation is complicated. Just for the record,
|
|
; here's a sample transformation:
|
|
;(let-values ([(a b c) e1] [(d e) e2]) e3)
|
|
;
|
|
;turns into
|
|
;
|
|
;(let-values ([(dummy1 dummy2 dummy3 dummy4 dummy5)
|
|
; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated*)])
|
|
; (with-continuation-mark
|
|
; key huge-value
|
|
; (begin
|
|
; (set!-values (dummy1 dummy2 dummy3) e1)
|
|
; (set!-values (dummy4 dummy5) e2)
|
|
; (let-values ([(a b c d e) (values dummy1 dummy2 dummy3 dummy4 dummy5)])
|
|
; e3))))
|
|
;
|
|
; let me know if you can do it in less.
|
|
|
|
; another irritating point: the mark and the break that must go immediately
|
|
; around the body. Irritating because they will be instantly replaced by
|
|
; the mark and the break produced by the annotated body itself. However,
|
|
; they're necessary, because the body may not contain free references to
|
|
; all of the variables defined in the let, and thus their values are not
|
|
; known otherwise.
|
|
; whoops! hold the phone. I think I can get away with a break before, and
|
|
; a mark after, so only one of each. groovy, eh?
|
|
|
|
[(z:let-values-form? expr)
|
|
(let*-values
|
|
([(binding-sets) (z:let-values-form-vars expr)]
|
|
[(binding-set-list) (apply append binding-sets)]
|
|
[(vals) (z:let-values-form-vals expr)]
|
|
[(_1) (for-each utils:check-for-keyword binding-set-list)]
|
|
[(_2) (for-each mark-never-undefined binding-set-list)]
|
|
[(annotated-vals free-bindings-vals)
|
|
(dual-map non-tail-recur vals)]
|
|
[(annotated-body free-bindings-body)
|
|
(let-body-recur (z:let-values-form-body expr) binding-set-list)]
|
|
[(free-bindings) (apply binding-set-union (remq* binding-set-list free-bindings-body)
|
|
free-bindings-vals)])
|
|
(if cheap-wrap?
|
|
(let ([bindings
|
|
(map (lambda (bindings val)
|
|
`(,(map get-binding-name bindings) ,val))
|
|
binding-sets
|
|
annotated-vals)])
|
|
(values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-bindings))
|
|
(let* ([dummy-binding-sets
|
|
(let ([counter 0])
|
|
(map (lambda (binding-set)
|
|
(map (lambda (binding)
|
|
(begin0
|
|
(get-arg-binding counter)
|
|
(set! counter (+ counter 1))))
|
|
binding-set))
|
|
binding-sets))]
|
|
[dummy-binding-list (apply append dummy-binding-sets)]
|
|
[outer-dummy-initialization
|
|
`([,(map z:binding-var dummy-binding-list)
|
|
(#%values ,@(build-list (length dummy-binding-list)
|
|
(lambda (_) `(#%quote ,*unevaluated*))))])]
|
|
[set!-clauses
|
|
(map (lambda (dummy-binding-set val)
|
|
`(#%set!-values ,(map z:binding-var dummy-binding-set) ,val))
|
|
dummy-binding-sets
|
|
annotated-vals)]
|
|
[inner-transference
|
|
`([,(map get-binding-name binding-set-list)
|
|
(values ,@(map z:binding-var dummy-binding-list))])]
|
|
; time to work from the inside out again
|
|
[inner-let-values
|
|
`(#%let-values ,inner-transference ,annotated-body)]
|
|
[middle-begin
|
|
`(#%begin ,@set!-clauses ,(double-break-wrap inner-let-values))]
|
|
[wrapped-begin
|
|
(wcm-wrap (make-debug-info-app (binding-set-union tail-bound dummy-binding-list)
|
|
(binding-set-union free-bindings dummy-binding-list)
|
|
'let-body)
|
|
middle-begin)]
|
|
[whole-thing
|
|
`(#%let-values ,outer-dummy-initialization ,wrapped-begin)])
|
|
(values whole-thing free-bindings))))]
|
|
|
|
[(z:letrec-values-form? expr)
|
|
(let*-values
|
|
([(binding-sets) (z:letrec-values-form-vars expr)]
|
|
[(binding-list) (apply append binding-sets)]
|
|
[(binding-names) (map get-binding-name binding-list)]
|
|
[(vals) (z:letrec-values-form-vals expr)]
|
|
[(_1) (when (andmap z:case-lambda-form? vals)
|
|
(for-each mark-never-undefined binding-list))] ; we could be more aggressive about this.
|
|
[(_2) (for-each utils:check-for-keyword binding-list)]
|
|
[(annotated-vals free-bindings-vals)
|
|
(dual-map non-tail-recur vals)]
|
|
[(annotated-body free-bindings-body)
|
|
(let-body-recur (z:letrec-values-form-body expr)
|
|
binding-list)]
|
|
[(free-bindings-inner) (apply binding-set-union free-bindings-body free-bindings-vals)]
|
|
[(free-bindings-outer) (remq* binding-list free-bindings-inner)])
|
|
(if cheap-wrap?
|
|
(let ([bindings
|
|
(map (lambda (bindings val)
|
|
`(,(map get-binding-name bindings)
|
|
,val))
|
|
binding-sets
|
|
annotated-vals)])
|
|
(values (expr-cheap-wrap `(#%letrec-values ,bindings ,annotated-body))
|
|
free-bindings-outer))
|
|
(let* ([outer-initialization
|
|
`((,binding-names (#%values ,@binding-names)))]
|
|
[set!-clauses
|
|
(map (lambda (binding-set val)
|
|
`(#%set!-values ,(map get-binding-name binding-set) ,val))
|
|
binding-sets
|
|
annotated-vals)]
|
|
[middle-begin
|
|
`(#%begin ,@set!-clauses ,(double-break-wrap annotated-body))]
|
|
[wrapped-begin
|
|
(wcm-wrap (make-debug-info-app (binding-set-union tail-bound binding-list)
|
|
(binding-set-union free-bindings-inner binding-list)
|
|
'let-body)
|
|
middle-begin)]
|
|
[whole-thing
|
|
`(#%letrec-values ,outer-initialization ,wrapped-begin)])
|
|
(values whole-thing free-bindings-outer))))]
|
|
|
|
[(z:define-values-form? expr)
|
|
(let*-values
|
|
([(vars) (z:define-values-form-vars expr)]
|
|
[(_1) (map utils:check-for-keyword vars)]
|
|
[(binding-names) (map z:varref-var vars)]
|
|
|
|
; NB: this next recurrence is NOT really tail, but we cannot
|
|
; mark define-values itself, so we mark the sub-expr as
|
|
; if it was in tail posn (i.e., we must hold on to
|
|
; bindings).
|
|
|
|
[(val) (z:define-values-form-val expr)]
|
|
[(annotated-val free-bindings-val)
|
|
(define-values-recur val)])
|
|
(cond [(and (z:case-lambda-form? val) (not cheap-wrap?))
|
|
(values `(#%define-values ,binding-names
|
|
(#%let ((,closure-temp ,annotated-val))
|
|
(,update-closure-record-name ,closure-temp (#%quote ,(car binding-names)))
|
|
,closure-temp))
|
|
free-bindings-val)]
|
|
[(z:struct-form? val)
|
|
(values `(#%define-values ,binding-names
|
|
,(wrap-struct-form binding-names annotated-val))
|
|
free-bindings-val)]
|
|
[else
|
|
(values `(#%define-values ,binding-names
|
|
,annotated-val)
|
|
free-bindings-val)]))]
|
|
|
|
[(z:set!-form? expr)
|
|
(utils:check-for-keyword (z:set!-form-var expr))
|
|
(let*-values
|
|
([(var) (z:set!-form-var expr)]
|
|
[(v) (translate-varref var)]
|
|
[(annotated-body rhs-free-bindings)
|
|
(non-tail-recur (z:set!-form-val expr))]
|
|
[(free-bindings) (binding-set-union (if (z:top-level-varref? var)
|
|
null
|
|
(list (z:bound-varref-binding var)))
|
|
rhs-free-bindings)]
|
|
[(debug-info) (make-debug-info-normal free-bindings)]
|
|
[(annotated) `(#%set! ,v ,annotated-body)])
|
|
(values (if cheap-wrap?
|
|
(expr-cheap-wrap annotated)
|
|
(wcm-wrap (make-debug-info-normal free-bindings) annotated))
|
|
free-bindings))]
|
|
|
|
[(z:case-lambda-form? expr)
|
|
(let*-values
|
|
([(annotated-cases free-bindings-cases)
|
|
(dual-map
|
|
(lambda (arglist body)
|
|
(let ([binding-list (z:arglist-vars arglist)]
|
|
[args (utils:arglist->ilist arglist)])
|
|
(utils:improper-foreach utils:check-for-keyword args)
|
|
(utils:improper-foreach mark-never-undefined args)
|
|
(let*-values
|
|
([(annotated free-bindings)
|
|
(lambda-body-recur body)]
|
|
[(new-free-bindings) (remq* binding-list free-bindings)]
|
|
[(new-annotated) (list (utils:improper-map get-binding-name args)
|
|
annotated)])
|
|
(values new-annotated new-free-bindings))))
|
|
(z:case-lambda-form-args expr)
|
|
(z:case-lambda-form-bodies expr))]
|
|
[(annotated-case-lambda) (cons '#%case-lambda annotated-cases)]
|
|
[(new-free-bindings) (apply binding-set-union free-bindings-cases)]
|
|
[(closure-info) (make-debug-info-app 'all new-free-bindings 'none)]
|
|
[(wrapped-annotated) (wcm-wrap (make-debug-info-normal null)
|
|
annotated-case-lambda)]
|
|
[(hash-wrapped) `(#%let ([,closure-temp ,wrapped-annotated])
|
|
(,closure-table-put! (,closure-key-maker ,closure-temp)
|
|
(,make-closure-record
|
|
#f
|
|
,closure-info
|
|
#f))
|
|
,closure-temp)])
|
|
(values (if cheap-wrap?
|
|
annotated-case-lambda
|
|
hash-wrapped)
|
|
new-free-bindings))]
|
|
|
|
; the annotation for w-c-m is insufficient for
|
|
; debugging: there must be an intermediate let & set!s to
|
|
; allow the user to see the computed values for the key and the
|
|
; value.
|
|
|
|
[(z:with-continuation-mark-form? expr)
|
|
(let*-values
|
|
([(annotated-key free-bindings-key)
|
|
(non-tail-recur (z:with-continuation-mark-form-key expr))]
|
|
[(annotated-val free-bindings-val)
|
|
(non-tail-recur (z:with-continuation-mark-form-val expr))]
|
|
[(annotated-body free-bindings-body)
|
|
(non-tail-recur (z:with-continuation-mark-form-body expr))]
|
|
[(free-bindings) (binding-set-union free-bindings-key free-bindings-val free-bindings-body)]
|
|
[(debug-info) (make-debug-info-normal free-bindings)]
|
|
[(annotated) `(#%with-continuation-mark
|
|
,annotated-key
|
|
,annotated-val
|
|
,annotated-body)])
|
|
(values (if cheap-wrap?
|
|
(expr-cheap-wrap annotated)
|
|
(wcm-wrap debug-info annotated))
|
|
free-bindings))]
|
|
|
|
[(not cheap-wrap?)
|
|
(e:static-error "cannot annotate units or classes except in cheap-wrap mode")]
|
|
|
|
[(z:unit-form? expr)
|
|
(let* ([imports (z:unit-form-imports expr)]
|
|
[exports (map (lambda (export)
|
|
(list (translate-varref (car export))
|
|
(z:read-object (cdr export))))
|
|
(z:unit-form-exports expr))]
|
|
[clauses (map annotate/top-level (z:unit-form-clauses expr))])
|
|
(for-each utils:check-for-keyword imports)
|
|
(values
|
|
`(#%unit
|
|
(import ,@(map get-binding-name imports))
|
|
(export ,@exports)
|
|
,@clauses)
|
|
null))]
|
|
|
|
[(z:compound-unit-form? expr)
|
|
(let ((imports (map get-binding-name
|
|
(z:compound-unit-form-imports expr)))
|
|
(links (z:compound-unit-form-links expr))
|
|
(exports (z:compound-unit-form-exports expr)))
|
|
(let
|
|
((links
|
|
(map
|
|
(lambda (link-clause)
|
|
(let* ([tag (utils:read->raw (car link-clause))]
|
|
[sub-unit (cheap-wrap-recur (cadr link-clause))]
|
|
[imports
|
|
(map (lambda (import)
|
|
(if (z:lexical-varref? import)
|
|
(translate-varref import)
|
|
`(,(utils:read->raw (car import))
|
|
,(utils:read->raw (cdr import)))))
|
|
(cddr link-clause))])
|
|
`(,tag (,sub-unit ,@imports))))
|
|
links))
|
|
(exports
|
|
(map
|
|
(lambda (export-clause)
|
|
`(,(utils:read->raw (car export-clause))
|
|
(,(utils:read->raw (cadr export-clause))
|
|
,(utils:read->raw (cddr export-clause)))))
|
|
exports)))
|
|
(let ((e `(#%compound-unit
|
|
(import ,@imports)
|
|
(link ,@links)
|
|
(export ,@exports))))
|
|
(values (expr-cheap-wrap e) null))))]
|
|
|
|
[(z:invoke-unit-form? expr)
|
|
(values
|
|
(expr-cheap-wrap `(#%invoke-unit ,(cheap-wrap-recur (z:invoke-unit-form-unit expr))
|
|
,@(map translate-varref
|
|
(z:invoke-unit-form-variables expr))))
|
|
null)]
|
|
|
|
[(z:interface-form? expr)
|
|
(let ([vars (z:interface-form-variables expr)])
|
|
(for-each utils:check-for-keyword vars)
|
|
(values
|
|
(expr-cheap-wrap
|
|
`(#%interface ,(map cheap-wrap-recur
|
|
(z:interface-form-super-exprs expr))
|
|
,@(map utils:read->raw vars)))
|
|
null))]
|
|
|
|
[(z:class*/names-form? expr)
|
|
(let* ([process-arg
|
|
(lambda (element)
|
|
(if (pair? element)
|
|
(and (utils:check-for-keyword (car element))
|
|
(list (get-binding-name (car element))
|
|
(cheap-wrap-recur (cdr element))))
|
|
(and (utils:check-for-keyword element)
|
|
(get-binding-name element))))]
|
|
[paroptarglist->ilist
|
|
(lambda (paroptarglist)
|
|
(cond
|
|
((z:sym-paroptarglist? paroptarglist)
|
|
(process-arg (car (z:paroptarglist-vars paroptarglist))))
|
|
((z:list-paroptarglist? paroptarglist)
|
|
(map process-arg (z:paroptarglist-vars paroptarglist)))
|
|
((z:ilist-paroptarglist? paroptarglist)
|
|
(let loop ((vars (map process-arg
|
|
(z:paroptarglist-vars paroptarglist))))
|
|
(if (null? (cddr vars))
|
|
(cons (car vars) (cadr vars))
|
|
(cons (car vars) (loop (cdr vars))))))
|
|
(else
|
|
(e:internal-error paroptarglist
|
|
"Given to paroptarglist->ilist"))))])
|
|
(values
|
|
(expr-cheap-wrap
|
|
`(#%class*/names
|
|
(,(get-binding-name (z:class*/names-form-this expr))
|
|
,(get-binding-name (z:class*/names-form-super-init expr)))
|
|
,(cheap-wrap-recur (z:class*/names-form-super-expr expr))
|
|
,(map cheap-wrap-recur (z:class*/names-form-interfaces expr))
|
|
,(paroptarglist->ilist (z:class*/names-form-init-vars expr))
|
|
,@(map
|
|
(lambda (clause)
|
|
(cond
|
|
((z:public-clause? clause)
|
|
`(public
|
|
,@(map (lambda (internal export expr)
|
|
`((,(get-binding-name internal)
|
|
,(utils:read->raw export))
|
|
,(cheap-wrap-recur expr)))
|
|
(z:public-clause-internals clause)
|
|
(z:public-clause-exports clause)
|
|
(z:public-clause-exprs clause))))
|
|
((z:override-clause? clause)
|
|
`(override
|
|
,@(map (lambda (internal export expr)
|
|
`((,(get-binding-name internal)
|
|
,(utils:read->raw export))
|
|
,(cheap-wrap-recur expr)))
|
|
(z:override-clause-internals clause)
|
|
(z:override-clause-exports clause)
|
|
(z:override-clause-exprs clause))))
|
|
((z:private-clause? clause)
|
|
`(private
|
|
,@(map (lambda (internal expr)
|
|
`(,(get-binding-name internal)
|
|
,(cheap-wrap-recur expr)))
|
|
(z:private-clause-internals clause)
|
|
(z:private-clause-exprs clause))))
|
|
((z:inherit-clause? clause)
|
|
`(inherit
|
|
,@(map (lambda (internal inherited)
|
|
`(,(get-binding-name internal)
|
|
,(utils:read->raw inherited)))
|
|
(z:inherit-clause-internals clause)
|
|
(z:inherit-clause-imports clause))))
|
|
((z:rename-clause? clause)
|
|
`(rename
|
|
,@(map (lambda (internal import)
|
|
`(,(get-binding-name internal)
|
|
,(utils:read->raw import)))
|
|
(z:rename-clause-internals clause)
|
|
(z:rename-clause-imports clause))))
|
|
((z:sequence-clause? clause)
|
|
`(sequence
|
|
,@(map cheap-wrap-recur
|
|
(z:sequence-clause-exprs clause))))))
|
|
(z:class*/names-form-inst-clauses expr))))
|
|
null))]
|
|
|
|
[else
|
|
(e:internal-error
|
|
expr
|
|
"stepper:annotate/inner: unknown object to annotate, ~a~n"
|
|
expr)])))
|
|
|
|
(define (annotate/top-level expr)
|
|
(let-values ([(annotated dont-care)
|
|
(annotate/inner expr 'all #f #t)])
|
|
annotated)))
|
|
|
|
; body of local
|
|
|
|
(let* ([annotated-exprs (map (lambda (expr)
|
|
(annotate/top-level expr))
|
|
parsed-exprs)])
|
|
(values annotated-exprs
|
|
struct-proc-names))))
|
|
|
|
)
|
|
|