"Copyright (c) 2015, Mark Tarver All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of Mark Tarver may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." (defun shen.f_error (V2327) (do (shen.prhush (cn "partial function " (shen.app V2327 "; " shen.a)) (stoutput)) (do (if (and (not (shen.tracked? V2327)) (y-or-n? (cn "track " (shen.app V2327 "? " shen.a)))) (shen.track-function (ps V2327)) shen.ok) (simple-error "aborted")))) (defun shen.tracked? (V2328) (element? V2328 (value shen.*tracking*))) (defun track (V2329) (let Source (ps V2329) (shen.track-function Source))) (defun shen.track-function (V2330) (cond ((and (cons? V2330) (and (= defun (hd V2330)) (and (cons? (tl V2330)) (and (cons? (tl (tl V2330))) (and (cons? (tl (tl (tl V2330)))) (= () (tl (tl (tl (tl V2330)))))))))) (let KL (cons defun (cons (hd (tl V2330)) (cons (hd (tl (tl V2330))) (cons (shen.insert-tracking-code (hd (tl V2330)) (hd (tl (tl V2330))) (hd (tl (tl (tl V2330))))) ())))) (let Ob (eval-kl KL) (let Tr (set shen.*tracking* (cons Ob (value shen.*tracking*))) Ob)))) (true (shen.f_error shen.track-function)))) (defun shen.insert-tracking-code (V2331 V2332 V2333) (cons do (cons (cons set (cons shen.*call* (cons (cons + (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.input-track (cons (cons value (cons shen.*call* ())) (cons V2331 (cons (shen.cons_form V2332) ())))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons (cons let (cons Result (cons V2333 (cons (cons do (cons (cons shen.output-track (cons (cons value (cons shen.*call* ())) (cons V2331 (cons Result ())))) (cons (cons do (cons (cons set (cons shen.*call* (cons (cons - (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons Result ()))) ()))) ()))) ())))) ()))) ()))) ())))) (set shen.*step* false) (defun step (V2338) (cond ((= + V2338) (set shen.*step* true)) ((= - V2338) (set shen.*step* false)) (true (simple-error "step expects a + or a -. ")))) (defun spy (V2343) (cond ((= + V2343) (set shen.*spy* true)) ((= - V2343) (set shen.*spy* false)) (true (simple-error "spy expects a + or a -. ")))) (defun shen.terpri-or-read-char () (if (value shen.*step*) (shen.check-byte (read-byte (value *stinput*))) (nl 1))) (defun shen.check-byte (V2348) (cond ((= V2348 (shen.hat)) (simple-error "aborted")) (true true))) (defun shen.input-track (V2349 V2350 V2351) (do (shen.prhush (cn " " (shen.app (shen.spaces V2349) (cn "<" (shen.app V2349 (cn "> Inputs to " (shen.app V2350 (cn " " (shen.app (shen.spaces V2349) "" shen.a)) shen.a)) shen.a)) shen.a)) (stoutput)) (shen.recursively-print V2351))) (defun shen.recursively-print (V2352) (cond ((= () V2352) (shen.prhush " ==>" (stoutput))) ((cons? V2352) (do (print (hd V2352)) (do (shen.prhush ", " (stoutput)) (shen.recursively-print (tl V2352))))) (true (shen.f_error shen.recursively-print)))) (defun shen.spaces (V2353) (cond ((= 0 V2353) "") (true (cn " " (shen.spaces (- V2353 1)))))) (defun shen.output-track (V2354 V2355 V2356) (shen.prhush (cn " " (shen.app (shen.spaces V2354) (cn "<" (shen.app V2354 (cn "> Output from " (shen.app V2355 (cn " " (shen.app (shen.spaces V2354) (cn "==> " (shen.app V2356 "" shen.s)) shen.a)) shen.a)) shen.a)) shen.a)) (stoutput))) (defun untrack (V2357) (eval (ps V2357))) (defun profile (V2358) (shen.profile-help (ps V2358))) (defun shen.profile-help (V2363) (cond ((and (cons? V2363) (and (= defun (hd V2363)) (and (cons? (tl V2363)) (and (cons? (tl (tl V2363))) (and (cons? (tl (tl (tl V2363)))) (= () (tl (tl (tl (tl V2363)))))))))) (let G (gensym shen.f) (let Profile (cons defun (cons (hd (tl V2363)) (cons (hd (tl (tl V2363))) (cons (shen.profile-func (hd (tl V2363)) (hd (tl (tl V2363))) (cons G (hd (tl (tl V2363))))) ())))) (let Def (cons defun (cons G (cons (hd (tl (tl V2363))) (cons (subst G (hd (tl V2363)) (hd (tl (tl (tl V2363))))) ())))) (let CompileProfile (shen.eval-without-macros Profile) (let CompileG (shen.eval-without-macros Def) (hd (tl V2363)))))))) (true (simple-error "Cannot profile. ")))) (defun unprofile (V2364) (untrack V2364)) (defun shen.profile-func (V2365 V2366 V2367) (cons let (cons Start (cons (cons get-time (cons run ())) (cons (cons let (cons Result (cons V2367 (cons (cons let (cons Finish (cons (cons - (cons (cons get-time (cons run ())) (cons Start ()))) (cons (cons let (cons Record (cons (cons shen.put-profile (cons V2365 (cons (cons + (cons (cons shen.get-profile (cons V2365 ())) (cons Finish ()))) ()))) (cons Result ())))) ())))) ())))) ()))))) (defun profile-results (V2368) (let Results (shen.get-profile V2368) (let Initialise (shen.put-profile V2368 0) (@p V2368 Results)))) (defun shen.get-profile (V2369) (trap-error (get V2369 profile (value *property-vector*)) (lambda E 0))) (defun shen.put-profile (V2370 V2371) (put V2370 profile V2371 (value *property-vector*)))