aboutsummaryrefslogtreecommitdiff
path: root/src/interp/debug.lisp.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/debug.lisp.pamphlet')
-rw-r--r--src/interp/debug.lisp.pamphlet1235
1 files changed, 1235 insertions, 0 deletions
diff --git a/src/interp/debug.lisp.pamphlet b/src/interp/debug.lisp.pamphlet
new file mode 100644
index 00000000..8f73998d
--- /dev/null
+++ b/src/interp/debug.lisp.pamphlet
@@ -0,0 +1,1235 @@
+%% Oh Emacs, this is a -*- Lisp -*- file despite apperance.
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/debug.lisp} Pamphlet}
+\author{Timothy Daly}
+
+\begin{document}
+\maketitle
+
+\begin{abstract}
+\end{abstract}
+
+\tableofcontents
+\eject
+
+\section{interrupt}
+
+A "resumable" break loop for use in trace etc. Unfortunately this
+only works for CCL. We need to define a Common Lisp version. For
+now the function is defined but does nothing.
+<<interrupt>>=
+#-:CCL
+(defun interrupt (&rest ignore))
+
+#+:CCL
+(defun interrupt (&rest ignore)
+ (prog (prompt ifile ofile u v)
+ (setq ifile (rds *debug-io*))
+ (setq ofile (wrs *debug-io*))
+ (setq prompt (setpchar "Break loop (:? for help)> "))
+top (setq u (read))
+ (cond
+ ((equal u ':x) (go exit))
+ ((equal u ':r) (go resume))
+ ((equal u ':q)
+ (progn (lisp::enable-backtrace nil)
+ (princ "Backtrace now disabled")
+ (terpri)))
+ ((equal u ':v)
+ (progn (lisp::enable-backtrace t)
+ (princ "Backtrace now enabled")
+ (terpri)))
+ ((equal u ':?)
+ (progn
+ (princ ":Q disables backtrace")
+ (terpri)
+ (princ ":V enables backtrace")
+ (terpri)
+ (princ ":R resumes from break")
+ (terpri)
+ (princ ":X exits from break loop")
+ (terpri)
+ (princ "else enter LISP expressions for evaluation")
+ (terpri)))
+ ((equal u #\eof)
+ (go exit))
+ (t (progn
+ (setq v (errorset u nil nil))
+ (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) )
+ (go top)
+resume (rds ifile)
+ (wrs ofile)
+ (setpchar prompt)
+ (return nil)
+exit (rds ifile)
+ (wrs ofile)
+ (setpchar prompt)
+ (lisp::unwind)))
+
+@
+
+\section{License}
+
+<<license>>=
+;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+;;
+;; - Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; - 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.
+;;
+;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+;; names of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 THE COPYRIGHT OWNER
+;; OR CONTRIBUTORS 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.
+
+@
+<<*>>=
+<<license>>
+
+;;; @(#)debug.lisp 2.5 90/02/15 10:27:33
+
+; NAME: Debugging Package
+; PURPOSE: Debugging hooks for Boot code
+
+(in-package "BOOT")
+(use-package '("LISP" "VMLISP"))
+
+(DEFPARAMETER /COUNTLIST NIL)
+(DEFPARAMETER /TIMERLIST NIL)
+(DEFPARAMETER /TRACESIZE NIL "sets limit on size of object to be mathprinted")
+(DEFVAR CURSTRM *TERMINAL-IO*)
+(DEFVAR /TRACELETNAMES ())
+(DEFVAR /PRETTY () "controls pretty printing of trace output")
+(SETANDFILEQ /ECHO NIL) ;;"prevents echo of SPAD or BOOT code with /c"
+(MAKEPROP 'LISP '/TERMCHR '(#\ #\())
+(MAKEPROP 'LSP '/TERMCHR '(#\ #\())
+(MAKEPROP 'META '/TERMCHR '(#\: #\())
+(MAKEPROP 'INPUT '/TERMCHR '(#\: #\< #\ #\())
+(MAKEPROP 'SPAD '/TERMCHR '(#\: #\< #\ #\())
+(MAKEPROP 'BOOT '/TERMCHR '(#\: #\< #\ #\())
+(MAKEPROP 'INPUT '/XCAPE #\_)
+(MAKEPROP 'BOOT '/XCAPE '#\_)
+(MAKEPROP 'SPAD '/XCAPE '#\_)
+(MAKEPROP 'META '/READFUN 'META\,RULE)
+(MAKEPROP 'META '/TRAN '/TRANSMETA)
+(MAKEPROP 'INPUT '/READFUN '|New,LEXPR,Interactive|)
+(MAKEPROP 'INPUT '/TRAN '/TRANSPAD)
+(MAKEPROP 'BOOT '/READFUN '|New,LEXPR1|)
+(MAKEPROP 'BOOT '/TRAN '/TRANSNBOOT)
+(MAKEPROP 'SPAD '/READFUN '|New,LEXPR|)
+(MAKEPROP 'SPAD '/TRAN '/TRANSPAD)
+
+(defmacro |/C,LIB| (&rest L &aux optionlist /editfile
+ ($prettyprint 't) ($reportCompilation 't))
+ (declare (special optionlist /editfile $prettyprint $reportComilation))
+ `',(|compileConstructorLib| L (/COMP) NIL NIL))
+
+(defmacro /C (&rest L) `',(/D-1 L (/COMP) NIL NIL))
+
+(defmacro /CT (&rest L) `',(/D-1 L (/COMP) NIL 'T))
+
+(defmacro /CTL (&rest L) `',(/D-1 L (/COMP) NIL 'TRACELET))
+
+(defmacro /D (&rest L) `',(/D-1 L 'DEFINE NIL NIL))
+
+(defmacro /EC (&rest L) `', (/D-1 L (/COMP) 'T NIL))
+
+(defmacro /ECT (&rest L) `',(/D-1 L (/COMP) 'T 'T))
+
+(defmacro /ECTL (&rest L) `',(/D-1 L (/COMP) 'T 'TRACELET))
+
+(defmacro /E (&rest L) `',(/D-1 L NIL 'T NIL))
+
+(defmacro /ED (&rest L) `',(/D-1 L 'DEFINE 'T NIL))
+
+(defun heapelapsed () 0)
+
+(defun /COMP () (if (fboundp 'COMP) 'COMP 'COMP370))
+
+(DEFUN /D-1 (L OP EFLG TFLG)
+ (CATCH 'FILENAM
+ (PROG (TO OPTIONL OPTIONS FNL INFILE OUTSTREAM FN )
+ (declare (special fn infile outstream ))
+ (if (member '? L :test #'eq)
+ (RETURN (OBEY "EXEC SPADEDIT /C TELL")))
+ (SETQ OPTIONL (/OPTIONS L))
+ (SETQ FNL (TRUNCLIST L OPTIONL))
+ (SETQ OPTIONS (OPTIONS2UC OPTIONL))
+ (SETQ INFILE (/MKINFILENAM (/GETOPTION OPTIONS 'FROM)))
+ (SETQ TO (/GETOPTION OPTIONS 'TO))
+ (if TO (SETQ TO (/MKOUTFILENAM (/GETOPTION OPTIONS 'TO) INFILE)))
+ (SETQ OUTSTREAM (if TO (DEFSTREAM TO 'OUTPUT) CUROUTSTREAM))
+ (RETURN (mapcar #'(lambda (fn)
+ (/D-2 FN INFILE OUTSTREAM OP EFLG TFLG))
+ (or fnl (list /fn)))))))
+
+(DEFUN |/D,2,LIB| (FN INFILE CUROUTSTREAM OP EDITFLAG TRACEFLAG)
+ (declare (special CUROUTSTREAM))
+ "Called from compConLib1 (see LISPLIB BOOT) to bind CUROUTSTREAM."
+ (/D-2 FN INFILE CUROUTSTREAM OP EDITFLAG TRACEFLAG))
+
+(DEFUN /D-2 (FN INFILE OUTPUTSTREAM OP EDITFLAG TRACEFLAG)
+ (declare (special OUTPUTSTREAM))
+ (PROG (FT oft SFN X EDINFILE FILE DEF KEY RECNO U W SOURCEFILES
+ ECHOMETA SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM SPADERRORSTREAM
+ ISID NBLNK COMMENTCHR $TOKSTACK (/SOURCEFILES |$sourceFiles|)
+ METAKEYLST DEFINITION_NAME (|$sourceFileTypes| '(|spad| |boot| |lisp| |lsp| |meta|))
+ ($FUNCTION FN) $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK
+ TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE
+ (*COMP370-APPLY* (if (eq op 'define) #'eval-defun #'compile-defun)))
+ (declare (special ECHOMETA SINGLINEMODE XCAPE XTOKENREADER INPUTSTREAM
+ SPADERRORSTREAM ISID NBLNK COMMENTCHR $TOKSTACK /SOURCEFILES
+ METAKEYLST DEFINITION_NAME |$sourceFileTypes|
+ $FUNCTION $BOOT $NEWSPAD $LINESTACK $LINENUMBER STACK STACKX BACK OK
+ TRAPFLAG |$InteractiveMode| TOK COUNT ERRCOL COLUMN *QUERY CHR LINE))
+ (if (PAIRP FN) (SETQ FN (QCAR FN)))
+ (SETQ INFILE (OR INFILE (|getFunctionSourceFile| FN)))
+ ;; $FUNCTION is freely set in getFunctionSourceFile
+ (IF (PAIRP $FUNCTION) (SETQ $FUNCTION (QCAR $FUNCTION)))
+ (SETQ FN $FUNCTION)
+ (SETQ /FN $FUNCTION)
+ LOOP (SETQ SOURCEFILES
+ (cond ( INFILE
+ (SETQ /SOURCEFILES (CONS INFILE (REMOVE INFILE /SOURCEFILES)))
+ (LIST INFILE))
+ ( /EDITFILE
+ (|insert| (|pathname| /EDITFILE) /SOURCEFILES))
+ ( 't /SOURCEFILES)))
+ (SETQ RECNO
+ (dolist (file sourcefiles)
+ (SETQ INPUTSTREAM (DEFSTREAM FILE 'INPUT))
+
+ ;;?(REMFLAG S-SPADKEY 'KEY) ; hack !!
+ (SETQ FT (|pathnameType| FILE))
+ (SETQ oft (|object2Identifier| (UPCASE FT)))
+ (SETQ XCAPE (OR (GET oft '/XCAPE) #\|))
+ (SETQ COMMENTCHR (GET oft '/COMMENTCHR))
+ (SETQ XTOKENREADER (OR (GET oft '/NXTTOK) 'METATOK))
+ (SETQ DEFINITION_NAME FN)
+ (SETQ KEY
+ (STRCONC
+ (OR (AND (EQ oFT 'SPAD) "")
+ (AND (EQ oFT 'BOOT) "")
+ (GET oFT '/PREFIX)
+ "")
+ (PNAME FN)))
+ (SETQ SFN (GET oFT '/READFUN))
+ (SETQ RECNO (/LOCATE FN KEY FILE 0))
+ (SHUT INPUTSTREAM)
+ (cond ((NUMBERP RECNO)
+ (SETQ /SOURCEFILES (CONS FILE (REMOVE FILE /SOURCEFILES)))
+ (SETQ INFILE FILE)
+ (RETURN RECNO)))) )
+ (if (NOT RECNO)
+ (if (SETQ INFILE (/MKINFILENAM '(NIL))) (GO LOOP) (UNWIND)))
+ (TERPRI)
+ (TERPRI)
+ (SETQ INFILE (|pathname| INFILE))
+ (COND
+ ( EDITFLAG
+ ;;%% next form is used because $FINDFILE seems to screw up
+ ;;%% sometimes. The stream is opened and closed several times
+ ;;%% in case the filemode has changed during editing.
+ (SETQ EDINFILE (make-input-filename INFILE))
+ (SETQ INPUTSTREAM (DEFSTREAM EDINFILE 'INPUT))
+ (|sayBrightly|
+ (LIST " editing file" '|%b| (|namestring| EDINFILE) '|%d|))
+ (OBEY
+ (STRCONC
+ (make-absolute-filename "/lib/SPADEDFN ")
+ (|namestring| EDINFILE)
+ " "
+ (STRINGIMAGE $LINENUMBER)))
+ (SHUT INPUTSTREAM)
+ ;(COND
+ ; ( (EQ (READ ERRORINSTREAM) 'ABORTPROCESS)
+ ; (RETURN 'ABORT) ) )
+ ;;%% next is done in case the diskmode changed
+ ;;(SETQ INFILE (|pathname| (IFCAR
+ ;; (QSORT ($LISTFILE INFILE)))))
+ (SETQ INPUTSTREAM (DEFSTREAM INFILE 'INPUT))
+ (SETQ RECNO (/LOCATE FN KEY INFILE RECNO))
+
+ (COND ((NOT RECNO)
+ (|sayBrightly| (LIST " Warning: function" "%b" /FN "%d"
+ "was not found in the file" "%l" " " "%b"
+ (|namestring| INFILE) "%d" "after editing."))
+ (RETURN NIL)))
+ ;; next is done in case the diskmode changed
+ (SHUT INPUTSTREAM) ))
+ ;;(SETQ INFILE (|pathname| (IFCAR ($LISTFILE INFILE))))
+ (SETQ INFILE (vmlisp::make-input-filename INFILE))
+ (MAKEPROP /FN 'DEFLOC
+ (CONS RECNO INFILE))
+ (SETQ oft (|object2Identifier| (UPCASE (|pathnameType| INFILE))))
+ (COND
+ ( (NULL OP)
+ (RETURN /FN) ) )
+ (COND
+ ( (EQ TRACEFLAG 'TRACELET)
+ (RETURN (/TRACELET-1 (LIST FN) NIL)) ) )
+ (SETQ INPUTSTREAM (DEFSTREAM INFILE 'INPUT))
+ (|sayBrightly|
+ (LIST " Reading file" '|%b| (|namestring| INFILE) '|%d|))
+ (TERPRI)
+ (SETQ $BOOT (EQ oft 'BOOT))
+ (SETQ $NEWSPAD (OR $BOOT (EQ oft 'SPAD)))
+ (SETQ DEF
+ (COND
+ ( SFN
+ ;(+VOL 'METABASE)
+ (POINT RECNO INPUTSTREAM)
+ ;(SETQ CHR (CAR INPUTSTREAM))
+ ;(SETQ ERRCOL 0)
+ ;(SETQ COUNT 0)
+ ;(SETQ COLUMN 0)
+ ;(SETQ TRAPFLAG NIL)
+ (SETQ OK 'T)
+ ;(NXTTOK)
+ ;(SETQ LINE (CURINPUTLINE))
+ ;(SETQ SPADERRORSTREAM CUROUTSTREAM)
+ ;(AND /ECHO (SETQ ECHOMETA 'T) (PRINTEXP LINE) (TERPRI))
+ ;(SFN)
+ (SETQ DEF (BOOT-PARSE-1 INPUTSTREAM))
+ (SETQ DEBUGMODE 'YES)
+ (COND
+ ( (NULL OK)
+ (FUNCALL (GET oft 'SYNTAX_ERROR))
+ NIL )
+ ( 'T
+ DEF ) ) )
+ ( 'T
+ (let* ((mode-line (read-line inputstream))
+ (pacpos (search "package:" mode-line :test #'equalp))
+ (endpos (search "-*-" mode-line :from-end t))
+ (*package* *package*)
+ (newpac nil))
+ (when pacpos
+ (setq newpac (read-from-string mode-line nil nil
+ :start (+ pacpos 8)
+ :end endpos))
+ (setq *package*
+ (cond ((find-package newpac))
+ (t *package*))))
+ (POINT RECNO INPUTSTREAM)
+ (READ INPUTSTREAM)))))
+ #+Lucid(system::compiler-options :messages t :warnings t)
+ (COND
+ ( (SETQ U (GET oft '/TRAN))
+ (SETQ DEF (FUNCALL U DEF)) ) )
+ (/WRITEUPDATE
+ /FN
+ (|pathnameName| INFILE)
+ (|pathnameType| INFILE)
+ (OR (|pathnameDirectory| INFILE) '*)
+ (OR (KAR (KAR (KDR DEF))) NIL)
+ OP)
+ (COND
+ ( (OR /ECHO $PRETTYPRINT)
+ (PRETTYPRINT DEF OUTPUTSTREAM) ) )
+ (COND
+ ( (EQ oft 'LISP)
+ (if (EQ OP 'DEFINE) (EVAL DEF)
+ (compile (EVAL DEF))))
+ ( DEF
+ (FUNCALL OP (LIST DEF)) ) )
+ #+Lucid(system::compiler-options :messages nil :warnings nil)
+ #+Lucid(TERPRI)
+ (COND
+ ( TRACEFLAG
+ (/TRACE-2 /FN NIL) ) )
+ (SHUT INPUTSTREAM)
+ (RETURN (LIST /FN)) ) )
+
+(DEFUN FUNLOC (func &aux file)
+ (if (PAIRP func) (SETQ func (CAR func)))
+ (setq file (ifcar (findtag func)))
+ (if file (list (pathname-name file) (pathname-type file) func)
+ nil))
+
+(DEFUN /LOCATE (FN KEY INFILE INITRECNO)
+ (PROG (FT RECNO KEYLENGTH LN)
+ (if (AND (NOT (eq 'FROMWRITEUPDATE (|pathnameName| INFILE)))
+ (NOT (make-input-filename INFILE)))
+ (RETURN NIL))
+ (SETQ FT (UPCASE (|object2Identifier| (|pathnameType| INFILE))))
+ (SETQ KEYLENGTH (STRINGLENGTH KEY))
+ (WHEN (> INITRECNO 1) ;; we think we know where it is
+ (POINT INITRECNO INPUTSTREAM)
+ (SETQ LN (READ-LINE INPUTSTREAM NIL NIL))
+ (IF (AND LN (MATCH-FUNCTION-DEF FN KEY KEYLENGTH LN FT))
+ (RETURN INITRECNO)))
+ (SETQ $LINENUMBER 0)
+ (POINT 0 INPUTSTREAM)
+EXAMINE (SETQ RECNO (NOTE INPUTSTREAM))
+ (SETQ LN (READ-LINE INPUTSTREAM NIL NIL))
+ (INCF $LINENUMBER)
+ (if (NULL LN) (RETURN NIL))
+ (IF (MATCH-FUNCTION-DEF FN KEY KEYLENGTH LN FT)
+ (RETURN RECNO))
+ (GO EXAMINE)))
+
+(DEFUN MATCH-FUNCTION-DEF (fn key keylength line type)
+ (if (eq type 'LISP) (match-lisp-tag fn line "(def")
+ (let ((n (mismatch key line)))
+ (and (= n keylength)
+ (or (= n (length line))
+ (member (elt line n)
+ (or (get type '/termchr) '(#\space ))))))))
+
+(define-function '|/D,1| #'/D-1)
+
+(DEFUN /INITUPDATES (/VERSION)
+ (SETQ FILENAME (STRINGIMAGE /VERSION))
+ (SETQ /UPDATESTREAM (open (strconc "/tmp/update." FILENAME) :direction :output
+ :if-exists :append :if-does-not-exist :create))
+ (PRINTEXP
+ " Function Name Filename Date Time"
+ /UPDATESTREAM)
+ (TERPRI /UPDATESTREAM)
+ (PRINTEXP
+ " --------------------------- ----------------------- -------- -----"
+ /UPDATESTREAM)
+ (TERPRI /UPDATESTREAM) )
+
+(defun /UPDATE (&rest ARGS)
+ (LET (( FILENAME (OR (KAR ARGS)
+ (strconc "/tmp/update." (STRINGIMAGE /VERSION))))
+ (|$createUpdateFiles| NIL))
+ (DECLARE (SPECIAL |$createUpdateFiles|))
+ (CATCH 'FILENAM (/UPDATE-1 FILENAME '(/COMP)))
+ (SAY "Update is finished")))
+
+(defun /DUPDATE (&rest ARGS)
+ (LET (( FILENAME (OR (KAR ARGS)
+ (strconc "/tmp/update." (STRINGIMAGE /VERSION))))
+ (|$createUpdateFiles| NIL))
+ (DECLARE (SPECIAL |$createUpdateFiles|))
+ (CATCH 'FILENAM (/UPDATE-1 FILENAME 'DEFINE))
+ (SAY "Update is finished")))
+
+(DEFUN /UPDATE-1 (UPFILE OP)
+ ;;if /VERSION=0 then no new update files will be written.
+ (prog (STREAM RECORD FUN FILE FUNFILES)
+ (SETQ STREAM (DEFSTREAM (/MKINFILENAM UPFILE) 'INPUT))
+ LOOP
+ (if (STREAM-EOF STREAM) (RETURN NIL))
+ (SETQ RECORD (read-line STREAM))
+ (if (NOT (STRINGP RECORD)) (RETURN NIL))
+ (if (< (LENGTH RECORD) 36) (GO LOOP))
+ (SETQ FUN (STRING2ID-N (SUBSTRING RECORD 0 36) 1))
+ (if (AND (NOT (EQUAL FUN 'QUAD)) (EQUAL (SUBSTRING RECORD 0 1) " "))
+ (GO LOOP))
+ (SETQ FILE (STRING2ID-N RECORD 2))
+ (if (member (cons fun file) funfiles :test #'equal) (go loop))
+ (push (cons fun file) funfiles)
+ (COND ((EQUAL FUN 'QUAD) (/RF-1 FILE))
+ ((/D-2 FUN FILE CUROUTSTREAM OP NIL NIL)))
+ (GO LOOP)))
+
+(DEFUN /WRITEUPDATE (FUN FN FT FM FTYPE OP)
+
+;;;If /VERSION=0 then no save has yet been done.
+;;;If A disk is not read-write, then issue msg and return.
+;;;If /UPDATESTREAM not set or current /UPDATES file doesnt exist, initialize.
+
+ (PROG (IFT KEY RECNO ORECNO COUNT DATE TIME)
+; (if (EQ 0 /VERSION) (RETURN NIL))
+ (if (EQ 'INPUT FT) (RETURN NIL))
+ (if (NOT |$createUpdateFiles|) (RETURN NIL))
+; (COND ((/= 0 (directory "A")))
+; ((SAY "A disk is not read-write. Update file not modified")
+; (RETURN NIL)))
+ (if (OR (NOT (BOUNDP '/UPDATESTREAM))
+ (NOT (STREAMP /UPDATESTREAM)))
+ (/INITUPDATES /VERSION))
+; (SETQ IFT (INTERN (STRINGIMAGE /VERSION)))
+; (SETQ INPUTSTREAM (open (strconc IFT /WSNAME) :direction :input))
+; (NEXT INPUTSTREAM)
+; (SETQ KEY (if (NOT FUN)
+; (STRCONC " QUAD "
+; (PNAME FN))
+; (PNAME FUN)))
+; (SETQ RECNO (/LOCATE KEY (LIST 'FROMWRITEUPDATE /WSNAME) 1))
+; (SETQ COUNT (COND
+; ((NOT (NUMBERP RECNO)) 1)
+; ((POINT RECNO INPUTSTREAM)
+; (do ((i 1 (1+ i))) ((> i 4)) (read inputstream))
+; (1+ (READ INPUTSTREAM)) )))
+; (COND ((NUMBERP RECNO)
+; (SETQ ORECNO (NOTE /UPDATESTREAM))
+; (POINTW RECNO /UPDATESTREAM) ))
+ (SETQ DATETIME (|getDateAndTime|))
+ (SETQ DATE (CAR DATETIME))
+ (SETQ TIME (CDR DATETIME))
+ (PRINTEXP (STRCONC
+ (COND ((NOT FUN) " QUAD ")
+ ((STRINGPAD (PNAME FUN) 28))) " "
+ (STRINGIMAGE FM)
+ (STRINGIMAGE FN) "." (STRINGIMAGE FT)
+ " "
+ DATE " " TIME) /UPDATESTREAM)
+ (TERPRI /UPDATESTREAM)
+; (if (NUMBERP RECNO) (POINTW ORECNO /UPDATESTREAM))
+ ))
+
+(defun |getDateAndTime| ()
+ (MULTIPLE-VALUE-BIND (sec min hour day mon year) (get-decoded-time)
+ (CONS (STRCONC (LENGTH2STR mon) "/"
+ (LENGTH2STR day) "/"
+ (LENGTH2STR year) )
+ (STRCONC (LENGTH2STR hour) ":"
+ (LENGTH2STR min)))))
+
+(DEFUN LENGTH2STR (X &aux XLEN)
+ (cond ( (= 1 (SETQ XLEN (LENGTH (SETQ X (STRINGIMAGE X))))) (STRCONC "0" X))
+ ( (= 2 XLEN) X)
+ ( (subseq x (- XLEN 2)))))
+
+(defmacro /T (&rest L) (CONS '/TRACE (OR L (LIST /FN))))
+
+(defmacro /TRACE (&rest L) `',(/TRACE-0 L))
+
+(DEFUN /TRACE-0 (L)
+ (if (member '? L :test #'eq)
+ (OBEY "EXEC NORMEDIT TRACE TELL")
+ (let* ((options (/OPTIONS L)) (FNL (TRUNCLIST L OPTIONS)))
+ (/TRACE-1 FNL OPTIONS))))
+
+(define-function '|/TRACE,0| #'/TRACE-0)
+
+(defmacro /TRACEANDCOUNT (&rest L) `',
+ (let* ((OPTIONS (/OPTIONS L))
+ (FNL (TRUNCLIST L OPTIONS)))
+ (/TRACE-1 FNL (CONS '(DEPTH) OPTIONS))))
+
+(DEFUN /TRACE-1 (FNLIST OPTIONS)
+ (mapcar #'(lambda (X) (/TRACE-2 X OPTIONS)) FNLIST)
+ (/TRACEREPLY))
+
+(DEFUN /TRACE-2 (FN OPTIONS)
+ (PROG (U FNVAL COUNTNAM TRACECODE BEFORE AFTER CONDITION
+ TRACENAME CALLER VARS BREAK FROM_CONDITION VARBREAK TIMERNAM
+ ONLYS G WITHIN_CONDITION DEPTH_CONDITION COUNT_CONDITION
+ LETFUNCODE MATHTRACE )
+ (if (member FN /TRACENAMES :test #'eq) (/UNTRACE-2 FN NIL))
+ (SETQ OPTIONS (OPTIONS2UC OPTIONS))
+ (if (AND |$traceDomains| (|isFunctor| FN) (ATOM FN))
+ (RETURN (|traceDomainConstructor| FN OPTIONS)))
+ (SETQ MATHTRACE (/GETTRACEOPTIONS OPTIONS 'MATHPRINT))
+ (if (AND MATHTRACE (NOT (EQL (ELT (PNAME FN) 0) #\$)) (NOT (GENSYMP FN)))
+ (if (RASSOC FN |$mapSubNameAlist|)
+ (SETQ |$mathTraceList| (CONS FN |$mathTraceList|))
+ (|spadThrowBrightly|
+ (format nil "mathprint not available for ~A" FN))))
+ (SETQ VARS (/GETTRACEOPTIONS OPTIONS 'VARS))
+ (if VARS
+ (progn (if (NOT (CDR VARS)) (SETQ VARS 'all) (SETQ VARS (CDR VARS)))
+ (|tracelet| FN VARS)))
+ (SETQ BREAK (/GETTRACEOPTIONS OPTIONS 'BREAK))
+ (SETQ VARBREAK (/GETTRACEOPTIONS OPTIONS 'VARBREAK))
+ (if VARBREAK
+ (progn (if (NOT (CDR VARBREAK)) (SETQ VARS 'all)
+ (SETQ VARS (CDR VARBREAK)))
+ (|breaklet| FN VARS)))
+ (if (and (symbolp fn) (not (boundp FN)) (not (fboundp FN)))
+ (progn
+ (COND ((|isUncompiledMap| FN)
+ (|sayBrightly|
+ (format nil
+ "~A must be compiled before it may be traced -- invoke ~A to compile"
+ FN FN)))
+ ((|isInterpOnlyMap| FN)
+ (|sayBrightly| (format nil
+ "~A cannot be traced because it is an interpret-only function" FN)))
+ (T (|sayBrightly| (format nil "~A is not a function" FN))))
+ (RETURN NIL)))
+ (if (and (symbolp fn) (boundp FN)
+ (|isDomainOrPackage| (SETQ FNVAL (EVAL FN))))
+ (RETURN (|spadTrace| FNVAL OPTIONS)))
+ (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'MASK=))
+ (MAKEPROP FN '/TRANSFORM (CADR U)))
+ (SETQ /TRACENAMES
+ (COND ((/GETTRACEOPTIONS OPTIONS 'ALIAS) /TRACENAMES)
+ ((ATOM /TRACENAMES) (LIST FN))
+ ((CONS FN /TRACENAMES))))
+ (SETQ TRACENAME
+ (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'ALIAS))
+ (STRINGIMAGE (CADR U)))
+ (T
+ (COND ((AND |$traceNoisely| (NOT VARS)
+ (NOT (|isSubForRedundantMapName| FN)))
+ (|sayBrightly|
+ (LIST '|%b| (|rassocSub| FN |$mapSubNameAlist|)
+ '|%d| "traced"))))
+ (STRINGIMAGE FN))))
+ (COND (|$fromSpadTrace|
+ (if MATHTRACE (push (INTERN TRACENAME) |$mathTraceList|))
+ (SETQ LETFUNCODE `(SETQ |$currentFunction| ,(MKQ FN)))
+ (SETQ BEFORE
+ (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'BEFORE))
+ `(progn ,(CADR U) ,LETFUNCODE)
+ LETFUNCODE)))
+ (T (SETQ BEFORE
+ (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'BEFORE))
+ (CADR U)))))
+ (SETQ AFTER (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'AFTER)) (CADR U)))
+ (SETQ CALLER (/GETTRACEOPTIONS OPTIONS 'CALLER))
+ (SETQ FROM_CONDITION
+ (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'FROM))
+ (LIST 'EQ '|#9| (LIST 'QUOTE (CADR U)))
+ T))
+ (SETQ CONDITION
+ (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'WHEN)) (CADR U) T))
+ (SETQ WITHIN_CONDITION T)
+ (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'WITHIN))
+ (SETQ G (INTERN (STRCONC (PNAME FN) "/" (PNAME (CADR U)))))
+ (SET G 0)
+ (/TRACE-1
+ (LIST (CADR U))
+ `((WHEN NIL)
+ (BEFORE (SETQ ,G (1+ ,G)))
+ (AFTER (SETQ ,G (1- ,G)))))
+ (SETQ WITHIN_CONDITION `(> ,G 0))))
+ (SETQ COUNTNAM
+ (AND (/GETTRACEOPTIONS OPTIONS 'COUNT)
+ (INTERN (STRCONC TRACENAME ",COUNT"))) )
+ (SETQ COUNT_CONDITION
+ (COND ((SETQ U (/GETTRACEOPTIONS OPTIONS 'COUNT))
+ (SETQ /COUNTLIST (adjoin TRACENAME /COUNTLIST
+ :test 'equal))
+ (if (AND (CDR U) (integerp (CADR U)))
+ `(cond ((<= ,COUNTNAM ,(CADR U)) t)
+ (t (/UNTRACE-2 ,(MKQ FN) NIL) NIL))
+ t))
+ (T T)))
+ (AND (/GETTRACEOPTIONS OPTIONS 'TIMER)
+ (SETQ TIMERNAM (INTERN (STRCONC TRACENAME ",TIMER")))
+ (SETQ /TIMERLIST (adjoin TRACENAME /TIMERLIST :test 'equal)))
+ (SETQ DEPTH_CONDITION
+ (if (SETQ U (/GETTRACEOPTIONS OPTIONS 'DEPTH))
+ (if (AND (CDR U) (integerp (CADR U)))
+ (LIST 'LE 'FUNDEPTH (CADR U))
+ (TRACE_OPTION_ERROR 'DEPTH))
+ T))
+ (SETQ CONDITION
+ (MKPF
+ (LIST CONDITION WITHIN_CONDITION FROM_CONDITION COUNT_CONDITION
+ DEPTH_CONDITION )
+ 'AND))
+ (SETQ ONLYS (/GETTRACEOPTIONS OPTIONS 'ONLY))
+
+ ;TRACECODE meaning:
+ ; 0: Caller (0,1) print caller if 1
+ ; 1: Value (0,1) print value if 1
+ ; 2...: Arguments (0,...,9) stop if 0; print ith if i; all if 9
+ (SETQ TRACECODE
+ (if (/GETTRACEOPTIONS OPTIONS 'NT) "000"
+ (PROG (F A V C NL BUF)
+ (SETQ ONLYS (MAPCAR #'COND-UCASE ONLYS))
+ (SETQ F (OR (member 'F ONLYS :test #'eq)
+ (member 'FULL ONLYS :test #'eq)))
+ (SETQ A (OR F (member 'A ONLYS :test #'eq)
+ (member 'ARGS ONLYS :test #'eq)))
+ (SETQ V (OR F (member 'V ONLYS :test #'eq)
+ (member 'VALUE ONLYS :test #'eq)))
+ (SETQ C (OR F (member 'C ONLYS :test #'eq)
+ (member 'CALLER ONLYS :test #'eq)))
+ (SETQ NL
+ (if A '(#\9)
+ (mapcan #'(lambda (X)
+ (if (AND (INTEGERP X)
+ (> X 0)
+ (< X 9))
+ (LIST (FETCHCHAR (STRINGIMAGE X) 0))))
+ onlys)))
+ (if (NOT (OR A V C NL))
+ (if Caller (return "119") (return "019")))
+ (SETQ NL (APPEND NL '(\0)))
+ (SETQ BUF (GETSTR 12))
+ (SUFFIX (if (or C Caller) #\1 #\0) BUF)
+ (SUFFIX (if V #\1 #\0) BUF)
+ (if A (suffix #\9 BUF)
+ (mapcar #'(lambda (x) (suffix x BUF)) NL))
+ (RETURN BUF))))
+ (/MONITOR FN TRACECODE BEFORE AFTER CONDITION TIMERNAM
+ COUNTNAM TRACENAME BREAK )))
+
+(DEFUN OPTIONS2UC (L)
+ (COND ((NOT L) NIL)
+ ((ATOM (CAR L))
+ (|spadThrowBrightly|
+ (format nil "~A has wrong format for an option" (car L))))
+ ((CONS (CONS (LC2UC (CAAR L)) (CDAR L)) (OPTIONS2UC (CDR L))))))
+
+(DEFUN COND-UCASE (X) (COND ((INTEGERP X) X) ((UPCASE X))))
+
+(DEFUN TRACEOPTIONS (X)
+ (COND ((NOT X) NIL)
+ ((EQ (CAR X) '/) X)
+ ((TRACEOPTIONS (CDR X)))))
+
+(defmacro |/untrace| (&rest L) `', (/UNTRACE-0 L))
+
+(defmacro /UNTRACE (&rest L) `', (/UNTRACE-0 L))
+
+(defmacro /U (&rest L) `', (/UNTRACE-0 L))
+
+(DEFUN /UNTRACE-0 (L)
+ (PROG (OPTIONL OPTIONS FNL)
+ (if (member '? L :test #'eq) (RETURN (OBEY "EXEC NORMEDIT TRACE TELL")))
+ (SETQ OPTIONL (/OPTIONS L))
+ (SETQ FNL (TRUNCLIST L OPTIONL))
+ (SETQ OPTIONS (if OPTIONL (CAR OPTIONL)))
+ (RETURN (/UNTRACE-1 FNL OPTIONS))))
+
+(define-function '|/UNTRACE,0| #'/UNTRACE-0)
+
+(defun /UNTRACE-1 (L OPTIONS)
+ (cond
+ ((NOT L)
+ (if (ATOM /TRACENAMES)
+ NIL
+ (mapcar #'(lambda (u) (/UNTRACE-2 (/UNTRACE-REDUCE U) OPTIONS))
+ (APPEND /TRACENAMES NIL))))
+ ((mapcar #'(lambda (x) (/UNTRACE-2 X OPTIONS)) L)))
+ (/TRACEREPLY))
+
+(DEFUN /UNTRACE-REDUCE (X) (if (ATOM X) X (first X))) ; (CAR X) is now a domain
+
+(DEFUN /UNTRACE-2 (X OPTIONS)
+ (let (u y)
+ (COND ((AND (|isFunctor| X) (ATOM X))
+ (|untraceDomainConstructor| X))
+ ((OR (|isDomainOrPackage| (SETQ U X))
+ (and (symbolp X) (boundp X)
+ (|isDomain| (SETQ U (EVAL X)))))
+ (|spadUntrace| U OPTIONS))
+ ((EQCAR OPTIONS 'ALIAS)
+ (if |$traceNoisely|
+ (|sayBrightly| (LIST '|%b| (CADR OPTIONS) '|%d| '**untraced)))
+ (SETQ /TIMERLIST
+ (REMOVE (STRINGIMAGE (CADR OPTIONS)) /TIMERLIST :test 'equal))
+ (SETQ /COUNTLIST
+ (REMOVE (STRINGIMAGE (CADR OPTIONS)) /COUNTLIST :test 'equal))
+ (SETQ |$mathTraceList|
+ (REMOVE (CADR OPTIONS) |$mathTraceList| :test 'equal))
+ (UNEMBED X))
+ ((AND (NOT (MEMBER X /TRACENAMES))
+ (NOT (|isSubForRedundantMapName| X)))
+ (|sayBrightly|
+ (LIST
+ '|%b|
+ (|rassocSub| X |$mapSubNameAlist|)
+ '|%d|
+ "not traced")))
+ (T (SETQ /TRACENAMES (REMOVE X /TRACENAMES :test 'equal))
+ (SETQ |$mathTraceList|
+ (REMOVE (if (STRINGP X) (INTERN X) X) |$mathTraceList|))
+ (SETQ |$letAssoc| (DELASC X |$letAssoc|))
+ (setq Y (if (IS_GENVAR X) (|devaluate| (EVAL X)) X))
+ (SETQ /TIMERLIST (REMOVE (STRINGIMAGE Y) /TIMERLIST :test 'equal))
+ (SET (INTERN (STRCONC Y ",TIMER")) 0)
+ (SETQ /COUNTLIST (REMOVE (STRINGIMAGE Y) /COUNTLIST :test 'equal))
+ (SET (INTERN (STRCONC Y ",COUNT")) 0)
+ (COND ((AND |$traceNoisely| (NOT (|isSubForRedundantMapName| Y)))
+ (|sayBrightly|
+ (LIST '|%b| (|rassocSub| Y |$mapSubNameAlist|)
+ '|%d| "untraced"))))
+ (UNEMBED X)))))
+
+ ;; the following is called by |clearCache|
+(define-function '/UNTRACE\,2 #'/UNTRACE-2)
+
+(DEFUN MONITOR-PRINVALUE (VAL NAME)
+ (let (u)
+ (COND ((setq U (GET NAME '/TRANSFORM))
+ (COND
+ ((EQCAR U '&)
+ (PRINC "//" CURSTRM) (PRIN1 VAL CURSTRM) (TERPRI CURSTRM))
+ (T (PRINC "! " CURSTRM)
+ (PRIN1 (EVAL (SUBST (MKQ VAL) '* (CAR U))) CURSTRM)
+ (TERPRI CURSTRM)) ))
+ (T
+ (PRINC ": " CURSTRM)
+ (COND ((NOT (SMALL-ENOUGH VAL)) (|F,PRINT-ONE| VAL CURSTRM))
+ (/PRETTY (PRETTYPRINT VAL CURSTRM))
+ (T (COND (|$mathTrace| (TERPRI)))
+ (PRINMATHOR0 VAL CURSTRM)))))))
+
+(DEFUN MONITOR-BLANKS (N) (PRINC (MAKE-FULL-CVEC N " ") CURSTRM))
+
+(DEFUN MONITOR-EVALBEFORE (X) (EVALFUN (MONITOR-EVALTRAN X NIL)) X)
+
+(DEFUN MONITOR-EVALAFTER (X) (EVALFUN (MONITOR-EVALTRAN X 'T)))
+
+(DEFUN MONITOR-EVALTRAN (X FG)
+ (if (HAS_SHARP_VAR X) (MONITOR-EVALTRAN1 X FG) X))
+
+(define-function 'MONITOR\,EVALTRAN #'MONITOR-EVALTRAN)
+
+(DEFUN MONITOR-EVALTRAN1 (X FG)
+ (let (n)
+ (COND
+ ((SETQ N (|isSharpVarWithNum| X)) (MONITOR-GETVALUE N FG))
+ ((ATOM X) X)
+ ((CONS (MONITOR-EVALTRAN1 (CAR X) FG)
+ (MONITOR-EVALTRAN1 (CDR X) FG))))))
+
+(DEFUN HAS_SHARP_VAR (X)
+ (COND ((AND (ATOM X) (IS_SHARP_VAR X)) 'T)
+ ((ATOM X) NIL)
+ ((OR (HAS_SHARP_VAR (CAR X)) (HAS_SHARP_VAR (CDR X))))))
+
+(DEFUN IS_SHARP_VAR (X)
+ (AND (IDENTP X)
+ (EQL (ELT (PNAME X) 0) #\#)
+ (INTEGERP (lisp:parse-integer (symbol-name X) :start 1))))
+
+(DEFUN MONITOR-GETVALUE (N FG)
+ (COND ((= N 0)
+ (if FG
+ (MKQ /VALUE)
+ (|spadThrowBrightly| "cannot ask for value before execution")))
+ ((= N 9) (MKQ /CALLER))
+ ((<= N (SIZE /ARGS)) (MKQ (ELT /ARGS (1- N))))
+ ((|spadThrowBrightly| (LIST 'function '|%b| /NAME '|%d|
+ "does not have" '|%b| N '|%d| "arguments")))))
+
+(DEFUN MONITOR-PRINARGS (L CODE /TRANSFORM)
+ (let (N)
+ (cond
+ ((= (digit-char-p (elt CODE 2)) 0) NIL)
+ ((= (digit-char-p (elt CODE 2)) 9)
+ (cond
+ (/TRANSFORM
+ (mapcar
+ #'(lambda (x y)
+ (COND ((EQ Y '*)
+ (PRINC "\\ " CURSTRM)
+ (MONITOR-PRINT X CURSTRM))
+ ((EQ Y '&)
+ (PRINC "\\\\" CURSTRM)
+ (TERPRI CURSTRM)
+ (PRINT X CURSTRM))
+ ((NOT Y) (PRINC "! " CURSTRM))
+ (T
+ (PRINC "! " CURSTRM)
+ (MONITOR-PRINT
+ (EVAL (SUBST (MKQ X) '* Y)) CURSTRM))))
+ L (cdr /transform)))
+ (T (PRINC ": " CURSTRM)
+ (COND ((NOT (ATOM L))
+ (if |$mathTrace| (TERPRI CURSTRM))
+ (MONITOR-PRINT (CAR L) CURSTRM) (SETQ L (CDR L))))
+ (mapcar #'monitor-printrest L))))
+ ((do ((istep 2 (+ istep 1))
+ (k (maxindex code)))
+ ((> istep k) nil)
+ (when (not (= 0 (SETQ N (digit-char-p (elt CODE ISTEP)))))
+ (PRINC "\\" CURSTRM)
+ (PRINMATHOR0 N CURSTRM)
+ (PRINC ": " CURSTRM)
+ (MONITOR-PRINARGS-1 L N)))))))
+
+(DEFUN MONITOR-PRINTREST (X)
+ (COND ((NOT (SMALL-ENOUGH X))
+ (PROGN (TERPRI)
+ (MONITOR-BLANKS (1+ /DEPTH))
+ (PRINC "\\" CURSTRM)
+ (PRINT X CURSTRM)))
+ ((PROGN (if (NOT |$mathTrace|) (PRINC "\\" CURSTRM))
+ (COND (/PRETTY (PRETTYPRINT X CURSTRM))
+ ((PRINMATHOR0 X CURSTRM)))))))
+
+(DEFUN MONITOR-PRINARGS-1 (L N)
+ (COND ((OR (ATOM L) (LESSP N 1)) NIL)
+ ((EQ N 1) (MONITOR-PRINT (CAR L) CURSTRM))
+ ((MONITOR-PRINARGS-1 (CDR L) (1- N)))))
+
+(DEFUN MONITOR-PRINT (X CURSTRM)
+ (COND ((NOT (SMALL-ENOUGH X)) (|F,PRINT-ONE| X CURSTRM))
+ (/PRETTY (PRETTYPRINT X CURSTRM))
+ ((PRINMATHOR0 X CURSTRM))))
+
+(DEFUN PRINMATHOR0 (X CURSTRM)
+ (if |$mathTrace| (|maprinSpecial| (|outputTran| X) /DEPTH 80)
+ (PRIN0 X CURSTRM)))
+
+(DEFUN SMALL-ENOUGH (X) (if /TRACESIZE (SMALL-ENOUGH-COUNT X 0 /TRACESIZE) t))
+
+(DEFUN SMALL-ENOUGH-COUNT (X N M)
+ "Returns number if number of nodes < M otherwise nil."
+ (COND ((< M N) NIL)
+ ((VECP X)
+ (do ((i 0 (1+ i)) (k (maxindex x)))
+ ((> i k) n)
+ (if (NOT (SETQ N (SMALL-ENOUGH-COUNT (ELT X I) (1+ N) M)))
+ (RETURN NIL))))
+ ((ATOM X) N)
+ ((AND (SETQ N (SMALL-ENOUGH-COUNT (CAR X) (1+ N) M))
+ (SMALL-ENOUGH-COUNT (CDR X) N M)))))
+
+(DEFUN /OPTIONS (X)
+ (COND ((ATOM X) NIL)
+ ((OR (ATOM (CAR X)) (|isFunctor| (CAAR X))) (/OPTIONS (CDR X)))
+ (X)))
+
+(DEFUN /GETOPTION (L OPT) (KDR (/GETTRACEOPTIONS L OPT)))
+
+(DEFUN /GETTRACEOPTIONS (L OPT)
+ (COND ((ATOM L) NIL)
+ ((EQ (KAR (CAR L)) OPT) (CAR L))
+ ((/GETTRACEOPTIONS (CDR L) OPT))))
+
+(DEFMACRO /TRACELET (&rest L) `',
+ (PROG (OPTIONL FNL)
+ (if (member '? L :test #'eq)
+ (RETURN (OBEY (if (EQ (SYSID) 1)
+ "EXEC NORMEDIT TRACELET TELL"
+ "$COPY AZ8F:TRLET.TELL")) ))
+ (SETQ OPTIONL (/OPTIONS L))
+ (SETQ FNL (TRUNCLIST L OPTIONL))
+ (RETURN (/TRACELET-1 FNL OPTIONL))))
+
+(DEFUN /TRACELET-1 (FNLIST OPTIONL)
+ (mapcar #'(lambda (x) (/tracelet-2 x optionl)) fnlist)
+ (/TRACE-1 FNLIST OPTIONL)
+ (TRACELETREPLY))
+
+(DEFUN TRACELETREPLY ()
+ (if (ATOM /TRACELETNAMES) '(none tracelet)
+ (APPEND /TRACELETNAMES (LIST 'tracelet))))
+
+(DEFUN /TRACELET-2 (FN OPTIONL &AUX ($TRACELETFLAG T))
+ (/D-1 (CONS FN OPTIONL) 'COMP NIL NIL)
+ (SETQ /TRACELETNAMES
+ (if (ATOM /TRACELETNAMES) (LIST FN) (CONS FN /TRACELETNAMES)))
+ FN)
+
+(defmacro /TRACE-LET (A B)
+ `(PROG1 (SPADLET ,A ,B)
+ . ,(mapcar #'(lambda (x) `(/tracelet-print ',x ,x))
+ (if (ATOM A) (LIST A) A))))
+
+(defun /TRACELET-PRINT (X Y &AUX (/PRETTY 'T))
+ (PRINC (STRCONC (PNAME X) ": ") *terminal-io*)
+ (MONITOR-PRINT Y *terminal-io*))
+
+(defmacro /UNTRACELET (&rest L) `',
+ (COND
+ ((NOT L)
+ (if (ATOM /TRACELETNAMES) NIL (EVAL (CONS '/UNTRACELET /TRACELETNAMES))))
+ ((mapcar #'/untracelet-1 L))
+ ((TRACELETREPLY))))
+
+(DEFUN /UNTRACELET-1 (X)
+ (COND
+ ((NOT (MEMBER X /TRACELETNAMES))
+ (PROGN (PRINT (STRCONC (PNAME X) " not tracelet")) (TERPRI)))
+ ((PROGN
+ (/UNTRACELET-2 X)
+ (/D-1 (LIST X) 'COMP NIL NIL)))))
+
+(DEFUN /UNTRACELET-2 (X)
+ (SETQ /TRACELETNAMES (REMOVE X /TRACELETNAMES))
+ (PRINT (STRCONC (PNAME X) " untracelet")) (TERPRI))
+
+(defmacro /EMBED (&rest L) `',
+ (COND ((NOT L) (/EMBEDREPLY))
+ ((member '? L :test #'eq) (OBEY "EXEC NORMEDIT EMBED TELL"))
+ ((EQ 2 (LENGTH L)) (/EMBED-1 (CAR L) (CADR L)))
+ ((MOAN "IMPROPER USE OF /EMBED"))))
+
+(defmacro /UNEMBED (&rest L) `',
+ (COND ((NOT L)
+ (if (ATOM (EMBEDDED)) NIL
+ (mapcar #'unembed (embedded)))
+ (SETQ /TRACENAMES NIL)
+ (SETQ /EMBEDNAMES NIL))
+ ((mapcar #'/unembed-1 L)
+ (SETQ /TRACENAMES (S- /TRACENAMES L)) ))
+ (/EMBEDREPLY))
+
+(defun /UNEMBED-Q (X)
+ (COND
+ ((NOT (MEMBER X /EMBEDNAMES))
+ (ERROR (STRCONC (PNAME X) " not embeded")))
+ ((PROGN
+ (SETQ /EMBEDNAMES (REMOVE X /EMBEDNAMES))
+ (UNEMBED X)))))
+
+(defun /UNEMBED-1 (X)
+ (COND
+ ((NOT (MEMBER X /EMBEDNAMES))
+ (|sayBrightly| (LIST '|%b| (PNAME X) '|%d| "not embeded" '|%l|)))
+ ((PROGN
+ (SETQ /EMBEDNAMES (REMOVE X /EMBEDNAMES))
+ (|sayBrightly| (LIST '|%b| (PNAME X) '|%d| "unembeded" '|%l|))
+ (UNEMBED X))) ))
+
+
+
+(defun /MONITOR (&rest G5)
+ (PROG (G1 G4 TRACECODE BEFORE AFTER CONDITION
+ TIMERNAM COUNTNAM TRACENAME BREAK)
+ (dcq (G1 TRACECODE BEFORE AFTER CONDITION TIMERNAM COUNTNAM TRACENAME BREAK) G5)
+ (SETQ G4 (macro-function G1))
+ (SETQ TRACECODE (OR TRACECODE "119"))
+ (if COUNTNAM (SET COUNTNAM 0))
+ (if TIMERNAM (SET TIMERNAM 0))
+ (EMBED
+ G1
+ (LIST
+ (if G4 'MLAMBDA 'LAMBDA)
+ '(&rest G6)
+ (LIST
+ '/MONITORX
+ (QUOTE G6)
+ G1
+ (LIST
+ 'QUOTE
+ (LIST
+ TRACENAME (if G4 'MACRO) TRACECODE
+ COUNTNAM TIMERNAM BEFORE AFTER
+ CONDITION BREAK |$tracedModemap| ''T)))))
+ (RETURN G1)))
+
+(defun /MONITORX (/ARGS FUNCT OPTS &AUX NAME TYPE TRACECODE COUNTNAM TIMERNAM
+ BEFORE AFTER CONDITION BREAK TRACEDMODEMAP
+ BREAKCONDITION)
+ (declare (special /ARGS))
+ (DCQ (NAME TYPE TRACECODE COUNTNAM TIMERNAM BEFORE AFTER CONDITION BREAK TRACEDMODEMAP BREAKCONDITION) OPTS)
+ (|stopTimer|)
+ (PROG (C V A NAME1 CURSTRM EVAL_TIME INIT_TIME NOT_TOP_LEVEL
+ (/DEPTH (if (and (BOUNDP '/DEPTH) (numberp /depth)) (1+ /DEPTH) 1))
+ (|depthAlist| (if (BOUNDP '|depthAlist|) (COPY-TREE |depthAlist|) NIL))
+ FUNDEPTH NAMEID YES (|$tracedSpadModemap| TRACEDMODEMAP) (|$mathTrace| NIL)
+ /caller /name /value /breakcondition curdepth)
+ (declare (special curstrm /depth fundepth |$tracedSpadModemap| |$mathTrace|
+ /caller /name /value /breakcondition |depthAlist|))
+ (SETQ /NAME NAME)
+ (SETQ NAME1 (PNAME (|rassocSub| (INTERN NAME) |$mapSubNameAlist|)))
+ (SETQ /BREAKCONDITION BREAKCONDITION)
+ (SETQ /CALLER (|rassocSub| (WHOCALLED 6) |$mapSubNameAlist|))
+ (if (NOT (STRINGP TRACECODE))
+ (MOAN "set TRACECODE to \'1911\' and restart"))
+ (SETQ C (digit-char-p (elt TRACECODE 0))
+ V (digit-char-p (elt TRACECODE 1))
+ A (digit-char-p (elt TRACECODE 2)))
+ (if COUNTNAM (SET COUNTNAM (1+ (EVAL COUNTNAM))))
+ (SETQ NAMEID (INTERN NAME))
+ (SETQ NOT_TOP_LEVEL (ASSOC NAMEID |depthAlist| :test #'eq))
+ (if (NOT NOT_TOP_LEVEL)
+ (SETQ |depthAlist| (CONS (CONS NAMEID 1) |depthAlist|))
+ (RPLACD NOT_TOP_LEVEL (1+ (CDR NOT_TOP_LEVEL))))
+ (SETQ FUNDEPTH (CDR (ASSOC NAMEID |depthAlist| :test #'eq)))
+ (SETQ CONDITION (MONITOR-EVALTRAN CONDITION NIL))
+ (SETQ YES (EVALFUN CONDITION))
+ (if (member NAMEID |$mathTraceList| :test #'eq)
+ (SETQ |$mathTrace| T))
+ (if (AND YES |$TraceFlag|)
+ (PROG (|$TraceFlag|)
+ (SETQ CURSTRM *TERMINAL-IO*)
+ (if (EQUAL TRACECODE "000") (RETURN NIL))
+ (TAB 0 CURSTRM)
+ (MONITOR-BLANKS (1- /DEPTH))
+ (PRIN0 FUNDEPTH CURSTRM)
+ (|sayBrightlyNT| (LIST "<enter" '|%b|
+ NAME1 '|%d|) CURSTRM)
+ (COND ((EQ 0 C) NIL)
+ ((EQ TYPE 'MACRO)
+ (PRINT " expanded" CURSTRM))
+ (T (PRINT " from " CURSTRM)
+ (PRIN0 /CALLER CURSTRM)))
+ (MONITOR-PRINARGS
+ (if (SPADSYSNAMEP NAME)
+ (NREVERSE (REVERSE (|coerceTraceArgs2E|
+ (INTERN NAME1)
+ (INTERN NAME)
+ /ARGS)))
+ (|coerceTraceArgs2E| (INTERN NAME1)
+ (INTERN NAME) /ARGS))
+ TRACECODE
+ (GET (INTERN NAME) '/TRANSFORM))
+ (if (NOT |$mathTrace|) (TERPRI CURSTRM))))
+ (if before (MONITOR-EVALBEFORE BEFORE))
+ (if (member '|before| BREAK :test #'eq)
+ (|break| (LIST "Break on entering" '|%b| NAME1 '|%d| ":")))
+ (if TIMERNAM (SETQ INIT_TIME (|startTimer|)))
+ (SETQ /VALUE (if (EQ TYPE 'MACRO) (MDEFX FUNCT /ARGS)
+ (APPLY FUNCT /ARGS)))
+ (|stopTimer|)
+ (if TIMERNAM (SETQ EVAL_TIME (- (|clock|) INIT_TIME)) )
+ (if (AND TIMERNAM (NOT NOT_TOP_LEVEL))
+ (SET TIMERNAM (+ (EVAL TIMERNAM) EVAL_TIME)))
+ (if AFTER (MONITOR-EVALAFTER AFTER))
+ (if (AND YES |$TraceFlag|)
+ (PROG (|$TraceFlag|)
+ (if (EQUAL TRACECODE "000") (GO SKIP))
+ (TAB 0 CURSTRM)
+ (MONITOR-BLANKS (1- /DEPTH))
+ (PRIN0 FUNDEPTH CURSTRM)
+ (|sayBrightlyNT| (LIST ">exit " '|%b| NAME1 '|%d|) CURSTRM)
+ (COND (TIMERNAM
+ (|sayBrightlyNT| '\( CURSTRM)
+ (|sayBrightlyNT| (/ EVAL_TIME 60.0) CURSTRM)
+ (|sayBrightlyNT| '\ sec\) CURSTRM) ))
+ (if (EQ 1 V)
+ (MONITOR-PRINVALUE
+ (|coerceTraceFunValue2E|
+ (INTERN NAME1) (INTERN NAME) /VALUE)
+ (INTERN NAME1)))
+ (if (NOT |$mathTrace|) (TERPRI CURSTRM))
+ SKIP))
+ (if (member '|after| BREAK :test #'eq)
+ (|break| (LIST "Break on exiting" '|%b| NAME1 '|%d| ":")))
+ (|startTimer|)
+ (RETURN /VALUE)))
+
+; Functions to run a timer for tracing
+; It avoids timing the tracing function itself by turning the timer
+; on and off
+
+(defun |startTimer| ()
+ (SETQ $delay (PLUS $delay (DIFFERENCE (TEMPUS-FUGIT) |$oldTime|)))
+ (SETQ |$timerOn| 'T)
+ (|clock|))
+
+(defun |stopTimer| () (SETQ |$oldTime| (TEMPUS-FUGIT) |$timerOn| NIL) (|clock|))
+
+(defun |clock| ()
+ (if |$timerOn| (- (TEMPUS-FUGIT) $delay) (- |$oldTime| $delay)))
+
+; Functions to trace/untrace a BPI; use as follows:
+; To trace a BPI-value <bpi>, evaluate (SETQ <name> (BPITRACE <bpi>))
+; To later untrace <bpi>, evaluate (BPITRACE <name>)
+
+(defun PAIRTRACE (PAIR ALIAS)
+ (RPLACA PAIR (BPITRACE (CAR PAIR) ALIAS )) NIL)
+
+(defun BPITRACE (BPI ALIAS &optional OPTIONS)
+ (SETQ NEWNAME (GENSYM))
+ (IF (identp bpi) (setq bpi (symbol-function bpi)))
+ (SET NEWNAME BPI)
+ (SETF (symbol-function NEWNAME) BPI)
+ (/TRACE-0 (APPEND (LIST NEWNAME (LIST 'ALIAS ALIAS)) OPTIONS))
+ NEWNAME)
+
+(defun BPIUNTRACE (X ALIAS) (/UNTRACE-0 (LIST X (LIST 'ALIAS ALIAS))))
+
+(defun SPADSYSNAMEP (STR)
+ (let (n i j)
+ (AND (SETQ N (MAXINDEX STR))
+ (SETQ I (position #\. STR :start 1))
+ (SETQ J (position #\, STR :start (1+ I)))
+ (do ((k (1+ j) (1+ k)))
+ ((> k n) t)
+ (if (not (digitp (elt str k))) (return nil))))))
+
+; **********************************************************************
+; Utility functions for Tracing Package
+; **********************************************************************
+
+(MAKEPROP '|coerce| '/TRANSFORM '(& & *))
+(MAKEPROP '|comp| '/TRANSFORM '(& * * &))
+(MAKEPROP '|compIf| '/TRANSFORM '(& * * &))
+
+; by having no transform for the 3rd argument, it is simply not printed
+
+(MAKEPROP '|compFormWithModemap| '/TRANSFORM '(& * * & *))
+
+(defun UNVEC (X)
+ (COND ((REFVECP X) (CONS '$ (VEC_TO_TREE X)))
+ ((ATOM X) X)
+ ((CONS (UNVEC (CAR X)) (UNVEC (CDR X))))))
+
+(defun DROPENV (X) (AND X (LIST (CAR X) (CADR X))))
+
+(defun SHOWBIND (E)
+ (do ((v e (cdr v))
+ (llev 1 (1+ llev)))
+ ((not v))
+ (PRINT (LIST "LAMBDA LEVEL" LLEV))
+ (do ((w (car v) (cdr w))
+ (clev 1 (1+ clev)))
+ ((not w))
+ (PRINT (LIST "CONTOUR LEVEL" CLEV))
+ (PRINT (mapcar #'car (car W))))))
+
+#+:CCL
+(defun break (&rest ignore) (lisp-break ignore) (lisp::unwind))
+
+
+#+:CCL
+(defun lisp-break (&rest ignore)
+ (prog (prompt ifile ofile u v)
+ (setq ifile (rds *debug-io*))
+ (setq ofile (wrs *debug-io*))
+ (setq prompt (setpchar "Break loop (:? for help)> "))
+top (setq u (read))
+ (cond
+ ((equal u ':x) (go exit))
+ ((equal u ':q)
+ (progn (lisp::enable-backtrace nil)
+ (princ "Backtrace now disabled")
+ (terpri)))
+ ((equal u ':v)
+ (progn (lisp::enable-backtrace t)
+ (princ "Backtrace now enabled")
+ (terpri)))
+ ((equal u ':?)
+ (progn
+ (princ ":Q disables backtrace")
+ (terpri)
+ (princ ":V enables backtrace")
+ (terpri)
+ (princ ":X exits from break loop")
+ (terpri)
+ (princ "else enter LISP expressions for evaluation")
+ (terpri)))
+ ((equal u #\eof)
+ (go exit))
+ (t (progn
+ (setq v (errorset u nil nil))
+ (if (listp v) (progn (princ "=> ") (prinl (car v)) (terpri))))) )
+ (go top)
+exit (rds ifile)
+ (wrs ofile)
+ (setpchar prompt)
+ (return nil)))
+
+(defun lisp-break-from-axiom (&rest ignore)
+ (boot::|handleLispBreakLoop| boot::|$BreakMode|))
+#+:CCL (setq lisp:*break-loop* 'boot::lisp-break-from-axiom)
+
+<<interrupt>>
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}