(FILECREATED "24-Apr-86 09:29:59" {DSK}<LISPFILES2>DCOMS>NUKE.;4 4559
previous date: " 3-Apr-86 16:22:38" {GOEDEL}<goedel/ports/xerox/lisp>NUKE)
(* Copyright (c) 1986 by Quintus Computer Systems, Inc. All rights reserved.)
(PRETTYCOMPRINT NUKECOMS)
(RPAQQ NUKECOMS ((SCCS) (* Code to smash atoms. QP.SMASH.ATOMS will smash all the function and
variable names on all the lisp files except those on the list QP.ATOMS.NOT.TO.SMASH. If given a file
name as argument, will write into the file enough information that all atom names can be retrieved by
LOADing that file.) (VARS QP.ATOMS.NOT.TO.SMASH) (GLOBALVARS QP.ATOMS.NOT.TO.SMASH \AtomSmashSysout) (
FNS QP.NUKE QP.NUKE.IF.ATOM QP.SMASH.ATOMS QP.VERIFY.ATOM.SMASH.SYSOUT)))
(* %%G% %%W% )
(* Code to smash atoms. QP.SMASH.ATOMS will smash all the function and variable names on all
the lisp files except those on the list QP.ATOMS.NOT.TO.SMASH. If given a file name as
argument, will write into the file enough information that all atom names can be retrieved by
LOADing that file.)
(RPAQQ QP.ATOMS.NOT.TO.SMASH (APROPOS ARITH AROUNDEXITFNS BIND BackgroundMenu BackgroundMenuCommands
CALL CELL CODE COUNT DEFVAR ENV ERROR FAIL FIRST FLAGS FORMAT GC GLOBALVARS INDEX INTERRUPTS JUMP
LAST LINK LISP LIST LOAD MASK META NAME NEXT NEXTCHAR OPCODES PROCS PROLOG PROLOG.ARGS PROLOG.FUNCTOR
PROLOG.TERM PROLOGHELPDIRECTORY PROLOGLIBRARYDIRECTORIES PROLOGROOTDIRECTORY QB QL QP.PROLOG.TEXEC
QP.VERIFY.ATOM.SMASH.SYSOUT SELECT TABLE TAGS TEDIT.DEFAULT.MENU TEDIT.DEFAULT.PROPS TEDITCARET VALUES
VALUES \AtomSmashSysout \DOGC1 \POPDISP.UFN \UnSmashAtom add apply arg before call compare either
fail fix float functor multiply or unless until when while zero))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS QP.ATOMS.NOT.TO.SMASH \AtomSmashSysout)
)
(DEFINEQ
(QP.NUKE
(LAMBDA (ATM FL) (* pds: "24-Nov-85 18:19") (if (AND (NOT (FMEMB ATM QP.ATOMS.NOT.TO.SMASH)) (for I
from 1 to (NCHARS ATM) thereis (NEQ (NTHCHARCODE ATM I) (CHARCODE X)))) then (if FL then (LET ((
ATOMSALVATION (\SmashAtom ATM))) (PRINTOUT FL "(\UnSmashAtom " (CAR ATOMSALVATION) , "%"" (CADR
ATOMSALVATION) "%")" T)) else (\SmashAtom ATM)))))
(QP.NUKE.IF.ATOM
(LAMBDA (POSSATOM) (DECLARE (SPECVARS FL)) (* pds: "24-Nov-85 17:10") (if (LITATOM (CAR POSSATOM))
then (QP.NUKE (CAR POSSATOM) FL))))
(QP.SMASH.ATOMS
(LAMBDA (FILE.TO.SAVE.ATOMNAMES.IN FILES.TO.NUKE EXTRA.ATOMS.TO.NUKE) (* pds: "28-Nov-85 22:28") (* *
smash all the Prolog atoms in the system. If FILE.TO.SAVE.ATOMNAMES.IN is provided, it becomes a file
with the antidote to the smashing. It can then be loaded back into the image to reinstate the smashed
atoms. Woe to the poor sod who loads such an antidote file into a SYSOUT other than the one that
created it. The first expr written into the file is designed to prevent that.) (LET ((FL (if
FILE.TO.SAVE.ATOMNAMES.IN then (OPENFILE FILE.TO.SAVE.ATOMNAMES.IN (QUOTE OUTPUT) (QUOTE NEW))))) (if
FL then (PRINTOUT FL (LIST (FUNCTION QP.VERIFY.ATOM.SMASH.SYSOUT) (KWOTE (SETQ \AtomSmashSysout (LIST
(IDATE) \MY.NSHOSTNUMBER)))) T)) (for F in FILES.TO.NUKE do (for FN in (FILECOMSLST F (QUOTE FNS)) do
(QP.NUKE FN FL)) (for MAC in (FILECOMSLST F (QUOTE MACROS)) do (QP.NUKE MAC FL)) (for GVR in (
FILECOMSLST F (QUOTE GLOBALVARS)) do (QP.NUKE GVR FL)) (for REC in (FILECOMSLST F (QUOTE RECORDS)) do
(QP.NUKE REC FL)) (for FLD in (FILECOMSLST F (QUOTE FIELDS)) do (QP.NUKE FLD FL)) (for CNST in (
FILECOMSLST F (QUOTE CONSTANTS)) do (QP.NUKE CNST FL)) (* * NB: the VARS on a file must be nuked LAST
for each file, since the fileCOMS is a variable considered to be on the file, and once it's nuked, you
can't get at anything else on the file.) (for VR in (FILECOMSLST F (QUOTE VARS)) do (QP.NUKE VR FL))
(QP.NUKE F FL)) (for A in EXTRA.ATOMS.TO.NUKE do (QP.NUKE A FL)) (* * I know this is ugly, but
QP.NUKE.IF.ATOM needs to pass FL to QP.NUKE, and since it's called from within a MAPHASH, there is no
clean way to get FL to it. Arrrrggggggg!) (DECLARE (SPECVARS FL)) (MAPHASH QP.INSTRUCTION.HARRAY (
FUNCTION QP.NUKE.IF.ATOM)) (MAPHASH QP.EXTENSION.HARRAY (FUNCTION QP.NUKE.IF.ATOM)) (if FL then (
PRINTOUT FL (QUOTE STOP) T) (CLOSEF FL)))))
(QP.VERIFY.ATOM.SMASH.SYSOUT
(LAMBDA (X) (* pds: "24-Nov-85 19:35") (if (NOT (EQUAL X \AtomSmashSysout)) then (ERROR
"Can't use this UNSMASH file on this image." "If you procede you will fall into a pit and be killed.")
)))
)
(PUTPROPS NUKE COPYRIGHT ("Quintus Computer Systems, Inc" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1839 4472 (QP.NUKE 1849 . 2207) (QP.NUKE.IF.ATOM 2209 . 2365) (QP.SMASH.ATOMS 2367 .
4240) (QP.VERIFY.ATOM.SMASH.SYSOUT 4242 . 4470)))))
STOP