#lang racket/base

(require (prefix-in kernel: syntax/kerncase)
         racket/match
         racket/contract
         "marks.rkt"
         "shared.rkt"
         "shared-typed.rkt"
         "syntax-hider.rkt"
         "syntax-property.rkt"
         "my-macros.rkt"
         #;"xml-box.rkt"
         (prefix-in beginner-defined: "beginner-defined.rkt")
         (for-syntax racket/base))

(define-syntax (where stx)
  (syntax-case stx ()
    [(_ body bindings)
     (syntax/loc stx (letrec bindings body))]))

; CONTRACTS


; PROVIDE
(provide/contract
 [annotate
  (syntax?                         ; syntax to annotate
   ((or/c continuation-mark-set? false/c) 
    break-kind?
    (or/c list? false/c)
    . -> .
    any/c)                       ; procedure for runtime break
   boolean?   ; show-lambdas-as-lambdas?
   . -> .
   syntax?)]                       ; result
 
 #;[top-level-rewrite (-> syntax? syntax?)])


;    ;                                               
;   ; ;                         ;          ;         
;   ; ;    ; ;;   ; ;;    ;;;  ;;;;  ;;;  ;;;;  ;;;  
;   ; ;    ;;  ;  ;;  ;  ;   ;  ;   ;   ;  ;   ;   ; 
;  ;   ;   ;   ;  ;   ;  ;   ;  ;       ;  ;   ;   ; 
;  ;;;;;   ;   ;  ;   ;  ;   ;  ;    ;;;;  ;   ;;;;; 
;  ;   ;   ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;     
; ;     ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;     
; ;     ;  ;   ;  ;   ;   ;;;    ;;  ;;;;;  ;;  ;;;; 




;  oh-say-can-you-see,by-the-dawn's-early-light,what-so-proudly-we-hailed,at-the-twilight's-last-gle
;  a m i n g . W h o s e b r o a d s t r i                                                         p
;  pe s a n d b r i g h t s t a r s , t hrough-the-perilous-night,o'er-the-ramparts-we-watched,were-
;  s o g a l l a n t l y s t r e a m i n g                                                         .
;  an d t h e r o c k e t ' s r e d g l are,the-bombs-bursting-in-air,gave-proof-through-the-night,,
;  t h a t o u r f l a g w a s s t i l l t                                                         h
;  er e . O h s a y , d o e s t h a t s tar-spangled-banner-yet-wave,o'er-the-land-of-the-free,and-t
;  h e h o m e o f t h e b r a v e ? . . .                                                         .
;  .. . . . . . . . . . . . . . . . . . ............................................................
;  . . . . . . . . . . . . . . . . . . . .                                                         .
;  .........you-know,-this-flag-doesn't-feel-quite-as...............................................
;  .                                                                                               .
;  ..........lighthearted-as-it-did-when-I-created-it-in-1998.......................................
;  .                                                                                               .
;  .................................................................................................
;  .                                                                                               .
;  .................................................................................................
;  .                                                                                               .
;  .................................................................................................
;  .                                                                                               .
;  .................................................................................................
;  .                                                                                               .
;  .................................................................................................
;  .                                                                                               .
;  .................................................................................................
;


;; given an expression to annotate, and a 'break' expression to call 
;; when a breakpoint occurs, and a boolean indicating whether
;; lambdas are to be displayed as lambdas, return an annotated expression.
(define (annotate main-exp break show-lambdas-as-lambdas?)
  
  ;; check for identifiers ending in underscore numbers
  ;; invariant: the user's program is all wrapped in a single module.
  (define max-underscore (program-max-underscore main-exp))
  (define starting-index (cond [max-underscore (add1 max-underscore)]
                               [else 0]))
  
  (define binding-indexer
    (let ([binding-index starting-index])
      (lambda ()
        (let ([temp binding-index])
          (set! binding-index (+ binding-index 1))
          temp))))
  
  (define (normal-break)
    (break (current-continuation-marks) 'normal-break #f))
  
  (define (result-exp-break)
    (break (current-continuation-marks) 'result-exp-break #f))
  
  (define (result-value-break vals-list)
    (break (current-continuation-marks) 'result-value-break vals-list))
  
  (define (normal-break/values vals-list)
    (break (current-continuation-marks) 'normal-break/values vals-list))
  
  (define (exp-finished-break info-list)
    (break #f 'expr-finished-break info-list))
  
  (define (double-break)
    (break (current-continuation-marks) 'double-break #f))
  
  (define ((make-opaque-exp-break exp))
    (exp-finished-break 
     (list (list (lambda () exp) 
                 #f 
                 (lambda () (error 'make-define-struct-break
                                   "no getter for a define-struct"))))))
  
  ; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr
  (define (wcm-pre-break-wrap debug-info exp)
    (wcm-wrap debug-info (pre-break-wrap exp)))
  
  ;; wrap a pre-break around stx
  (define (pre-break-wrap stx)
    #`(begin (#%plain-app #,result-exp-break) #,stx))
  
  ;; wrap a normal break around stx
  (define (break-wrap exp)
    #`(begin (#%plain-app #,normal-break) #,exp));
  
  ;; wrap a double-break around exp
  (define (double-break-wrap exp)
    #`(begin (#%plain-app #,double-break) #,exp))
  
  ;; abstraction used in the next two defs
  (define (return-value-wrap-maker break-proc) 
    (lambda (exp)
      #`(#%plain-app
         call-with-values
         (#%plain-lambda () #,exp)
         (#%plain-lambda args
           (#%plain-app #,break-proc args)
           (#%plain-app #,apply values args)))))
  
  ;; wrap a return-value-break around exp
  (define return-value-wrap
    (return-value-wrap-maker result-value-break))
  
  ;; wrap a normal-break/values around exp
  (define normal-break/values-wrap
    (return-value-wrap-maker normal-break/values))
  
  (define (top-level-annotate/inner exp source-exp defined-name)
    (match-let* 
        ([(vector annotated dont-care)
          (annotate/inner exp 'all #f defined-name)])
      #`(with-continuation-mark #,debug-key 
          #,(make-top-level-mark source-exp)
          ;; inserting eta-expansion to prevent destruction of top-level mark
          (#%plain-app
           call-with-values (#%plain-lambda () #,annotated)
           (#%plain-lambda args (#%plain-app #,apply values args))))))
  
  ; annotate/inner takes 
  ; a) an expression to annotate
  ; b) a list of all bindings which this expression is tail w.r.t. 
  ;    or 'all to indicate that this expression is tail w.r.t. _all_ bindings.
  ; d) a boolean indicating whether this expression will be the r.h.s. of a reduction
  ;    (and therefore should be broken before)
  ; g) information about the binding name of the given expression.  This is used 
  ;    to associate a name with a closure mark (though this may now be redundant)
  
  ; it returns (as a 2vals)
  ; a) an annotated s-expression
  ; b) a list of varrefs for the variables which occur free in the expression
  ;
  ;(syntax-object BINDING-SET bool bool (or/c #f symbol (list binding symbol)) -> 
  ;          sexp (list-of z:varref))
  
  
  
  
  
  ;                                                       ;  ;                           
  ;                              ;          ;             ;                              
  ;   ;;;   ; ;;   ; ;;    ;;;  ;;;;  ;;;  ;;;;  ;;;     ;   ;  ; ;;   ; ;;    ;;;   ; ;;
  ;  ;   ;  ;;  ;  ;;  ;  ;   ;  ;   ;   ;  ;   ;   ;    ;   ;  ;;  ;  ;;  ;  ;   ;  ;;  
  ;      ;  ;   ;  ;   ;  ;   ;  ;       ;  ;   ;   ;    ;   ;  ;   ;  ;   ;  ;   ;  ;   
  ;   ;;;;  ;   ;  ;   ;  ;   ;  ;    ;;;;  ;   ;;;;;   ;    ;  ;   ;  ;   ;  ;;;;;  ;   
  ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;       ;    ;  ;   ;  ;   ;  ;      ;   
  ;  ;   ;  ;   ;  ;   ;  ;   ;  ;   ;   ;  ;   ;       ;    ;  ;   ;  ;   ;  ;      ;   
  ;   ;;;;; ;   ;  ;   ;   ;;;    ;;  ;;;;;  ;;  ;;;;   ;    ;  ;   ;  ;   ;   ;;;;  ;   
  ;  ;                                 
  ;                                 
  
  (define annotate/inner
    #;(syntax? binding-set? boolean? (or/c false/c syntax? (list/p syntax? syntax?)) (or/c false/c integer?)
               . -> . (vector/p syntax? binding-set?))
    (lambda (exp tail-bound pre-break? procedure-name-info)
      
      ;; annotate an exp with a stepper/skipto or stepper-skipto/discard
      ;; label. If force-discard? is true, then we use a discarding
      ;; reconstruction regardless of the tag
      (define (dont-annotate)
        ;; mutable, to catch free vars. Mutated several times, we
        ;; only care about the last. A bit yecchy.
        (define free-vars-captured #f)
        
        (define (subterm-recur subterm)
          (match-let* 
              ([(vector stx free-vars)
                (annotate/inner subterm tail-bound pre-break?
                                procedure-name-info)])
            (set! free-vars-captured free-vars)
            stx))
        
        (define annotated (skipto/auto exp #f subterm-recur))
        
        (vector (wcm-wrap skipto-mark annotated) free-vars-captured))

      ;; recurrence procedures, used to recur on sub-expressions:

      (define (tail-recur exp) (annotate/inner exp tail-bound
                                               #t procedure-name-info))
      (define (non-tail-recur exp) (annotate/inner exp null #f #f))
      (define (result-recur exp) (annotate/inner exp null
                                                 #f procedure-name-info))
      (define (set!-rhs-recur exp name) (annotate/inner exp null #f name))
      (define (let-rhs-recur exp binding-names dyn-index-syms)
        (define proc-name-info 
          (if (not (null? binding-names))
              (list (car binding-names) (car dyn-index-syms))
              #f))
        (annotate/inner exp null #f proc-name-info))
      (define (lambda-body-recur exp) (annotate/inner exp 'all #t #f))
      
      
      ; let bodies have a startling number of recurrence patterns. ouch!  
      ;; ... looks like these can maybe be collapsed with a simpler desired reduction sequence
      ;; (a.k.a. not safe-for-space).
                  
      ;; no pre-break, tail w.r.t. new bindings:
      (define (let-body-recur/single exp bindings)
        (annotate/inner exp (binding-set-union (list tail-bound bindings))
                        #f procedure-name-info))
                  
      ;; different flavors of make-debug-info allow users to provide only the needed fields:
                  
      (define (make-debug-info/normal free-bindings)
        (make-debug-info exp tail-bound free-bindings 'none #t))
      
      (define (make-debug-info/app tail-bound free-bindings label)
        (make-debug-info exp tail-bound free-bindings label #t))
      
      (define (make-debug-info/let free-bindings binding-list let-counter)
        (make-debug-info 
         exp 
         (binding-set-union (list tail-bound 
                                  binding-list
                                  (list let-counter)))
         (varref-set-union (list free-bindings 
                                 binding-list
                                 (list let-counter))) ; NB using bindings as varrefs
         'let-body
         #t))
      (define (make-debug-info/fake-exp exp free-bindings)
        (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) 
                         tail-bound free-bindings 'none #t))
      
      (define (make-debug-info/fake-exp/tail-bound exp tail-bound free-bindings)
        (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) 
                         tail-bound free-bindings 'none #t))
                  
      (define outer-wcm-wrap (if pre-break?
                                 wcm-pre-break-wrap
                                 wcm-wrap))
      (define (wcm-break-wrap debug-info exp)
        (outer-wcm-wrap debug-info (break-wrap exp)))
                  
      ;; used for things that are values:
      (define (normal-bundle free-vars annotated)
        (vector (outer-wcm-wrap (make-debug-info/normal free-vars)
                                annotated)
                free-vars))
      
      
      ;    @@                 @@         @@        
      ;     @                  @          @        
      ;     @     $@$: @@+-$:  @-@$    $@:@   $@$: 
      ;     @       -@  @+@$@  @+ *$  $* *@     -@ 
      ;     @    -$@$@  @ @ @  @   @  @   @  -$@$@ 
      ;     @    $*  @  @ @ @  @   @  @   @  $*  @ 
      ;     @    @- *@  @ @ @  @  +$  $* *@  @- *@ 
      ;   @@@@@  -$$-@@@@@@@@@@@+@$    $@:@@ -$$-@@
      ;                                                        
      
      (define (lambda-clause-abstraction clause)
        (with-syntax ([(args-stx . bodies) clause])
          (match-let* 
              ([(vector annotated-body free-varrefs)
                ; wrap bodies in explicit begin if more than 1 
                ; user-introduced (non-skipped) bodies
                ; NB: CAN'T HAPPEN in beginner up through int/lambda
                (let ([non-skipped-bodies
                       (filter 
                        (lambda (clause)
                          (not (to-be-skipped? clause)))
                        (syntax->list (syntax bodies)))])
                  (if (> (length non-skipped-bodies) 1)
                      (lambda-body-recur (syntax (begin . bodies)))
                      (match-let* 
                          ([(vector annotated-bodies free-var-sets)
                            (2vals-map lambda-body-recur
                                       (syntax->list #`bodies))])
                        (vector #`(begin . #,annotated-bodies)
                                (varref-set-union free-var-sets)))))]
               [new-free-varrefs 
                (varref-set-remove-bindings
                 free-varrefs
                 (arglist-flatten #'args-stx))])
            (vector (datum->syntax
                     #'here
                     `(,#'args-stx ,annotated-body) #'clause)
                    new-free-varrefs))))
      
      
      (define (outer-lambda-abstraction annotated-lambda free-varrefs)
        (let*
            ([closure-info (make-debug-info/app 'all free-varrefs 'none)]
             ;; if we manually disable the storage of names, 
             ;; lambdas get rendered as lambdas.
             ;; Yikes, this seems like a pretty gross hack... JBC 2010-12
             [closure-name 
              (if show-lambdas-as-lambdas?
                  #f
                  (cond [(syntax? procedure-name-info) procedure-name-info]
                        [(pair? procedure-name-info) (car procedure-name-info)]
                        [else #f]))]
             
             [closure-storing-proc
              (lambda (clo debug-info maybe-index)
                (annotated-proc
                 clo
                 (Closure-Record
                  ;; FIXME WHEN TR HAS SYNTAX CHAPERONES
                  (if closure-name (sstx closure-name) #f)
                  ;; FIXME WHEN MARKS ENTER THE TYPED SIDE
                  (smrk debug-info)
                  ;; FIXME WHEN TR HAS SYNTAX CHAPERONES
                  (if maybe-index (sstx maybe-index) #f))))]
             
             [captured
              (cond [(pair? procedure-name-info)
                     #`(#%plain-app 
                        #,closure-storing-proc
                        #,annotated-lambda
                        #,closure-info 
                        #,(cadr procedure-name-info))]
                    [else
                     #`(#%plain-app
                        #,closure-storing-proc
                        #,annotated-lambda
                        #,closure-info
                        #f)])]
             
             ;; gnarr! I can't find a test case
             ;; that depends on the attachment of the inferred name...
             [inferred-name-struct
              (if closure-name
                  (syntax-property
                   captured
                   'inferred-name
                   (syntax-e closure-name))
                  captured)])
         
         (normal-bundle free-varrefs inferred-name-struct)))
      
      
                  
      
      
      ;    @@                 
      ;     @            @    
      ;     @    -@@$   @@@@@ 
      ;     @    $  -$   @    
      ;     @    @@@@@   @    
      ;     @    $       @    
      ;     @    +:      @: :$
      ;   @@@@@   $@@+   :@@$-
      
      
      ; The let transformation is complicated.
      ; here's a sample transformation (not including 'break's):
      ;(let-values ([(a b c) e1] [(d e) e2]) e3)
      ;
      ;turns into
      ;
      ;(let ([counter (<dynamic-counter-call>)])
      ;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter)
      ;              (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated*
      ;                      counter counter counter counter counter 0)])
      ;  (with-continuation-mark 
      ;   key huge-value
      ;   (begin
      ;     (set!-values (a b c) e1)
      ;     (set! let-counter 1)
      ;     (set!-values (d e) e2)
      ;     (set! let-counter 2)
      ;     e3))))
      ;
      ; note that this elaboration looks exactly like the one for letrec, and that's
      ; okay, because expand guarantees that reordering them will not cause capture.
      ; this is because a bound variable answers is considered bound by a binding only when
      ; the pair answers true to bound-identifier=?, which is determined during (the first)
      ; expand.
      
      ; 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?
      
      ; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of 
      ;  continuations; backing up a computation using a set! will not revert the
      ;  counter, and the stepper may think that the computation is in a different 
      ;  place.  To fix this, we must go to a pure let* with nested marks at each right-hand-side.
      
      ; 2006-01: oh dear heaven.  Begin expands into a let-values.  This means that the 
      ;  let-values really has most of the complexity of the whole stepper, all in one 
      ;  place.  Re-formulating the bodies as a begin and re-calling annotate/inner broke
      ;  implied invariants (in particular, that annotate/inner was only called on subexprs)
      ;  and confused the heck out of me for some time today.  Bleah.  I'm just going to 
      ;  do the whole expansion here. Also, I'm going to make this expansion call/cc-clean, 
      ;  because I think it'll actually be easier to state & read this way.
      
      ; 2006-11: appears to work now.  I'm about to try to transfer this new idiom to begin0;
      ;  wish me luck.
      
      
      (define (let-abstraction stx output-identifier)
        (with-syntax ([(_ ([(var ...) val] ...) . bodies) stx])
          (match-let*
              ([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))]
               [binding-list (apply append binding-sets)]
               [vals (syntax->list #'(val ...))]
               [lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)]
               [lifted-vars (apply append lifted-var-sets)]
               [(vector annotated-vals free-varref-sets-vals)
                (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)]
               [bodies-list (syntax->list #'bodies)]
               [(vector annotated-body free-varrefs-body)
                (if (= (length bodies-list) 1)
                    (let-body-recur/single (car bodies-list) binding-list)
                    ;; oh dear Lord, we have to unfold these like an application:
                    (let unroll-loop ([bodies-list bodies-list] [outermost? #t])
                      (cond [(null? bodies-list)
                             (error 'annotate "no bodies in let")]
                            [(null? (cdr bodies-list))
                             (tail-recur (car bodies-list))]
                            [else
                             (match-let*
                              ([(vector rest free-vars-rest) 
                                (unroll-loop (cdr bodies-list) #f)]
                               [(vector this-one free-vars-this)
                                (non-tail-recur (car bodies-list))]
                               [free-vars-all
                                (varref-set-union (list free-vars-rest
                                                        free-vars-this))]
                               [debug-info (make-debug-info/fake-exp 
                                            #`(begin #,@bodies-list)
                                            free-vars-all)]
                               [begin-form 
                                 #`(begin 
                                     #,(normal-break/values-wrap this-one) 
                                     #,rest)])
                              (vector (if outermost?
                                          (wcm-wrap debug-info begin-form)
                                          (wcm-pre-break-wrap debug-info
                                                              begin-form))
                                      free-vars-all))])))])
           
           ((vector (quasisyntax/loc 
                        exp 
                      (let ([#,counter-id (#,binding-indexer)])
                        (#,output-identifier #,outer-initialization #,wrapped-begin))) 
                    free-varrefs)
            
            . where .
            
            ([free-varrefs (varref-set-remove-bindings 
                            (varref-set-union (cons free-varrefs-body
                                                    free-varref-sets-vals)) 
                            binding-list)]
             [counter-id #`lifting-counter]
             [unevaluated-list (map (lambda (b) *unevaluated*)  binding-list)]
             [outer-initialization
              #`([(#,@lifted-vars #,@binding-list #,let-counter)
                  (values #,@(append (map (lambda (dc_binding) counter-id)
                                          binding-list)
                                     unevaluated-list
                                     (list 0)))])]
             [counter-clauses (build-list 
                               (length binding-sets)
                               (lambda (num)
                                 #`(set! #,let-counter #,(+ num 1))))]
             [set!-clauses
              (map (lambda (binding-set val)
                     #`(set!-values #,binding-set #,val))
                   binding-sets
                   annotated-vals)]
             [exp-finished-clauses
              
              (with-syntax  ([(_ let-clauses . dc) stx]
                             [((lifted-var ...) ...) lifted-var-sets])
                (with-syntax ([(exp-thunk ...) (map (lx (lambda () _))
                                                    (syntax->list #`let-clauses))])
                  #`(#%plain-app 
                     list 
                     (#%plain-app
                      list exp-thunk
                      (#%plain-app
                       list lifted-var ...)
                      (#%plain-lambda () (#%plain-app list var ...))) ...)))]
             ; time to work from the inside out again
             ; without renaming, this would all be much much simpler.
             [wrapped-begin (outer-wcm-wrap (make-debug-info/let free-varrefs
                                                                 binding-list
                                                                 let-counter) 
                                            (double-break-wrap
                                             #`(begin #,@(apply append (zip set!-clauses counter-clauses))
                                                      (#%plain-app #,exp-finished-break #,exp-finished-clauses)
                                                      #,annotated-body)))])))))
      
      
                  
                  
                  
                  
                  
      
      
      ;     @     :@@$ 
      ;           @:   
      ;   -@@    @@@@@ 
      ;     @     @    
      ;     @     @    
      ;     @     @    
      ;     @     @    
      ;   @@@@@  @@@@@ 
      
      ; if-abstraction: (-> syntax? syntax? (or/c false/c syntax?) (values syntax? varref-set?))
      (define (if-abstraction test then else) 
        (match-let*
            ([(vector annotated-test free-varrefs-test) 
              (non-tail-recur test)]
             [test-with-break
              (normal-break/values-wrap annotated-test)]
             [(vector annotated-then free-varrefs-then) 
              (tail-recur then)]
             [(vector annotated-else free-varrefs-else)
              (if else
                  (tail-recur else)
                  (vector #f null))]
             [free-varrefs (varref-set-union (list free-varrefs-test 
                                                   free-varrefs-then 
                                                   free-varrefs-else))]
             [annotated-if 
              (if else
                  (quasisyntax/loc exp 
                    (if #,test-with-break #,annotated-then #,annotated-else))
                  (quasisyntax/loc exp 
                    (if #,test-with-break #,annotated-then)))])
          (vector
           (outer-wcm-wrap (make-debug-info/normal free-varrefs) annotated-if)
           free-varrefs)))
      
      
                  
      
      
      ;                                            
      ;                                            
      ;                                        ;;; 
      ;                                       ;    
      ;                                       ;    
      ;   ;   ;   ;;;;  ; ;;;  ; ;;;   ;;;  ;;;;;; 
      ;   ;   ;  ;   ;  ;;  ;  ;;  ;  ;   ;   ;    
      ;    ; ;   ;   ;  ;      ;      ;;;;;   ;    
      ;    ; ;   ;   ;  ;      ;      ;       ;    
      ;    ; ;   ;  ;;  ;      ;      ;       ;    
      ;     ;     ;; ;  ;      ;       ;;;;   ;    
      ;                                            
      ;                                            
      ;                                            
      
      
      (define (varref-abstraction var)
        (match-let* 
            ([free-varrefs (list var)]
             [varref-break-wrap
              (lambda ()
                (wcm-break-wrap (make-debug-info/normal free-varrefs)
                                (return-value-wrap var)))]
             [varref-no-break-wrap
              (lambda ()
                (outer-wcm-wrap (make-debug-info/normal free-varrefs) var))]
             ;; JBC: shouldn't this be the namespace of the user's code... ?
             [base-namespace-symbols (namespace-mapped-symbols (make-base-namespace))]
             [module-bound-varref-break-wrap
              (lambda ()
                (varref-break-wrap)
                #;(if (or (memq (syntax-e var) beginner-defined:must-reduce)
                        (and (stepper-syntax-property var 'lazy-op)
                             (not (memq (syntax->datum var) base-namespace-symbols))))
                    (varref-break-wrap)
                    (varref-no-break-wrap)))])
          (vector 
           (match (stepper-syntax-property var 'stepper-binding-type)
             [(or 'lambda-bound 'macro-bound)   (varref-no-break-wrap)]
             ['let-bound                        (varref-break-wrap)]
             ['non-lexical ;; is it from this module or not?
              (match (identifier-binding var)
                ;; this can only come up when stepping through non-module code...
                ;; perhaps we should just signal an error here.
                (#f (varref-break-wrap))
                ['lexical  
                 ;; my reading of the docs suggest that this should not occur in v4...
                 (error 'varref-abstraction 
                        "identifier-binding should not be 'lexical")]
                [(list-rest (? module-path-index? path-index) dontcare)
                 (let-values ([(module-path dc5)
                               (module-path-index-split path-index)])
                   (if module-path
                       ;; not a module-local variable:
                       (module-bound-varref-break-wrap)
                       ;; a module-local-variable:
                       (varref-break-wrap)))]
                [other (error 
                        'annotate
                        "unexpected value for identifier-binding: ~v" other)])]
             [other
              (error 'annotate 
                     "unexpected value for stepper-binding-type on variable ~e: ~e"
                     (syntax->datum var)
                     other)])
           free-varrefs)))
                  
      (define (recertifier vals)
        (match-let* ([(vector new-exp bindings) vals])
          (vector new-exp
                  (map (lambda (b) b)
                       bindings))))

      ;; this is a terrible hack... until some other language form needs it. 
      ;; It wraps the given annotated expression with a break that adds the 
      ;; result to the list of completed expressions
      (define maybe-final-val-wrap
        (match-lambda 
          [(vector annotated free-vars) 
           (vector (if (stepper-syntax-property exp 'stepper-use-val-as-final)
                       #`(#%plain-app
                          call-with-values 
                          (#%plain-lambda () #,annotated)
                          (#%plain-lambda 
                           results
                           (#,exp-finished-break 
                            (#%plain-app list
                                         (#%plain-app 
                                          list
                                          #,(lambda () exp)
                                          #f
                                          (#%plain-lambda () results))))
                                          (#%plain-app values results)))
                       annotated)
                   free-vars)]
          [error 'maybe-final-val-wrap "stepper internal error 20080527"]))
      
      (cond [(or (stepper-syntax-property exp 'stepper-skipto)
                 (stepper-syntax-property exp 'stepper-skipto/discard))
             (dont-annotate)]
            [(to-be-skipped? exp)
             (vector (wcm-wrap "supposed to be skipped" exp) null)]
            
            [else
             (let ([exp (disarm exp)])
              (recertifier
              (maybe-final-val-wrap
               (kernel:kernel-syntax-case 
                exp #f
                
                [(#%plain-lambda . clause)
                 (match-let* 
                     ([(vector annotated-clause free-varrefs)
                       (lambda-clause-abstraction (syntax clause))]
                      [annotated-lambda
                       (with-syntax ([annotated-clause annotated-clause])
                         (syntax/loc exp (#%plain-lambda . annotated-clause)))])
                   (outer-lambda-abstraction annotated-lambda free-varrefs))]
                
                [(case-lambda . clauses)
                 (match-let* 
                     ([(vector annotated-cases free-varrefs-cases)
                       (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
                      [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
                                               (syntax/loc exp (case-lambda . annotated-cases)))]
                      [free-varrefs (varref-set-union free-varrefs-cases)])
                   (outer-lambda-abstraction annotated-case-lambda free-varrefs))]
                
                
                
                [(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))]
                
                
                ;                                     
                ;                                     
                ;   ;                     ;           
                ;   ;                                 
                ;   ;                                 
                ;   ; ;;    ;;;    ;;;; ;;;     ; ;;  
                ;   ;;  ;  ;   ;  ;   ;   ;     ;;  ; 
                ;   ;   ;  ;;;;;  ;   ;   ;     ;   ; 
                ;   ;   ;  ;      ;   ;   ;     ;   ; 
                ;   ;   ;  ;      ;  ;;   ;     ;   ; 
                ;   ;;;;    ;;;;   ;; ;   ;;;   ;   ; 
                ;                     ;               
                ;                 ;;;;                
                ;                                     
                
                
                [(begin . bodies-stx)
                 (begin
                   (error 'annotate-inner "nothing expands into begin! : ~v" (syntax->datum exp))
                   #;(begin-abstraction (syntax->list #`bodies-stx)))]
                
                
                ;                                            
                ;                                            
                ;   ;                     ;             ;;   
                ;   ;                                  ;  ;  
                ;   ;                                 ;   ;; 
                ;   ; ;;    ;;;    ;;;; ;;;     ; ;;  ;  ; ; 
                ;   ;;  ;  ;   ;  ;   ;   ;     ;;  ; ;  ; ; 
                ;   ;   ;  ;;;;;  ;   ;   ;     ;   ; ; ;  ; 
                ;   ;   ;  ;      ;   ;   ;     ;   ; ;;   ; 
                ;   ;   ;  ;      ;  ;;   ;     ;   ; ;;  ;  
                ;   ;;;;    ;;;;   ;; ;   ;;;   ;   ;   ;;   
                ;                     ;                      
                ;                 ;;;;                       
                ;                                            
                
                ;; one-element begin0 is a special case, because in this case only
                ;; the body of the begin0 is in tail position.
                
                [(begin0 body)
                 (match-let* ([(vector annotated-body free-vars-body) 
                               (tail-recur #'body)])
                   (vector (wcm-break-wrap (make-debug-info/normal free-vars-body)
                                           (quasisyntax/loc exp (begin0 #,annotated-body)))
                           free-vars-body))]
                
                
                [(begin0 first-body . bodies-stx)
                 (match-let*
                     ([(vector annotated-first free-vars-first) (result-recur #'first-body)]
                      [(vector annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))]
                      [wrapped-rest (map normal-break/values-wrap annotated-rest)]
                      [all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))]
                      [early-debug-info (make-debug-info/normal all-free-vars)]
                      [tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)]
                      [debug-info-maker
                       (lambda (rest-exps)
                         (make-debug-info/fake-exp/tail-bound
                          #`(begin0 #,@rest-exps)
                          (binding-set-union (list (list tagged-temp) tail-bound))
                          (varref-set-union (list (list tagged-temp) all-free-vars))))]
                      [rolled-into-fakes 
                       (let loop ([remaining-wrapped wrapped-rest] 
                                  [remaining-src (syntax->list #`bodies-stx)]
                                  [first-time? #t])
                         ((if first-time? wcm-wrap wcm-pre-break-wrap)
                          (debug-info-maker remaining-src)   
                          (cond [(null? remaining-src) begin0-temp]
                                [else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped)
                                                                                 (cdr remaining-src)
                                                                                 #f))])))])
                   (vector (wcm-wrap early-debug-info
                                     #`(let ([#,begin0-temp #,annotated-first])
                                         #,rolled-into-fakes))
                           all-free-vars))]
                                            
                [(let-values . _) (let-abstraction exp #`let-values)]
                
                [(letrec-values . _) (let-abstraction exp #`letrec-values)]
                
                
                ;                          $   
                ;                  @       @   
                ;   :@@+@  -@@$   @@@@@    @   
                ;   @$ -@  $  -$   @       @   
                ;   :@@$-  @@@@@   @       @   
                ;      *@  $       @           
                ;   @  :@  +:      @: :$       
                ;   $+@@:   $@@+   :@@$-   $   
                
                
                [(set! var val)
                 (match-let*
                     ([(vector annotated-val val-free-varrefs)
                       (set!-rhs-recur (syntax val) 
                                       (syntax-case (syntax var) (#%top)
                                         [(#%top . real-var) (syntax-e (syntax real-var))]
                                         [else (syntax var)]))]
                      [free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
                      [annotated-set!
                       (return-value-wrap
                        (quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))])
                   (vector
                    (outer-wcm-wrap (make-debug-info/normal free-varrefs) annotated-set!)
                    free-varrefs))]
                
                
                ;                         @           
                ;    $@-@@@@  @@   $@$   @@@@@  -@@$  
                ;   $- :@  @   @  $- -$   @     $  -$ 
                ;   @   @  @   @  @   @   @     @@@@@ 
                ;   @   @  @   @  @   @   @     $     
                ;   $- :@  @: +@  $- -$   @: :$ +:    
                ;    $@-@  :@$-@@  $@$    :@@$-  $@@+ 
                ;       @                             
                ;      @@@                            
                
                [(quote _)
                 (normal-bundle null exp)]
                
                [(quote-syntax _)
                 (normal-bundle null exp)]
                
                
                ;  @@@ @@@         $@+@        @@+-$: 
                ;   @   @         $+ -@         @+@$@ 
                ;   $-@ @  @@@@@  @      @@@@@  @ @ @ 
                ;   ++@+$         @             @ @ @ 
                ;   :@@$+         $* -$         @ @ @ 
                ;   -@$@*          $@$-        @@@@@@@
                
                
                [(with-continuation-mark key mark body)
                 ;(match-let* ([(annotated-key free-varrefs-key)
                 ;              (non-tail-recur (syntax key))]
                 ;             [(annotated-mark free-varrefs-mark)
                 ;              (non-tail-recur (syntax mark))]
                 ;             [(annotated-body dc_free-varrefs-body)
                 ;              (result-recur (syntax body))])
                 (error 'annotate/inner "this region of code is still under construction")
                 
                 ;                                       [annotated #`(let-values ([key-temp #,*unevaluated*]
                 ;                                             [mark-temp #,*unevaluated*]
                 ;)
                 ]
                
                
                ;                         @@      @                           @                 
                ;                          @                          @                         
                ;    $@$: @@:@$- @@:@$-    @    -@@     $@+@   $@$:  @@@@@  -@@     $@$  @@:@@: 
                ;      -@  @: -$  @: -$    @      @    $+ -@     -@   @       @    $- -$  @+ :@ 
                ;   -$@$@  @   @  @   @    @      @    @      -$@$@   @       @    @   @  @   @ 
                ;   $*  @  @   @  @   @    @      @    @      $*  @   @       @    @   @  @   @ 
                ;   @- *@  @: -$  @: -$    @      @    $* -$  @- *@   @: :$   @    $- -$  @   @ 
                ;   -$$-@@ @-@$   @-@$   @@@@@  @@@@@   $@$-  -$$-@@  :@@$- @@@@@   $@$  @@@ @@@
                ;          @      @                                                             
                ;         @@@    @@@                                                            
                
                
                ;                                  [foot-wrap? 
                ;                                   (wcm-wrap debug-info annotated)])
                ;                           free-bindings))]
                
                ; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc
                ; are temp identifiers that do not occur in the program:
                ; (M0 ...)
                ;
                ; goes to
                ;
                ;(let ([t0 *unevaluated*]
                ;      ...)
                ;  (with-continuation-mark
                ;   debug-key
                ;   huge-value
                ;   (set! t0 M0)
                ;   ...
                ;   (with-continuation-mark
                ;    debug-key
                ;    much-smaller-value
                ;    (t0 ...))))
                ; 
                ; 'break's are not illustrated.  An optimization is possible when all expressions M0 ... are
                ; varrefs.  In particular (where v0 ... are varrefs):
                ; (v0 ...)
                ;
                ; goes to
                ; 
                ; (with-continuation-mark
                ;  debug-key
                ;  debug-value
                ;  (v0 ...))
                ;
                ; in other words, no real elaboration occurs. Note that this doesn't work as-is for the
                ; stepper, because there's nowhere to hang the breakpoint; you want to see the break
                ; occur after all vars have been evaluated.  I suppose you could do (wcm ... (begin v0 ... (v0 ...)))
                ; where the second set are not annotated ... but stepper runtime is not at a premium.
                
                ;; the call/cc-safe version of this appears to work, and it lives in the definition of let.  I should 
                ;; transfer that knowledge to here.  -- JBC, 2006-10-11
                
                [(#%plain-app . terms)
                 (match-let*
                     ([(vector annotated-terms free-varrefs-terms)
                       (2vals-map non-tail-recur (syntax->list (syntax terms)))]
                      [free-varrefs (varref-set-union free-varrefs-terms)])
                   (vector
                    (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)]
                           [tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp))
                                                  arg-temps)]
                           [let-clauses #`((#,tagged-arg-temps 
                                            (#%plain-app values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
                           [set!-list (map (lambda (arg-symbol annotated-sub-exp)
                                             #`(set! #,arg-symbol #,annotated-sub-exp))
                                           tagged-arg-temps annotated-terms)]
                           [new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))]
                           [app-debug-info (make-debug-info/app new-tail-bound tagged-arg-temps 'called)]
                           [app-term (quasisyntax/loc exp (#%plain-app #,@tagged-arg-temps))]
                           [debug-info (make-debug-info/app new-tail-bound
                                                            (varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars
                                                            'not-yet-called)]
                           [let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list
                                                                         #,(break-wrap
                                                                            (wcm-wrap
                                                                             app-debug-info
                                                                             #`(if (#%plain-app #,annotated-proc? #,(car tagged-arg-temps))
                                                                                   #,app-term
                                                                                   #,(return-value-wrap app-term))))))])
                      #`(let-values #,let-clauses #,let-body))
                    ;)
                    free-varrefs))]
                
                
                ;      @@                             
                ;       @          @                  
                ;    $@:@   $@$:  @@@@@ @@  @@ @@+-$: 
                ;   $* *@     -@   @     @   @  @+@$@ 
                ;   @   @  -$@$@   @     @   @  @ @ @ 
                ;   @   @  $*  @   @     @   @  @ @ @ 
                ;   $* *@  @- *@   @: :$ @: +@  @ @ @ 
                ;    $@:@@ -$$-@@  :@@$- :@$-@@@@@@@@@
                
                
                [(#%top . var-stx) (varref-abstraction #`var-stx)]
                
                [var-stx
                 (identifier? #`var-stx)
                 (varref-abstraction #`var-stx)]
                
                [else 
                 (error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))]))))])))
  
  ;; annotate/top-level : syntax-> syntax
  ;; expansion of teaching level language programs produces two kinds of 
  ;; expressions: modules containing all of the code in the def'ns window, and
  ;; require statements that invoke those modules.  In the first case, we must annotate
  ;; the expressions inside the top-level module, and in the second, we should just
  ;; leave it alone.
  
  (define/contract annotate/top-level
    (syntax? . -> . syntax?)
    (lambda (exp)
      (syntax-case exp (module #%plain-module-begin let-values dynamic-wind #%plain-lambda #%plain-app define-values)
        [(module name lang
           (#%plain-module-begin . bodies))
         #`(module name lang (#%plain-module-begin #,@(map annotate/module-top-level (syntax->list #`bodies))))]
        ; the 'require' form is used for the test harness
        [(require module-name) exp]
        ; the 'dynamic-require' form is used by the actual expander 
        [(let-values ([(done-already?) . rest1])
           (#%plain-app dynamic-wind
                        void
                        (#%plain-lambda () . rest2)
                        (#%plain-lambda () . rest3)))
         exp]
        ; STC: for lazy, handle defines
        [(define-values (ids ...) bodies) (annotate/module-top-level exp)]
        [else (annotate/module-top-level exp)]
        #;[else
         (error `annotate/top-level "unexpected top-level expression: ~a\n"
                (syntax->datum exp))
         #;(annotate/module-top-level exp)])))
  
  #;(define/contract annotate/top-level/acl2
    (syntax? . -> . syntax?)
    (lambda (exp)
      (syntax-case exp (begin define-values #%plain-app)
        [(begin contract-thingy 
                (begin body (begin)))
         #`(begin contract-thingy (begin #,(annotate/module-top-level #`body) (begin)))]
        
        #;(define-values
            (lifted)
            (begin
              (#%app
               contract/proc
               provide/contract-contract-id-zp
               zp
               provide/contract-pos-module-source-zp
               (#%app module-source-as-symbol (quote-syntax here))
               (quote-syntax zp))))
        #;(if (#%app null? (#%app lifted (#%datum . 3))) 'y 'x)
        
        
        [else (annotate/module-top-level exp)]
        
        #;[else (begin
                  (eprintf "~v\n" (syntax->datum exp))
                  (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax->datum exp)))])))
  
  
  
  ;; annotate expressions at the top level within a module.
  (define (annotate/module-top-level exp)
    (cond [(stepper-syntax-property exp 'stepper-replace)]
          [(to-be-skipped? exp) exp]
          ;; for kathy's test engine:
          [(syntax-property exp 'test-call) exp]
          [(stepper-syntax-property exp 'stepper-black-box-expr)
           #`(begin #,exp
                    (#%plain-app #,(make-opaque-exp-break exp)))]
          [(stepper-syntax-property exp 'stepper-skipto)
           (skipto/auto exp #f annotate/module-top-level)] 
          [else 
           (syntax-case exp (#%app #%plain-app call-with-values define-values define-syntaxes 
                                   #%require #%provide #%declare begin #%plain-lambda lambda
                                   module module*)
             [(define-values (new-var ...) e)
              (let* ([name-list (syntax->list #`(new-var ...))]
                     [defined-name (if (and (pair? name-list) (null? (cdr name-list)))
                                       (car name-list)
                                       #f)])
                (stepper-recertify
                 #`(begin
                     (define-values (new-var ...)
                       #,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name))
                     ;; this next expression should deliver the newly computed values to an
                     ;; exp-finished-break
                     (#%plain-app #,exp-finished-break
                                  (#%plain-app list 
                                               (#%plain-app list
                                                            #,(lambda () exp)
                                                            #f
                                                            (#%plain-lambda ()
                                                                            (#%plain-app
                                                                             list
                                                                             new-var ...))))))
                 #'e))]
             [(define-syntaxes (new-vars ...) e)
              exp]
             [(#%require specs ...)
              ;; this should only include requires inserted automatically, as others should 
              ;; get caught above in the "stepper-black-box-expr" check:
              exp]
             [(#%provide specs ...)
              exp]
             [(#%declare specs ...)
              exp]
             [(module . _) ; submodule
              exp]
             [(module* . _) ; submodule
              exp]
             [(begin .  bodies)
              #`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))]
             ; STC: for lazy racket, need this case to catch and hide toplevel-forcer
             ; stepper tests will expand to this case, with call-with-values
             [(#%plain-app 
               call-with-values 
               (#%plain-lambda 
                ()
                (#%plain-app (#%plain-app toplevel-forcer) operand)) 
               print-values)
              (stepper-recertify
               #`(#%plain-app
                  call-with-values
                  (#%plain-lambda 
                   () 
                   (#%plain-app 
                    (#%plain-app toplevel-forcer)
                    #,(top-level-annotate/inner (top-level-rewrite #'operand) exp #f)))
                  (#%plain-lambda 
                   vals
                   (begin
                     (#,exp-finished-break
                      (#%plain-app 
                       list 
                       (#%plain-app 
                        list 
                        #,(lambda () exp) #f (#%plain-lambda () vals))))
                     (#%plain-app 
                      call-with-values 
                      (#%plain-lambda () vals) values))))
               exp)]
             [(#%plain-app call-with-values (#%plain-lambda () body) print-values)
              ;; re-extract the plain-lambda term, to use in recertification:
              (let ([lam-for-cert (syntax-case exp (#%plain-app call-with-values)
                                    [(#%plain-app call-with-values lam print-values) #'lam]
                                    [other (error 'annotate/module-top-level "unreachable 2010-01-23 22:14")])])
                ;; this recertify looks to be superfluous now that it has the "transparent" certificate-mode tag,
                ;; but it can't hurt, and I'd rather just leave it in here.
                (stepper-recertify 
                 #`(#%plain-app
                    call-with-values 
                    #,(stepper-recertify
                       #`(#%plain-lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f))
                       lam-for-cert)
                    (#%plain-lambda vals
                                    (begin
                                      (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () vals))))
                                      (#%plain-app
                                       call-with-values (#%plain-lambda () vals)
                                       print-values))))
                 exp))]
             ; STC: for lazy racket, need this case to catch and hide toplevel-forcer
             ; This is similar to app case above, but with toplevel-forcer
             ; normal lazy stepper operation expands to this case
             [(#%plain-app (#%plain-app toplevel-forcer) operand)
              (stepper-recertify
               #`(#%plain-app
                  call-with-values
                  (#%plain-lambda 
                   () 
                   (#%plain-app 
                    (#%plain-app toplevel-forcer)
                    #,(top-level-annotate/inner (top-level-rewrite #'operand) exp #f)))
                  (#%plain-lambda 
                   vals
                   (begin
                     (#,exp-finished-break
                      (#%plain-app 
                       list 
                       (#%plain-app 
                        list 
                        #,(lambda () exp) #f (#%plain-lambda () vals))))
                     (#%plain-app 
                      call-with-values 
                      (#%plain-lambda () vals) values))))
               exp)]
             [any
              (stepper-syntax-property exp 'stepper-test-suite-hint)
              (top-level-annotate/inner (top-level-rewrite exp) exp #f)]
             [else
              (top-level-annotate/inner (top-level-rewrite exp) exp #f)
              ;; the following check can't be permitted in the presence of things like test-suite cases
              ;; which produce arbitrary expressions at the top level.
              #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])]))
  
  
  ; body of local
  (annotate/top-level main-exp))

;
;  ;                         ;                      ;                                ;            
;  ;                         ;                      ;                                   ;         
; ;;;;  ;;;   ; ;;;          ;   ;;;  ;   ;   ;;;   ;      ; ;;  ;;;  ;   ;   ; ; ;; ; ;;;;  ;;;  
;  ;   ;   ;  ;;   ;         ;  ;   ; ;   ;  ;   ;  ;      ;;   ;   ; ;   ;   ; ;;   ;  ;   ;   ; 
;  ;   ;   ;  ;    ;         ;  ;   ;  ; ;   ;   ;  ;      ;    ;   ;  ; ; ; ;  ;    ;  ;   ;   ; 
;  ;   ;   ;  ;    ;  ;;;;;  ;  ;;;;;  ; ;   ;;;;;  ;      ;    ;;;;;  ; ; ; ;  ;    ;  ;   ;;;;; 
;  ;   ;   ;  ;    ;         ;  ;      ; ;   ;      ;      ;    ;      ; ; ; ;  ;    ;  ;   ;     
;  ;   ;   ;  ;;   ;         ;  ;      ;;    ;      ;      ;    ;      ; ; ; ;  ;    ;  ;   ;     
;   ;;  ;;;   ; ;;;          ;   ;;;;   ;     ;;;;  ;      ;     ;;;;   ;   ;   ;    ;   ;;  ;;;; 
;             ;                                                                                   
;             ;                                                                                   
;                                                                                                 


; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT)

; top-level-rewrite performs several tasks; it labels variables with their types 
; (let-bound, lambda-bound, or non-lexical), it flags if's which could come from 
; cond's, it labels the begins in conds with 'stepper-skip annotations.
; Why aren't these labels added earlier? Most of these labeling operations happen
; in teach.rkt, attached to the expansion (thereby keeping single point of control
; over the expansion and the corresponding tags. These, unfortunately, are performed
; in C (though you know, this might soon change... 2017-07-25), and are therefore
; added by this separate pass.


; label-var-types returns a syntax object which is identical to the 
; original except that the variable references are labeled with the 
; stepper-syntax-property 'stepper-binding-type, which is set to either 
; let-bound, lambda-bound, or non-lexical. (It can also be 'macro-bound, set
; earlier during macro expansion.)

(define (top-level-rewrite stx)
  (let loop ([stx stx]
             [let-bound-bindings null]
             [cond-test (lx #f)])
    (define (recur-regular stx)
      (loop stx let-bound-bindings (lx #f)))
    
    (define (recur-with-bindings exp vars)
      (loop exp (append vars let-bound-bindings) (lx #f)))
    
    (define (recur-in-cond stx new-cond-test)
      (loop stx let-bound-bindings new-cond-test))
    
    (define (do-let/rec stx rec?)
      (with-syntax ([(label ((vars rhs) ...) . bodies) stx])
        (let* ([vars-list 
                (apply append
                       (map syntax->list
                            (syntax->list (syntax (vars ...)))))]
               [labelled-vars-list 
                (map (lambda (var-list)
                       (map (lambda (exp)
                              (recur-with-bindings exp vars-list))
                            (syntax->list var-list)))
                     (syntax->list (syntax (vars ...))))]
               [rhs-list 
                (if rec?
                    (map (lambda (exp)
                           (recur-with-bindings exp vars-list))
                         (syntax->list #'(rhs ...)))
                    (map recur-regular (syntax->list #'(rhs ...))))]
               [new-bodies 
                (map (lambda (exp)
                       (recur-with-bindings exp vars-list))
                     (syntax->list #'bodies))]
               [new-bindings (map list labelled-vars-list rhs-list)])
          (datum->syntax
           stx
           `(,#'label ,new-bindings ,@new-bodies) stx stx))))
    
    
    ; evaluated at runtime, using 3D code:
    (define (put-into-xml-table val)
      (hash-set! finished-xml-box-table val #t)
      val)
    
    (cond 
      [(or (to-be-skipped? stx)
           (stepper-syntax-property stx 'stepper-black-box-expr))
       stx]
      [else
       (define disarmed-stx (disarm stx))
       (define rewritten
         (kernel:kernel-syntax-case 
          disarmed-stx
          #f
          ; cond :
          [(if test (let-values () then) else-stx)
           (let ([origin (syntax-property disarmed-stx 'origin)]
                 [rebuild-if
                  (lambda (new-cond-test)
                    (let* ([new-then (recur-regular (syntax then))]
                           [rebuilt 
                            (stepper-syntax-property
                             (rebuild-stx 
                              `(if ,(recur-regular (syntax test))
                                   ,new-then
                                   ,(recur-in-cond (syntax else-stx)
                                                   new-cond-test))
                              disarmed-stx)
                             'stepper-hint
                             'comes-from-cond)])
                      ; move the stepper-else mark to the if, if it's present:
                      (if (stepper-syntax-property (syntax test) 'stepper-else)
                          (stepper-syntax-property rebuilt 'stepper-else #t)
                          rebuilt)))])
             (cond [(cond-test disarmed-stx) ; continuing an existing 'cond'
                    (rebuild-if cond-test)]
                   [(and origin (pair? origin) 
                         (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
                    (rebuild-if (lambda (test-stx) 
                                  (and (eq? (syntax-source disarmed-stx)
                                            (syntax-source test-stx))
                                       (eq? (syntax-position disarmed-stx)
                                            (syntax-position test-stx)))))]
                   [else ; not from a 'cond' at all.
                    (rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) disarmed-stx)]))]
          [_ ; else clauses of conds; ALWAYS AN ERROR CALL
           (cond-test disarmed-stx)
           (stepper-syntax-property disarmed-stx 'stepper-skip-completely #t)]
          
          ; wrapper on a local.  This is necessary because 
          ; teach.rkt expands local into a trivial let wrapping a bunch of
          ; internal defines, and therefore the letrec-values on 
          ; which I want to hang the 'stepper-hint doesn't yet
          ; exist.  So we patch it up after expansion.  And we 
          ; discard the outer 'let' at the same time.
          [(let-values () expansion-of-local)
           (eq? (stepper-syntax-property disarmed-stx 'stepper-hint) 'comes-from-local)
           (syntax-case #`expansion-of-local (letrec-values)
             [(letrec-values (bogus-clause clause ...) . bodies)
              (recur-regular
               (stepper-syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))]
             [else (error 'top-level-rewrite "expected a letrec-values inside a local, given: ~e" 
                          (syntax->datum #`expansion-of-local))])]
          
          ; let/letrec :
          [(let-values x ...) (do-let/rec disarmed-stx #f)]
          [(letrec-values x ...) (do-let/rec disarmed-stx #t)]
          
          ; varref :
          [var
           (identifier? (syntax var))
           (stepper-syntax-property 
            (syntax var) 
            'stepper-binding-type
            (if (eq? (identifier-binding (syntax var)) 'lexical)
                (cond [(ormap (lx (bound-identifier=? _ (syntax var)))
                              let-bound-bindings)
                       'let-bound]
                      [else
                       'lambda-bound])
                'non-lexical))]
          
          [else
           (let ([content (syntax-e disarmed-stx)])
             (if (pair? content)
                 (rebuild-stx (syntax-pair-map content recur-regular) disarmed-stx)
                 disarmed-stx))]))
       
       (if (eq? (stepper-syntax-property stx 'stepper-xml-hint) 'from-xml-box)
           (stepper-syntax-property #`(#%plain-app 
                                       #,put-into-xml-table
                                       #,rewritten) 
                                    'stepper-skipto
                                    (list syntax-e cdr car))
           (stepper-recertify rewritten stx))])))



;; recertify the output of the stepper, to allow it to run:
(define (stepper-recertify new-stx old-stx)
  (syntax-rearm new-stx old-stx #t))

;; does this stx have the 'stepper-skip-completely property?
(define (to-be-skipped? stx)
  (stepper-syntax-property stx 'stepper-skip-completely))

;; given a syntax object, return the largest number that appears as part of
;; an identifier of the form .*_[0-9]+
;; yes, this will pick up user symbols as well, but who cares?
(define (program-max-underscore stx)
  (match stx
    [(? symbol? s) (match (symbol->string s)
                   ;; 0 is a special case because in other situations leading
                   ;; 0's disqualify the id from counting against the max
                   [(regexp #px"_0$") 0]
                   [(regexp #px"_([1-9][0-9]*)$" (list _ n)) (string->number n)]
                   [else #f])]
    [(cons f r) (maybe-max (program-max-underscore f)
                           (program-max-underscore r))]
    [(? syntax? so) (program-max-underscore (syntax-e so))]
    [other #f]))

;; return the maximum of two numbers-or-false. 
(define (maybe-max a b)
  (cond [(and a (not (real? a)))
         (raise-argument-error 'maybe-max "real or false"
                               0 a b)]
        [(and b (not (real? b)))
         (raise-argument-error 'maybe-max "real or false"
                               1 a b)]
        [(not a) b]
        [(not b) a]
        [else (max a b)]))

(module+ test
  (require rackunit)

  (check-equal? (maybe-max #f #f) #f)
  (check-equal? (maybe-max #f 3) 3)
  (check-equal? (maybe-max 3 #f) 3)

  (check-equal? (program-max-underscore #'(+ 3 4)) #f)
  (check-equal? (program-max-underscore #'(define x_0 4)) 0)
  ;; surprising but not a problem:
  (check-equal? (program-max-underscore #'(define x_0 'aoe_4)) 4)
  (check-equal? (program-max-underscore #'(define x_00 'aoe_04)) #f)
  )
