;;; (SHOW-CONTOUR env who extent) --- Prints out a contour in a pleasant
;;; format. The 2nd argument is used to identify the owner of the
;;; contour. The 3rd argument specifies how many bindings constitute
;;; the contour. If a closure, it is assumed that the contour was
;;; created by expanding this closure. If a number, that many bindings
;;; are printed. Otherwise, a healthy chunk of the (non-global) environment
;;; is printed. Returns that portion of the environment not shown.
(define SHOW-CONTOUR
(lambda simple [env who extent]
(cond [(number extent) ; This many bindings.
(block
(p who) (nl)
(show-bindings env extent))]
[(closure extent) ; Pattern will tell us extent of contour.
(show-contour env who (length (pattern-variables extent)))]
[$T ; Show some of it???
(show-contour env who (min 10 (length (non-global-segment env))))])))
;;; (SHOW-BINDINGS env n) --- Prints out the first n variable bindings
;;; of the given environment. Returns the tail of the environment
;;; that begins with the first binding not printed. (This procedure
;;; should probably be local to SHOW-CONTOUR.)
(define SHOW-BINDINGS
(lambda simple [env n]
(if (or (empty env) (<= n 0))
env
(block
(ps %" %") (p (1st (1st env))) (ps %" => %") (p (2nd (1st env))) (nl)
(show-bindings (rest env) (1- n))))))
;;; @ADVISED-PROCEDURES --- Variable designating a sequence of advice records
;;; so that advice can be undone. Each entry has the form:
;;;
;;; [kind-of-advice whos-advice advised-closure original-closure]
;;;
(set @ADVISED-PROCEDURES (scons))
;;; *-* Commentary is out of date *-*
;;;
;;; ADVISE --- Install advice. 1st argument should be an atom
;;; indication what kind of advice is being given. 2nd argument
;;; should be an atom that identifies who was advised. 3rd
;;; argument is closure that will be advised (destructively, but
;;; in an undoable manner). 4th argument is the advice procedure.
;;; The advice procedure will be called whenever the given closure
;;; is reduced. It will be pass 4 arguments. 1. An unadvised version
;;; of the original closure so that the reduction may be carried out
;;; unhindered. 2. The normalised or un-normalised arguments of the
;;; reduction, dependant on whether or not the original closure is simple.
;;; 3. The environment in effect at the time of the reduction. 4. The
;;; continuation.
;;;
;;; e.g. (ADVISE 'TRACE-ENTRY-ADVISE 'foo ↑foo
;;; (lambda simple [kind tag proc a e c]
;;; (block
;;; (ps %"Entering %") (p tag) (nl)
;;; (reduce proc a e c))))
(define ADVISE
(lambda simple [advice-kind tag proc advice]
(let [[original (closure-copy proc)]]
(block
(replace proc (add-advice advice-kind tag original advice))
(set @advised-procedures
(prep [advice-kind tag proc original] @advised-procedures))
tag))))
;;; ADD-ADVICE --- Arrange for advice to be called whenever a
;;; particular closure is to be reduced. PROC designates
;;; a closure. ADVICE designates a function of 6 arguments:
;;; the kind of advice, a tag identifying this piece of advice,
;;; the closure being reduced (or copy thereof), the arguments to this
;;; reduction, and an environment and continuation. The result
;;; designates a closure. Note that the result will always have
;;; the same procedure-type (SIMPLE or REFLECT) as the original
;;; closure.
(define ADD-ADVICE
(lambda simple [advice-kind tag proc advice]
(if (reflective proc)
↑(lambda reflect [a e c]
(\(add-advice advice-kind tag (de-reflect proc) advice) a e c))
↑(lambda simple x
((lambda reflect [[] e c]
(advice advice-kind tag proc ↑x e c)))))))
(define UNADVISE
(lambda simple [who-to-unadvise]
(labels
[[loop
(lambda simple [advice-list]
(cond [(empty advice-list) advice-list]
[(= (2nd (1st advice-list)) who-to-unadvise)
(block
(replace (3rd (1st advice-list)) (4th (1st advice-list)))
(p (1st (1st advice-list))) (nl)
(loop (rest advice-list)))]
[$T
(prep (1st advice-list) (loop (rest advice-list)))]))]]
(set @advised-procedures (loop @advised-procedures)))))
(define ADVICE
(lambda simple [who]
(labels
[[loop
(lambda simple [advice-list]
(cond [(empty advice-list) (scons)]
[(= (2nd (1st advice-list)) who)
(prep (1st advice-list)
(loop (rest advice-list)))]
[$T (loop (rest advice-list))]))]]
(map 1st (loop @advised-procedures)))))
(define UNADVISE-ALL
(lambda simple []
(block
(do [[x @advised-procedures (rest x)]]
[[(empty x) 'ok]]
(let [[[kind var advised-proc clone] (1st x)]]
(block
(replace advised-proc clone)
(p var) (ps %" %") (p kind) (nl))))
(set @advised-procedures (scons)))))
(define TRACE
(lambda macro [var]
~(trace-both ,↑var ↑,var)))
(define TRACE-BOTH
(lambda simple [tag closure]
(block
(if (reflective closure)
(reflective-trace-both tag closure)
(simple-trace-both tag closure)))))
(define SIMPLE-TRACE-BOTH
(lambda simple [tag closure]
(block
(advise 'TRACE-BOTH-ADVICE
tag
closure
simple-trace-both-advice)
tag)))
(define REFLECTIVE-TRACE-BOTH
(lambda simple [tag closure]
(block
(cond [(not (rail (pattern closure))) ; Can't find continuation.
(simple-trace-both tag closure)]
[(macro-closure closure) ; Trace expansion of macro
(trace-both tag (binding 'expander (environment closure)))]
[(reflect!-closure closure) ; Trace after args normalised
(trace-both tag (binding 'fun (environment closure)))]
[$T
(advise 'TRACE-BOTH-ADVICE
tag
closure
reflective-trace-both-advice)])
tag)))
(define SIMPLE-TRACE-BOTH-ADVICE
(lambda simple [advice-kind tag proc! args! env cont]
(let [[new-env (bind (pattern proc!) args! (environment proc!))]]
(block
(show-contour new-env tag proc!)
(normalise (body proc!) new-env
(lambda simple [result]
(block
(p tag) (ps %" returns %") (p result) (nl)
(cont result))))))))
(define REFLECTIVE-TRACE-BOTH-ADVICE
(lambda simple [advice-kind tag proc! args! env cont]
(let [[new-env (bind (pattern proc!)
args!
(environment proc!))]]
(block
(show-contour new-env tag proc!)
(rebind (3rd (pattern proc!))
(add-advice 'CPS-EXIT-ADVICE
~(,(3rd (pattern proc!)) . ,tag)
(binding (3rd (pattern proc!)) new-env)
trace-entry-advice)
new-env)
(normalise (body proc!) new-env cont)))))
(define MAKE-CPS-TRACE-EXIT-ADVICE
(lambda simple [cont-var]
(lambda simple [advice-kind tag proc! args! env cont]
(let [[new-env (bind (pattern proc!)
args!
(environment proc!))]]
(block
(rebind cont-var
(add-advice 'CPS-EXIT-ADVICE
~(,cont-var OF ,tag)
(binding cont-var new-env)
trace-entry-advice)
new-env)
(normalise (body proc!) new-env cont))))))
(define TRACE-ENTRY-ADVICE
(lambda simple [advice-kind tag proc! args! env cont]
(let [[new-env (bind (pattern proc!) args! (environment proc!))]]
(block
(show-contour new-env tag proc!)
(normalise (body proc!) new-env cont)))))
(define TRACE-EXIT-ADVICE
(lambda simple [advice-kind tag proc! args! env cont]
(reduce proc! args! env
(lambda simple [result]
(block
(p tag) (ps %" returns %") (p result) (ps %".%") (nl)
(cont result))))))
(define BREAK-ENTRY-ADVICE
(lambda simple [advice-kind tag proc! args! env cont]
(let [[new-env (bind (pattern proc!) args! (environment proc!))]]
(block
(show-contour new-env tag proc!)
(ps %"Break inside simple procedure.%") (nl)
(read-normalise-print tag new-env primary-stream)
(ps %"Break terminated.%") (nl)
(normalise (body proc!) new-env cont)))))
(define BREAK-EXIT-ADVICE
(lambda simple [advice-kind tag proc! args! env cont]
(reduce proc! args! env
(lambda simple [result]
(block
(ps %"About to return.%") (nl)
(let [[new-env (prep ['result result]
(bind (pattern proc!)
args!
(environment proc!)))]]
(block
(show-contour new-env tag proc!)
(ps %"Breaking inside it.%") (nl)
(read-normalise-print tag new-env primary-stream)
(ps %"Break terminated.%") (nl)
(cont (binding 'result new-env)))))))))
;;; ADVISE-AROUND-BODY --- Takes advice in the form of an expression to
;;; be normalised instead of the usual body of a particular closure.
;;; This expression will be normalised in an environment in which the
;;; atom & is bound to the (lambda-delayed) original body.
;;;
;;; Note that this form of advising only works for SIMPLE and REFLECT
;;; procedures. Other kinds, such as MACRO or REFLECT!, flop due to
;;; the fact that the pattern and body of such procedures is not what
;;; you'd expect if you wrote (LAMBDA REFLECT! {p} {b}).
;;;
;;; e.g. (ADVISE-AROUND-BODY 'BODY-ADVICE 'fact ↑fact '(if (= n 3) 6 (&)))
;;;
(define ADVISE-AROUND-BODY
(lambda simple [advice-kind tag proc new-body]
(let [[clone-of-original (closure-copy proc)]]
(block
(replace proc
(ccons (procedure-type proc)
(environment-designator proc)
(pattern proc)
~(let [[& (lambda simple [] ,(body proc))]] ,new-body)))
(set @advised-procedures
(prep [advice-kind tag proc clone-of-original] @advised-procedures))
tag))))
;;; ADVISE-BODY --- Uses ADVISE-AROUND-BODY to add a single extra statement
;;; at the start of the procedures body. Only works properly for (LAMBDA
;;; SIMPLE ...) and (LAMBDA REFLECT ...) procedures.
;;;
;;; e.g. (ADVISE-BODY 'BODY-ADVICE 'fact ↑fact '(print n primary-stream))
;;;
;;; would net the same result as redefining FACT as follows:
;;;
;;; (define FACT
;;; (lambda simple [x]
;;; (block (print n primary-stream)
;;; (if (= n 0) 1 (* n (fact (1- n)))))))
(define ADVISE-BODY
(lambda simple [advice-kind tag proc extra-code]
(advise-around-body advice-kind tag proc ~(block ,extra-code (&)))))