(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)))) )