diff --git a/changelog b/changelog index 101de02..3540daf 100644 --- a/changelog +++ b/changelog @@ -1,11 +1,16 @@ +20090808 tpd src/axiom-website/patches.html 20090808.01.tpd.patch +20090808 tpd src/interp/Makefile remove debug.lisp +20090808 tpd src/interp/debugsys.lisp remove debug reference +20090808 tpd src/interp/vmlisp.lisp merge debug.lisp +20090808 tpd src/interp/debug.lisp removed, merged with vmlisp.lisp 20090807 tpd src/axiom-website/patches.html 20090807.02.tpd.patch 20090807 tpd src/interp/Makefile remove spaderror.lisp -20090807 tpd src/interp/comp.lisp remove spaderror reference +20090807 tpd src/interp/debugsys.lisp remove spaderror reference 20090807 tpd src/interp/vmlisp.lisp merge spaderror.lisp 20090807 tpd src/interp/spaderror.lisp removed, merged with vmlisp.lisp 20090807 tpd src/axiom-website/patches.html 20090807.01.tpd.patch 20090807 tpd src/interp/Makefile remove comp.lisp -20090807 tpd src/interp/comp.lisp remove comp reference +20090807 tpd src/interp/debugsys.lisp remove comp reference 20090807 tpd src/interp/vmlisp.lisp merge comp.lisp 20090807 tpd src/interp/comp.lisp removed, merged with vmlisp.lisp 20090806 tpd src/axiom-website/patches.html 20090806.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ba40569..2cc3d29 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1754,6 +1754,8 @@ vmlisp.lisp and macros.lisp merged
vmlisp.lisp and comp.lisp merged
20090807.02.tpd.patch vmlisp.lisp and spaderror.lisp merged
+20090808.01.tpd.patch +vmlisp.lisp and debug.lisp merged
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 0cb65b3..4c96fc5 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -128,7 +128,6 @@ expanded in later compiles. All macros are assumed to be in this list of files. <>= DEP= ${MID}/vmlisp.lisp \ - ${MID}/debug.lisp \ ${MID}/spad.lisp ${MID}/bits.lisp \ ${MID}/setq.lisp ${MID}/property.lisp \ ${MID}/unlisp.lisp ${MID}/foam_l.lisp \ @@ -184,7 +183,7 @@ OBJS= ${OUT}/vmlisp.${O} \ ${OUT}/compat.${O} ${OUT}/compress.${O} \ ${OUT}/cparse.${O} ${OUT}/cstream.${O} \ ${OUT}/database.${O} \ - ${OUT}/debug.${O} ${OUT}/dq.${O} \ + ${OUT}/dq.${O} \ ${OUT}/fname.${O} ${OUT}/format.${O} \ ${OUT}/g-boot.${O} ${OUT}/g-cndata.${O} \ ${OUT}/g-error.${O} ${OUT}/g-opt.${O} \ @@ -429,7 +428,7 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/compress.boot.dvi \ ${DOC}/cparse.boot.dvi ${DOC}/cstream.boot.dvi \ ${DOC}/c-util.boot.dvi ${DOC}/daase.lisp.dvi \ - ${DOC}/database.boot.dvi ${DOC}/debug.lisp.dvi \ + ${DOC}/database.boot.dvi \ ${DOC}/define.boot.dvi \ ${DOC}/dq.boot.dvi \ ${DOC}/fname.lisp.dvi \ @@ -1042,40 +1041,6 @@ ${DOC}/daase.lisp.dvi: ${IN}/daase.lisp.pamphlet @ -\subsection{debug.lisp \cite{14}} -<>= -${OUT}/debug.${O}: ${MID}/debug.lisp - @ echo 36 making ${OUT}/debug.${O} from ${MID}/debug.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/debug.lisp"' \ - ':output-file "${OUT}/debug.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/debug.lisp"' \ - ':output-file "${OUT}/debug.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/debug.lisp: ${IN}/debug.lisp.pamphlet - @ echo 37 making ${MID}/debug.lisp from ${IN}/debug.lisp.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/debug.lisp.pamphlet >debug.lisp ) - -@ -<>= -${DOC}/debug.lisp.dvi: ${IN}/debug.lisp.pamphlet - @echo 38 making ${DOC}/debug.lisp.dvi from ${IN}/debug.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/debug.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} debug.lisp ; \ - rm -f ${DOC}/debug.lisp.pamphlet ; \ - rm -f ${DOC}/debug.lisp.tex ; \ - rm -f ${DOC}/debug.lisp ) - -@ - \subsection{debugsys.lisp \cite{14}} The {\bf debugsys.lisp} file is used to create a {\bf debugsys} runnable image. This image contains almost all of the lisp code that make up the axiom @@ -7211,10 +7176,6 @@ clean: <> <> -<> -<> -<> - <> <> @@ -7737,7 +7698,6 @@ pp \bibitem{10} {\bf \$SPAD/src/interp/cfuns.lisp.pamphlet} \bibitem{12} {\bf \$SPAD/src/interp/construc.lisp.pamphlet} \bibitem{13} {\bf \$SPAD/src/interp/daase.lisp.pamphlet} -\bibitem{14} {\bf \$SPAD/src/interp/debug.lisp.pamphlet} \bibitem{16} {\bf \$SPAD/src/interp/fortcall.boot.pamphlet} \bibitem{17} {\bf \$SPAD/src/interp/fname.lisp.pamphlet} \bibitem{24} {\bf \$SPAD/src/interp/monitor.lisp.pamphlet} diff --git a/src/interp/debug.lisp.pamphlet b/src/interp/debug.lisp.pamphlet deleted file mode 100644 index f1a4e08..0000000 --- a/src/interp/debug.lisp.pamphlet +++ /dev/null @@ -1,1225 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp debug.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\subsection{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. -<>= -#-: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} -<>= -;; 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. - -@ -<<*>>= -<> - -;;; @(#)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 '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 - |$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 - |$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 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 "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 , evaluate (SETQ (BPITRACE )) -; To later untrace , evaluate (BPITRACE ) - -(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) - -<> - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/debugsys.lisp.pamphlet b/src/interp/debugsys.lisp.pamphlet index 2ff0988..a66f060 100644 --- a/src/interp/debugsys.lisp.pamphlet +++ b/src/interp/debugsys.lisp.pamphlet @@ -101,7 +101,6 @@ loaded by hand we need to establish a value. (thesymb "/int/interp/cparse.clisp") (thesymb "/int/interp/cstream.clisp") (thesymb "/int/interp/database.clisp") - (thesymb "/int/interp/debug.lisp") (thesymb "/int/interp/dq.clisp") (thesymb "/int/interp/fname.lisp") (thesymb "/int/interp/format.clisp") diff --git a/src/interp/vmlisp.lisp.pamphlet b/src/interp/vmlisp.lisp.pamphlet index ecc4ed6..515c288 100644 --- a/src/interp/vmlisp.lisp.pamphlet +++ b/src/interp/vmlisp.lisp.pamphlet @@ -2827,6 +2827,7 @@ do the compile, and then rename the result back to code.o. ; not defined at lower levels. (in-package "BOOT") +(use-package '("LISP" "VMLISP")) (defmacro def-boot-fun (f args where) `(compiler-let nil @@ -5206,6 +5207,1173 @@ terminals and empty or at-end files. In Common Lisp, we must assume record size continue-string error-string args ))))) +;;; @(#)debug.lisp 2.5 90/02/15 10:27:33 + +; NAME: Debugging Package +; PURPOSE: Debugging hooks for Boot code + + +(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)) + +(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 + |$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 + |$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 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 "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 , evaluate (SETQ (BPITRACE )) +; To later untrace , evaluate (BPITRACE ) + +(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) + +@ +\subsection{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. +<<*>>= +#-: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))) + @ \eject \begin{thebibliography}{99}