(define C-PROC
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'PROC-NF)))))

(define C-ARGS
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'ARGS-NF)))))

(define C-FIRST
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'FIRST-NF)))))

(define C-REST!
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'REST-NF)))))

(define C-IF
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'PREMISE-NF)))))

(define C-BEGIN
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'JUNK-NF)))))

(define C-REPLY
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'RESULT-NF)))))

(define C-SET
  (lambda [c]
      (let [[p (pattern c)]]
         (and (rail p) (= (length p) 1)
              (= (first p) 'RHS-NF)))))


(define TRACE-CONTINUATIONS
   (lambda [c]
      (let [[new-c ((tracer c) c)]]
         (if (closure new-c)
             (trace-continuations new-c)
             'OK))))



(define TRACE-NON-STANDARD-CONTINUATION
   (lambda [c]
      (begin
         (print-string "Non-standard continuation" primary-stream)
         (let [[[w x] (who c)]]
            (cond [(= w 'PROBABLY)
                   (begin
                      (print-string ", probably " primary-stream)
                      (print x primary-stream))]
                  [(= w 'INSIDE)
                   (begin
                      (print-string ", probably internal to " primary-stream)
                      (print x primary-stream))]
                  [$T (print-string w primary-stream)]))
         (newline primary-stream)
         (print-string "Backtrace will resume with whatever you THROW it." primary-stream)
         (newline primary-stream)
         (print-string "You'll be in an environment with these non-global variables: " primary-stream)
         (print-vector (non-local-variables (environment c)))
         (read-normalise-print #t (environment c) primary-stream))))



(define FFF
   (lambda reflect [exp env esc cont]
      (begin
         (print ps "+++ Backtrace +++ " cr)
         (trace-continuations ^cont)
         (print ps cr "+++ End backtrace +++ " cr)
         (normalize (first exp) env esc cont))))



(define TRACE-C-PROC
   (lambda [c]
      (begin
         (print ps "C-PROC" cr
            "     PROC-NF => "
            (binding 'PROC-NF (closure-environment c)) cr)
         (binding 'CONT (closure-environment c)))))



(define TRACE-C-ARGS
   (lambda [c]
      (begin
         (print ps "C-ARGS" cr
            "     ARGS-NF => "
            (binding 'ARGS-NF (closure-environment c)) cr)
         (binding 'CONT (closure-environment c)))))



(define TRACE-C-FIRST
   (lambda [c]
      (begin
         (print ps "C-FIRST" cr
            "     FIRST-NF => "
            (binding 'FIRST-NF (closure-environment c)) cr)
         (binding 'CONT (closure-environment c)))))



(define TRACE-C-REST
   (lambda [c]
      (begin
         (print ps "C-REST" cr)
         (binding 'CONT (closure-environment c)))))


(define TRACER
   (lambda [x]
      (cond [(not (closure x)) trace-non-closure]
            [(c-proc x) trace-c-proc] 
            [(c-args x) trace-c-args] 
            [(c-first x) trace-c-first] 
            [(c-rest x) trace-c-rest] 
            [(c-if x) trace-c-if] 
            [(c-begin x) trace-c-begin] 
            [(c-set x) trace-c-set]
            [(c-reply x) trace-c-reply]
            [$T trace-non-standard-continuation])))



(define TRACE-NON-CLOSURE
   (lambda [x]
      (begin
         (print ps "Backtrace terminated at a non-closure: " cr
            x cr)
         'DONE)))



(define TRACE-C-REPLY
   (lambda [c]
      (begin
         (print ps "C-REPLY" cr
            "     RESULT-NF => "
            (binding 'LEVEL (closure-environment c)) cr)
         'DONE)))



(define TRACE-C-IF
   (lambda [c]
      (begin
         (print ps "C-IF" cr
            "     PREMISE-NF => "
            (binding 'PREMISE-NF (closure-environment c)) cr)
         (binding 'CONT (closure-environment c)))))



(define TRACE-C-BEGIN
   (lambda [c]
      (begin
         (print ps "C-BEGIN" cr)
         (binding 'CONT (closure-environment c)))))


(define TRACE-C-SET
   (lambda [c]
      (begin
         (print ps "C-SET" cr)         
         (binding 'CONT (closure-environment c)))))



(define WHO
   (lambda [x]
      (if (not (closure x))
          [" (not a closure)" '?]
          [" of unknown origin" '?])))



(define MAKE-FRAME
   (lambda [frame-kind frame-closure frame-env frame-cont frame-tag]
       (list frame-kind frame-closure frame-env frame-cont frame-tag)))

(define FRAME-KIND first)
(define FRAME-CLOSURE second)
(define FRAME-ENV third)
(define FRAME-CONT fourth)



(define EXTRACT-FRAME
   (lambda [proc]
      (cond [(not (closure proc))
             (error-extract-frame-expecting-closure)]
            [(c-proc! proc) (make-standard-frame 'PROC proc)]
            [(c-args! proc) (make-standard-frame 'ARGS proc)]
            [(c-first! proc) (make-standard-frame 'FIRST proc)]
            [(c-rest! proc) (make-standard-frame 'REST proc)]
            [(c-reply proc)
             (make-frame
               'REPLY
                proc
                \(binding 'ENV (closure-environment proc))
                'NONE
                '*YOU*)]
            [(c-begin proc) (make-standard-frame 'BLOCK proc)]
            [(c-set proc) (make-standard-frame 'SET proc)]
            [(c-if proc) (make-standard-frame 'IF proc)]
            [(= proc ^id) (make-frame 'ID proc 'NONE 'NONE '*NONE*)]
            [$true (extract-frame-from-stranger proc)])))


(define MAKE-STANDARD-FRAME
   (lambda [frame-name proc]
      (make-frame
        frame-name
        proc
        \(binding 'ENV (closure-environment proc))
        \(binding 'CONT (closure-environment proc))
        '?)))



(define EXTRACT-FRAME-FROM-STRANGER
   (lambda [proc]
      (let [[non-globals (variables (non-global-segment (environment proc)))]]
         (begin
            (print ps "Non-standard continuation encountered." cr
               "Non-globals available to you: "
               non-globals cr 
               "Give me the 5 fields of stack frame: ")
            (designation (read-structure ps) (closure-environment proc))))))



(define FOO
   (lambda [x]
      (begin
         (foo (set x (if (and (or $F (ggg (= x 1)))) 1 2)))
         1)))



(define GGG
   (rlambda [[exp] env cont]
      (begin
         (backtrace cont)
         (normalise exp env cont))))



(define EXTRACT-STACK
   (lambda [proc]
      (let [[frame (extract-frame proc)]]
         (if (function (frame-cont frame))
             (cons frame (extract-stack ^(frame-cont frame)))
             (list frame)))))



(define FRAME-TAG fifth)



(define COLLAPSE-STACK
   (lambda [frame-stack]
      (cond [(null frame-stack) frame-stack] 
            [(null (rest frame-stack)) frame-stack] 
            [(= ^(frame-env (first frame-stack))
                ^(frame-env (second frame-stack)))
             (collapse-stack
                (cons 
                   (make-frame
                     (clump (frame-kind (first frame-stack))
                       (frame-kind (second frame-stack)))
                     (clump (frame-closure (first frame-stack))
                       (frame-closure (second frame-stack)))
                     (frame-env (first frame-stack))
                     (frame-cont (first frame-stack))
                     (if (= (frame-tag (second frame-stack)) '?)
                         (frame-tag (first frame-stack))
                         (frame-tag (second frame-stack))))
                   (tail 2 frame-stack)))]
            [$T (cons (first frame-stack)
                      (collapse-stack (rest frame-stack)))])))



(define ENV-AFTER-EXPAND-CLOSURE
   (lambda [env proc]
      (if (and (sequence env) (closure proc)) 
          (let [[locals (pattern-variables proc)]
                [all-vars (map first (non-global-segment env))]
                [non-locals (map first (non-global-segment (environment proc)))]]
             (= (append locals non-locals) all-vars))
          $F)))



(define FILL-IN-TAGS
   (lambda [frame-stack]
      (map fill-in-frame-tag frame-stack)))



(define FILL-IN-FRAME-TAG
   (lambda [frame]
      (do [[x (non-global-segment (frame-env frame)) (rest x)]]
          [[(null x) frame]
           [(env-after-expand-closure (frame-env frame) (second (first x)))
            (make-frame (frame-kind frame)
                        (frame-closure frame)
                        (frame-env frame)
                        (frame-cont frame)
                        (first (first x)))]])))



(define SHOW-STACK
   (lambda [frame-stack]
      (if (null frame-stack)
          'OK
          (begin
             (show-frame (first frame-stack))
             (show-stack (rest frame-stack))))))



(define SHOW-FRAME
   (lambda [arg]
      (let [[tag (fourth arg)]]
         (print ps " <- " tag))))



(define BACKTRACE
   (lambda [cont]
      (letseq [[f1 (extract-stack ^cont)]
               [f2 (collapse-stack f1)]
               [f3 (fill-in-tags f2)]]
         (begin
            (print ps cr "Present state")
            (show-stack f3)
            (print ps cr)))))