mirror of
https://github.com/PDP-10/its.git
synced 2026-03-27 02:24:15 +00:00
99 lines
3.1 KiB
Common Lisp
Executable File
99 lines
3.1 KiB
Common Lisp
Executable File
;;-*-LISP-*-
|
|
;; FIND 'DEM ERROR MESSAGES!
|
|
;; 4:32pm Saturday, 18 July 1981 -George Carrete.
|
|
|
|
;; Each function will get an MERROR, MFORMAT, MTELL, and ERRRJF
|
|
;; property which will be a string. From this we can generate
|
|
;; a report on all macsyma error messages and wisecracks.
|
|
;; Super neato.
|
|
|
|
;; Note: Due to pdp-10 address space problems or maclisp problems,
|
|
;; hard to tell which, we aren't doing a two-pass operation.
|
|
|
|
(eval-when (eval compile)
|
|
(or (get 'defmfile 'version)
|
|
(load '((Maxtul)defile)))
|
|
(or (get 'toolm 'version)
|
|
(load '((maxtul)toolm))))
|
|
|
|
(declare (special current-module macsyma-source-file faslread-type
|
|
faslread-object))
|
|
|
|
(DEFVAR MESSAGE-FUNCTIONS-TABLE
|
|
'((MERROR *MERROR-1 *MERROR-2 *MERROR-3 *MERROR-4 *MERROR-5)
|
|
(MFORMAT *MFORMAT-2 *MFORMAT-3 *MFORMAT-4 *MFORMAT-5)
|
|
(MTELL MTELL1 MTELL2 MTELL3 MTELL4 MTELL5)
|
|
(ERRRJF *ERRRJF-1)))
|
|
|
|
(MAPC #'(LAMBDA (L)
|
|
(MAPC #'(LAMBDA (F) (PUTPROP F (CAR L) 'DA-FUNCTION))
|
|
L))
|
|
MESSAGE-FUNCTIONS-TABLE)
|
|
|
|
(DEFVAR MESSAGE-FUNCTIONS (MAPCAR #'CAR MESSAGE-FUNCTIONS-TABLE))
|
|
(DEFVAR MESSAGE-FUNCTIONS-FLATSIZE
|
|
(APPLY #'MAX (MAPCAR #'FLATSIZE MESSAGE-FUNCTIONS)))
|
|
|
|
(DEFVAR CURRENT-PLIST NIL)
|
|
(DEFVAR CURRENT-MESSAGE NIL)
|
|
|
|
(DEFUN FIND-MESSAGES-IN-MODULE (M &AUX
|
|
(CURRENT-PLIST (LIST NIL))
|
|
(CURRENT-MESSAGE NIL))
|
|
(MAP-OVER-FASL-INFO-IN-MODULE
|
|
#'MESSAGE-SNOOP
|
|
M
|
|
'(QLIST ENTRY CALL MIN)))
|
|
|
|
(DEFUN MESSAGE-SNOOP (FORM)
|
|
(CASEQ FASLREAD-TYPE
|
|
((QLIST)
|
|
(COND ((AND (EQ (TYPEP FORM) 'HUNK2)
|
|
(EQ (CAR FORM) (FASLREADSQUID FASLREAD-OBJECT))
|
|
(EQ (CADR FORM) 'ALLOCATE-MESSAGE-INDEX))
|
|
(SETQ CURRENT-MESSAGE (CHECK-OUT-OF-CORE-STRING (EVAL (CDR FORM))))
|
|
(PUTPROP CURRENT-MESSAGE T '+INTERNAL-STRING-MARKER))))
|
|
((CALL)
|
|
(LET ((DA-FUNCTION (GET FORM 'DA-FUNCTION)))
|
|
(COND (DA-FUNCTION
|
|
(ADDPROP? CURRENT-PLIST CURRENT-MESSAGE DA-FUNCTION)
|
|
(SETQ CURRENT-MESSAGE NIL)))))
|
|
((ENTRY)
|
|
(COND ((CDR CURRENT-PLIST)
|
|
(SETF (CAR CURRENT-PLIST) (LIST FORM CURRENT-MODULE))
|
|
(OUTPUT-MESSAGE-PLIST CURRENT-PLIST)
|
|
(SETQ CURRENT-PLIST (LIST NIL)))))))
|
|
|
|
(defun find-all-MESSAGES (&aux (modules (macsyma-runtime-modules)))
|
|
(format msgfiles
|
|
"~&; Looking in the following modules for MESSAGES:~
|
|
~%~S~%"
|
|
modules)
|
|
(mapc #'find-MESSAGES-IN-MODULE modules))
|
|
|
|
(DEFUN OUTPUT-MESSAGE-PLIST (S)
|
|
(FORMAT MSGFILES "~&(~S" (CAR S))
|
|
(DO ((L MESSAGE-FUNCTIONS (CDR L))
|
|
(M))
|
|
((NULL L)
|
|
(FORMAT MSGFILES ")~%"))
|
|
(COND ((SETQ M (GET S (CAR L)))
|
|
(FORMAT MSGFILES "~% ~S~vx ("
|
|
(CAR L)
|
|
(- MESSAGE-FUNCTIONS-FLATSIZE (FLATSIZE (CAR L))))
|
|
(DO ()
|
|
((NULL M)
|
|
(PRINC ")" MSGFILES))
|
|
(PRIN1 (POP M) MSGFILES)
|
|
(IF M (FORMAT MSGFILES "~% ~vX "
|
|
MESSAGE-FUNCTIONS-FLATSIZE)))))))
|
|
|
|
(deftoolage module-messages ()
|
|
"look for messages in a module"
|
|
(find-messages-in-module
|
|
(car (completing-read "Module-> " (macsyma-runtime-modules)))))
|
|
|
|
(deftoolage find-all-messages ()
|
|
"Map over all FASL files for FSUBRS finding."
|
|
"Use the Report-on-fsubrs command after this to see summary"
|
|
(find-all-messages)) |