diff options
Diffstat (limited to 'src/interp/debug.lisp.pamphlet')
| -rw-r--r-- | src/interp/debug.lisp.pamphlet | 1244 |
1 files changed, 0 insertions, 1244 deletions
diff --git a/src/interp/debug.lisp.pamphlet b/src/interp/debug.lisp.pamphlet deleted file mode 100644 index b4ceeed3..00000000 --- a/src/interp/debug.lisp.pamphlet +++ /dev/null @@ -1,1244 +0,0 @@ -%% 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" )) - -(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 '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)) - -(defparameter $linenumber 0) - -(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 (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)) - -(defvar |$traceDomains| t) - -(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))) - -(defvar |$TraceFlag| t) - -(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 - -(defvar |$oldTime| 0) -(defvar |$timerOn| t) -(defvar $delay 0) - -(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} |