(FILECREATED " 8-Oct-84 16:05:39" {ERIS}<LISPCORE>SOURCES>FILEPKG.;37 188377
changes to: (FNS \GR.METHODEXPANDER)
previous date: " 1-Oct-84 12:46:49" {ERIS}<LISPCORE>SOURCES>FILEPKG.;36)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved. The following program was
created in 1982 but has not been published within the meaning of the copyright law, is furnished
under license, and may not be used, copied and/or disclosed except in accordance with the terms of
said license.)
(PRETTYCOMPRINT FILEPKGCOMS)
(RPAQQ FILEPKGCOMS ((COMS (*
"standard records for accessing file package type/command parts. Exported for
PRETTY")
(EXPORT (DECLARE: EVAL@COMPILE DONTCOPY (FNS FILEPKGCOMPROPS)
(RECORDS * FILEPKGRECORDS)))
(FNS SEARCHPRETTYTYPELST PRETTYDEFMACROS)
(INITRECORDS * FILEPKGRECORDS))
(INITVARS (MSDATABASELST))
(* * "making, adding, listing, compiling files")
(FNS CLEANUP COMPILEFILES COMPILEFILES0 CONTINUEDIT MAKEFILE FILECHANGES FILEPKG.MERGECHANGES
FILEPKG.CHANGEDFNS MAKEFILE1 MAKEFILES ADDFILE ADDFILE0 LISTFILES)
(INITVARS (FILELST)
(LOADEDFILELST)
(NOTLISTEDFILES)
(NOTCOMPILEDFILES)
(MAKEFILEFORMS)
(NILCOMS))
(ADDVARS (MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST
STF (REC . RC)
(BREC . RC)
(TC . C)
(BC . C)
(TCOMPL . C)
(BCOMPL . C)))
(INITVARS (MAKEFILEREMAKEFLG T)
(CLEANUPOPTIONS (QUOTE (RC))))
(* * "scanning file coms")
(FNS FILEPKGCHANGES GETFILEPKGTYPE MARKASCHANGED FILECOMS WHEREIS SMASHFILECOMS FILEFNSLST
FILECOMSLST UPDATEFILES INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVALS
INFILECOMSVAL INFILECOMSPROP IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE INFILEPAIRS
INFILECOMSMACRO)
(* * "adding to a file")
(FNS FILES? FILES?1 ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
MAKENEWCOM DEFAULTMAKENEWCOM)
(INITVARS (DEFAULTCOMHASFILEFLG))
(FNS MERGEINSERT MERGEINSERT1)
(INITVARS (ADDTOFILEKEYLST (QUOTE ((%[ "" EXPLAINSTRING
"[ -- prettyprint the item to terminal and then ask again"
NOECHOFLG T)
(%
"" EXPLAINSTRING
"{line-feed} - same as previous response"
NOECHOFLG T)
(% "
" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
(%] "Nowhere
" EXPLAINSTRING "] - nowhere, item is marked as a dummy
" NOECHOFLG T)
(%( "List: (" EXPLAINSTRING "(list name)" NOECHOFLG T
KEYLST (( "" CONFIRMFLG (%) %] % %
)
RETURN
(CDR ANSWER))))
(@ "Near: " EXPLAINSTRING
"@ other-item -- put the item near the other item"
NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
)
RETURN ANSWER)))
(%
"" RETURN (QUOTE % ))
("" "File name: " EXPLAINSTRING "a file name" KEYLST
()))))
(LASTFILE))
(* * "deleting an item from a file")
(FNS DELFROMFILES DELFROMCOM DELFROMCOM1 DELFROMCOMS REMOVEITEM MOVETOFILE)
(P (MOVD? (QUOTE DELFROMFILES)
(QUOTE DELFROMFILE))
(MOVD? (QUOTE MOVETOFILE)
(QUOTE MOVEITEM)))
(ADDVARS (SYSPROPS PROPTYPE VARTYPE))
(ADDVARS * (LIST (CONS (QUOTE SYSPROPS)
MACROPROPS)))
(* * "functions for doing things and marking them changed and auxiliary functions")
(FNS SAVEPUT PUTPROPS ADDTOVAR APPENDTOVAR)
(FNS UNMARKASCHANGED PREEDITFN POSTEDITPROPS POSTEDITALISTS)
(ADDVARS (LISPXFNS (PUT . SAVEPUT)
(PUTPROP . SAVEPUT)))
(* * "sub-functions for file package commands & types")
(FNS ALISTS.WHENCHANGED CLEARCLISPARRAY EXPRESSIONS.WHENCHANGED MAKEALISTCOMS MAKEFILESCOMS
MAKELISPXMACROSCOMS MAKEPROPSCOMS MAKEUSERMACROSCOMS PROPS.WHENCHANGED)
(ADDVARS (MACROPROPS MACRO BYTEMACRO ALTOMACRO JMACRO VAXMACRO DMACRO 10MACRO)
(SYSPROPS PROPTYPE))
(PROP PROPTYPE I.S.OPR SUBR LIST CODE BRKINFO BROKEN-IN BROKEN FILEDATES FILE FILEMAP EXPR
ADVICE READVICE ADVISED VALUE)
(PROP VARTYPE BAKTRACELST BREAKMACROS COMPILETYPELST EDITMACROS ERRORTYPELST FONTDEFS
LISPXHISTORYMACROS LISPXMACROS PRETTYDEFMACROS PRETTYEQUIVLST PRETTYPRINTMACROS
PRETTYPRINTYPEMACROS USERMACROS)
(PROP PROPTYPE * (PROGN MACROPROPS))
(* * "Define the commands below AFTER the various properties have been established.")
(USERMACROS M)
(* * GETDEF "functions")
(FNS RENAME CHANGECALLERS)
(FNS SHOWDEF COPYDEF GETDEF GETDEFCOM GETDEFCOM0 GETDEFCURRENT GETDEFERR GETDEFFROMFILE
GETDEFSAVED PUTDEF EDITDEF LOADDEF DWIMDEF DELDEF DELFROMLIST HASDEF GETFILEDEF SAVEDEF
UNSAVEDEF COMPAREDEFS COMPARE TYPESOF)
(* Must come after PUTDEF)
(COMS (* *
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS
in order to get started.")
(FNS FILEPKGCOM FILEPKGTYPE)
(PROP ARGNAMES FILEPKGCOM)
(ADDVARS (FILEPKGCOMSPLST FILEPKGCOMS)
(FILEPKGTYPES FILEPKGCOMS))
(FILEPKGCOMS FILEPKGCOMS)
(FILEPKGCOMS ADVICE ALISTS DEFS EDITMACROS EXPRESSIONS FIELDS FILES FILEPKGTYPES
FILEVARS FNS INITVARS INITRECORDS LISPXCOMS LISPXMACROS MACROS
PRETTYDEFMACROS PROPS RECORDS SYSRECORDS USERMACROS VARS *))
(INITVARS (SAVEDDEFS)
(DEFAULTRENAMEMETHOD))
(* * EDITCALLERS)
(FNS FINDCALLERS EDITCALLERS EDITFROMFILE FINDATS LOOKIN)
(FNS SEPRCASE)
(INITVARS (SEPRCASE)
(CLISPCASE))
(P (MOVD? (QUOTE INFILEP)
(QUOTE FINDFILE))
(* "or else from SPELLFILE"))
(BLOCKS (FINDATS FINDATS)
(EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
(NOLINKFNS LOADFROM))
(NIL SEPRCASE FINDCALLERS EDITCALLERS (LOCALVARS . T)
(GLOBALVARS SYSFILES CLISPCASE SEPRCASE CLISPFLG CLISPCHARS FCHARAR)))
(COMS (* * EXPORT)
(FNS IMPORTFILE IMPORTEVAL CHECKIMPORTS GATHEREXPORTS)
(FILEPKGCOMS EXPORT)
(INITVARS (EXPORTDEFSTRING (CONCAT "(* FOLLOWING " "DEFINITIONS EXPORTED)")))
(BLOCKS (IMPORTFILE IMPORTFILE IMPORTEVAL)))
(* * for GAINSPACE)
(FNS CLEARFILEPKG)
(ADDVARS (GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
((Y "es")
(N "o")
(E . "verything")
(F "ilemaps only
")))))
(BLOCKS (NIL CLEARFILEPKG (GLOBALVARS SMASHPROPSLST1)))
(GLOBALVARS #LISTFILESCHARS #UNDOSAVES ADDTOFILEKEYLST BUILDMAPFLG CLEANUPOPTIONS CLISPARRAY
CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST DEFAULTRENAMEMETHOD DFNFLG
DWIMESSGAG DWIMFLG DWIMIFYCOMPFLG DWIMLOADFNSFLG DWIMWAIT FILELST FILEPKGCOMSPLST
FILEPKGFLG FILEPKGTYPES FILERDTBL FONTCHANGEFLG HISTORYCOMS HISTSTR0 I.S.OPRLST
LASTFILE LISPXCOMS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS LISTFILESTR
LOADEDFILELST MACROPROPS MAKEFILEFORMS MAKEFILEOPTIONS MAKEFILEREMAKEFLG
MSDATABASELST NOSPELLFLG NOTCOMPILEDFILES NOTLISTEDFILES PRETTYDEFMACROS
PRETTYFLG PRETTYHEADER PRETTYTRANFLG PRETTYTYPELST SAVEDDEFS SYSFILES SYSPROPS
USERMACROS USERRECLST USERWORDS)
(COMS (* RESOURCE "management")
(MACROS NEWRESOURCE GETRESOURCE FREERESOURCE WITH-RESOURCE WITH-RESOURCES)
(FNS \GR.METHODEXPANDER \GR.WITHRESOURCEMAC)
(FILEPKGCOMS RESOURCES INITRESOURCES)
(FNS \GR.GETDEFFN \GR.PUTDEFFN \GR.DELDEFFN \GR.CONTENTS)
(FNS \GR.MAKEPRETTYCOMSL \IGR.MAKEPRETTYCOMSL)
(INITVARS (GLOBAL.RESOURCES))
(GLOBALVARS GLOBAL.RESOURCES))
(COMS (* "need only be in ABC")
(MACROS GLOBALRESOURCE GLOBALRESOURCES)
(FILEPKGCOMS GLOBALRESOURCES)
(MACROS RELEASERESOURCE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA \IGR.MAKEPRETTYCOMSL \GR.MAKEPRETTYCOMSL MAKEUSERMACROSCOMS
MAKEPROPSCOMS MAKELISPXMACROSCOMS MAKEFILESCOMS MAKEALISTCOMS
APPENDTOVAR ADDTOVAR PUTPROPS LISTFILES COMPILEFILES CLEANUP
PRETTYDEFMACROS FILEPKGCOMPROPS)
(NLAML)
(LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)))
(BLOCKS (DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
(SPECVARS COMSNAME))
(MERGEINSERT MERGEINSERT MERGEINSERT1 (NOLINKFNS . T))
(ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
(NOLINKFNS . T)
(SPECVARS COMSNAME)
(ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES?))
(INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL
INFILECOMSVALS INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE
IFCPROPSCAN IFCDECLARE (LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE
ORIGFLG)
INFILECOMSPROP
(GLOBALVARS DWIMLOADFNSFLG))
(NIL MAKEFILE (LOCALVARS . T)
(SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
(ADDFILE ADDFILE ADDFILE0 (NOLINKFNS . T)
(GLOBALVARS ADDSPELLFLG))
(FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
(NIL ADDTOVAR APPENDTOVAR ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY
COMPARE COMPAREDEFS COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF
DEFAULTMAKENEWCOM DELFROMFILES EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS
FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS FILEPKGTYPE FILES? FILES?1
GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS MAKEFILE1 MAKEFILES
MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS MAKEUSERMACROSCOMS
MARKASCHANGED MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS
PROPS.WHENCHANGED PUTDEF PUTPROPS RENAME SAVEDEF SAVEPUT SEARCHPRETTYTYPELST
SHOWDEF SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF UPDATEFILES
(GLOBALVARS #UNDOSAVES SYSFILES MARKASCHANGEDSTATS ADDSPELLFLG COMPILE.EXT
EDITMACROS EDITLOADFNSFLG LOADOPTIONS)
(LOCALVARS . T))
(DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
(GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE
GETDEFSAVED (RETFNS GETDEFCOM)
(NOLINKFNS . T)
(GLOBALVARS NOT-FOUNDTAG)))))
(* "standard records for accessing file package type/command parts. Exported for
PRETTY")
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE DONTCOPY
(DEFINEQ
(FILEPKGCOMPROPS
[NLAMBDA PROPS
(MAPC PROPS (FUNCTION (LAMBDA (Y)
(OR (MEMB Y SYSPROPS)
(SETQ SYSPROPS (CONS Y SYSPROPS)))
(PUT Y (QUOTE PROPTYPE)
(QUOTE FILEPKGCOMS])
)
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
[DECLARE: EVAL@COMPILE
(ACCESSFNS FILEPKGCOM ((ADD (GETPROP DATUM (QUOTE ADDTOPRETTYCOM))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE ADDTOPRETTYCOM)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE ADDTOPRETTYCOM))))))
(DELETE (GETPROP DATUM (QUOTE DELFROMPRETTYCOM))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE DELFROMPRETTYCOM)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE DELFROMPRETTYCOM))))))
(PRETTYTYPE (GETPROP DATUM (QUOTE PRETTYTYPE))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE PRETTYTYPE)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE PRETTYTYPE))))))
(CONTENTS (GETPROP DATUM (QUOTE FILEPKGCONTENTS))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE FILEPKGCONTENTS)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE FILEPKGCONTENTS))))))
(MACRO (CDR (FASSOC DATUM (GETTOPVAL (QUOTE PRETTYDEFMACROS))))
(STANDARD (COND
(NEWVALUE (PUTASSOC DATUM NEWVALUE
(OR (LISTP (GETTOPVAL (QUOTE
PRETTYDEFMACROS)))
(SETTOPVAL (QUOTE PRETTYDEFMACROS)
(LIST (LIST DATUM))))))
(T (SETTOPVAL (QUOTE PRETTYDEFMACROS)
(REMOVE (FASSOC DATUM (GETTOPVAL
(QUOTE PRETTYDEFMACROS)))
(GETTOPVAL (QUOTE PRETTYDEFMACROS)))))
)
UNDOABLE
(COND
(NEWVALUE (/PUTASSOC DATUM NEWVALUE
(OR (LISTP (GETTOPVAL (QUOTE
PRETTYDEFMACROS)))
(/SETTOPVAL (QUOTE PRETTYDEFMACROS)
(LIST (LIST DATUM))))))
(T (/SETTOPVAL (QUOTE PRETTYDEFMACROS)
(REMOVE (FASSOC DATUM (GETTOPVAL
(QUOTE PRETTYDEFMACROS)))
(GETTOPVAL (QUOTE PRETTYDEFMACROS))))
))))) (* Not an atom record cause want REMPROP on NILs.)
(* NOTE: PRETTCOM on PRETTY has open-coded access to
the MACRO property.)
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
FILEPKGCONTENTS)))
(ACCESSFNS FILEPKGTYPE ((NEWCOM (GETPROP DATUM (QUOTE NEWCOMFN))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE NEWCOMFN)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE NEWCOMFN))))))
(WHENFILED (GETPROP DATUM (QUOTE NOTICEFN))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE NOTICEFN)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE NOTICEFN))))))
(WHENUNFILED (GETPROP DATUM (QUOTE WHENUNFILED))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE WHENUNFILED)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE WHENUNFILED))))))
(GETDEF (GETPROP DATUM (QUOTE GETDEF))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE GETDEF)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE GETDEF))))))
(PUTDEF (GETPROP DATUM (QUOTE PUTDEF))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE PUTDEF)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE PUTDEF))))))
(DELDEF (GETPROP DATUM (QUOTE DELDEF))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE DELDEF)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE DELDEF))))))
(WHENCHANGED (GETPROP DATUM (QUOTE WHENCHANGED))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE WHENCHANGED)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE WHENCHANGED))))))
(HASDEF (GETPROP DATUM (QUOTE HASDEF))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE HASDEF)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE HASDEF))))))
(EDITDEF (GETPROP DATUM (QUOTE EDITDEF))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE EDITDEF)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE EDITDEF))))))
(FILEGETDEF (GETPROP DATUM (QUOTE FILEGETDEF))
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM (QUOTE FILEGETDEF)
NEWVALUE))
(T (/REMPROP DATUM (QUOTE FILEGETDEF))))))
(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
(CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE)))
(CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM)))
(STANDARD (SETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
NEWVALUE)
UNDOABLE
(/SETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
NEWVALUE)))
(DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST DATUM)))
(CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
NEWVALUE)))
(ALLFIELDS NIL (/SETTOPVAL (QUOTE PRETTYTYPELST)
(REMOVE (SEARCHPRETTYTYPELST DATUM)
(GETTOPVAL (QUOTE PRETTYTYPELST))))))
(* NOTE: PRETTYCOM on PRETTY has open-coded access to
GETDEF property)
(INIT (FILEPKGCOMPROPS NEWCOMFN NOTICEFN WHENCHANGED GETDEF PUTDEF EDITDEF
DELDEF HASDEF)
(ADDTOVAR PRETTYTYPELST)))
(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
(ACCESSFNS FILE ((FILEPROP (GETPROP DATUM (QUOTE FILE))
(STANDARD (PUTPROP DATUM (QUOTE FILE)
NEWVALUE)
UNDOABLE
(/PUTPROP DATUM (QUOTE FILE)
NEWVALUE))))))
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
]
(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)
(FILEPKGCOMPROPS NEWCOMFN NOTICEFN WHENCHANGED GETDEF PUTDEF EDITDEF DELDEF HASDEF)
(ADDTOVAR PRETTYTYPELST)
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(SEARCHPRETTYTYPELST
[LAMBDA (TYPE FLG) (* rmk: " 3-JAN-82 22:55")
(* access functions used by the records)
(AND (LITATOM TYPE)
(OR (find X in PRETTYTYPELST suchthat (EQ (CADR X)
TYPE))
(COND
(FLG [/SETTOPVAL (QUOTE PRETTYTYPELST)
(CONS (SETQ FLG (LIST (PACK* (QUOTE CHANGED)
TYPE
(QUOTE LST))
TYPE NIL))
(GETTOPVAL (QUOTE PRETTYTYPELST]
(OR (LISTP (GETTOPVAL (CAR FLG)))
(/SETTOPVAL (CAR FLG)
NIL))
FLG])
(PRETTYDEFMACROS
[NLAMBDA ARGS (* lmm " 5-SEP-78 16:16")
(* included so that old files will continue to load)
(for X in ARGS collect (FILEPKGCOM (CAR X)
(QUOTE MACRO)
(CDR X])
)
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS)
(FILEPKGCOMPROPS NEWCOMFN NOTICEFN WHENCHANGED GETDEF PUTDEF EDITDEF DELDEF HASDEF)
(ADDTOVAR PRETTYTYPELST)
(RPAQ? MSDATABASELST )
(* * "making, adding, listing, compiling files")
(DEFINEQ
(CLEANUP
[NLAMBDA FILES (* lmm "14-Aug-84 19:17")
(PROG (TEM1 TEM2 OPTIONS)
(COND
([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
(SETQ OPTIONS (CAR FILES))
(SETQ FILES (CDR FILES)))
(T (SETQ OPTIONS CLEANUPOPTIONS)))
(RETURN (APPEND (MAKEFILES OPTIONS FILES)
(COND
((NOT (MEMB (QUOTE LIST)
OPTIONS))
NIL)
((NULL FILES)
(LISTFILES))
((SETQ TEM1 (INTERSECTION FILES NOTLISTEDFILES))
(* Intersection check because LISTFILES applied to NIL
means list all of NOTLISTEDFILES.)
(APPLY (QUOTE LISTFILES)
TEM1)))
(COND
[(NULL (SETQ TEM1 (MEMB (QUOTE RC)
OPTIONS]
((NULL FILES)
(COMPILEFILES0 (SETQ TEM2 NOTCOMPILEDFILES)
(CDR TEM1))
TEM2)
((SETQ TEM2 (INTERSECTION FILES NOTCOMPILEDFILES))
(COMPILEFILES0 TEM2 (CDR TEM1))
TEM2])
(COMPILEFILES
[NLAMBDA FILES (* lmm "14-Aug-84 19:17")
(COND
([LISTP (CAR (SETQ FILES (NLAMBDA.ARGS FILES]
(COMPILEFILES0 (CDR FILES)
(CAR FILES)))
(T (COMPILEFILES0 FILES])
(COMPILEFILES0
[LAMBDA (FILES OPTIONS) (* rmk: "19-FEB-83 21:59")
(for X OPTS (RCFLG ← T) on (OR FILES NOTCOMPILEDFILES) first (SETQ OPTS
(SELECTQ (CAR (LISTP OPTIONS))
(C (SETQ RCFLG NIL)
(CDR OPTIONS))
(RC (CDR OPTIONS))
OPTIONS))
do (MAKEFILE1 (OR (MISSPELLED? (CAR X)
70 FILELST NIL X)
(CAR X))
RCFLG OPTS X])
(CONTINUEDIT
[LAMBDA (FILE) (* rmk: "19-FEB-83 14:59")
(PROG (FL TEM X)
(SETQ FILE (INPUT (INFILE FILE)))
(SETFILEPTR FILE 0)
(SETQ X (READ FILE FILERDTBL))
(CLOSEF FILE)
(COND
([NOT (fetch FILEPROP of (SETQ FL (ROOTFILENAME FILE]
(LOADFROM FILE) (* also calls addfile to notice the file.)
))
(/replace FILECHANGES of FL (FILECHANGES X))
[/replace FILEDATES of FL with (LIST (create FILEDATEPAIR
FILEDATE ←(CADR X)
DATEFILENAME ← FILE)
(create FILEDATEPAIR
FILEDATE ←[CAR (SETQ TEM
(CDR (MEMB (QUOTE date:)
X]
DATEFILENAME ←(CADR TEM]
(RETURN FILE])
(MAKEFILE
[LAMBDA (FILE OPTIONS REPRINTFNS SOURCEFILE) (* lmm " 1-Oct-84 12:14")
(* OPTIONS: FAST means dump with PRETTYFLG set to NIL; LIST means list the FILE; RC means RECOMPILE, uses BRECOMPILE
if FILEblocks is NOBIND, OTHERWISE RECOMPILE; -
C means COMPILE, uses BCOMPL if FILEblocks is NOBIND, otherwise TCOMPL; -
for C AND RC assume ST unless next option is F.)
(PROG (FILETYPE ROOTNAME FILEPROP CHANGES FILEDATES (Z (ADDFILE FILE)))
(SETQ FILE (CAR Z)) (* Necessary because FILE might have been misspelled.)
(SETQ ROOTNAME (CADR Z)) (* result of (ROOTFILENAME FILE), or if FILE is
corrected, result of applying ROOTFILENAME to correct
value.)
(SETQ FILEPROP (CDDR Z))
(UPDATEFILES) (* Want updating done after file is added to filelst,
so any functions that are being dumped are marked as
having been dumped.)
(SETQ OPTIONS (MKLIST OPTIONS))
(SETQ CHANGES (fetch TOBEDUMPED of FILEPROP))
(SETQ FILEDATES (LISTP (fetch FILEDATES of ROOTNAME)))
(SETQ FILETYPE (GETPROP ROOTNAME (QUOTE FILETYPE)))
LP0 (if (AND (NULL (fetch LOADTYPE of FILEPROP))
(NULL FILEDATES))
then (* File has never been loaded and never dumped i.e.
user just set up COMS in core)
elseif [OR (EQMEMB (QUOTE NEW)
OPTIONS)
(AND (NULL MAKEFILEREMAKEFLG)
(NOT (MEMB (QUOTE REMAKE)
OPTIONS]
then (COND
((AND (fetch LOADTYPE of FILEPROP)
(NEQ T (fetch LOADTYPE of FILEPROP)))
(LISPXPRIN2 FILE T T)
(LISPXPRIN1 (SELECTQ (fetch LOADTYPE of FILEPROP)
(LOADCOMP
"the file was loaded for compilation purposes only")
((compiled Compiled COMPILED)
" -- only the compiled file has been loaded
")
((loadfns LOADFNS)
" -- only some of its symbolics have been loaded
")
(SHOULDNT))
T)
(COND
((NEQ (ASKUSER DWIMWAIT (QUOTE Y)
(QUOTE "do you want to go ahead and MAKEFILE anyway ?"))
(QUOTE Y)) (* E.g. user loads a .com file and then resets the COMS
or defines the functons by hand.)
(GO OUT)))
(/replace LOADTYPE of FILEPROP with NIL)))
(SETQ SOURCEFILE NIL)
(SETQ REPRINTFNS NIL)
elseif SOURCEFILE
then (* source file given)
elseif [AND FILEDATES (OR [AND (SETQ SOURCEFILE (FINDFILE ROOTNAME))
(EQUAL (FILEDATE SOURCEFILE)
(fetch FILEDATE of (CAR FILEDATES]
(AND [NEQ SOURCEFILE (SETQ SOURCEFILE (fetch DATEFILENAME
of (CAR FILEDATES]
(INFILEP SOURCEFILE)
(EQUAL (FILEDATE SOURCEFILE)
(fetch FILEDATE of (CAR FILEDATES]
then (/replace DATEFILENAME of (CAR FILEDATES) with SOURCEFILE)
(OR REPRINTFNS (SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES)))
elseif [AND (CDR FILEDATES)
[SETQ SOURCEFILE (INFILEP (fetch DATEFILENAME of (CADR FILEDATES]
(EQUAL (FILEDATE SOURCEFILE)
(fetch FILEDATE of (CADR FILEDATES]
then (* prevous version file is gone, drop back to original
daddy file and dump everything that has been changed.)
(SETQ CHANGES (FILEPKG.MERGECHANGES (fetch TOBEDUMPED of FILEPROP)
(fetch FILECHANGES of ROOTNAME)))
(SETQ REPRINTFNS (FILEPKG.CHANGEDFNS CHANGES))
else (LISPXPRIN1 (QUOTE
"can't find either the previous version or the original version of
")
T)
(LISPXPRIN2 FILE T T)
(LISPXPRIN1 (QUOTE ", so it will have to be written anew
")
T)
(SETQ SOURCEFILE NIL)
(SETQ REPRINTFNS NIL)
(push OPTIONS (QUOTE NEW))
(SETQ CHANGES (fetch FILECHANGES of ROOTNAME))
(GO LP0))
[COND
((AND SOURCEFILE (SETQ Z (SELECTQ (fetch LOADTYPE of FILEPROP)
(LOADCOMP (* only loaded via LOADCOMP.
Need to do LOADFROM)
(LIST (QUOTE N)
SOURCEFILE "was loaded with LOADCOMP"
(QUOTE -)
"LOADFROM it to obtain VARS/COMS"))
(Compiled (AND (INFILECOMS? (QUOTE DONTCOPY)
(QUOTE DECLARE:)
(fetch COMSNAME
of FILEPROP))
(LIST (QUOTE Y)
"only compiled version of"
ROOTNAME
"was loaded; LOADVARS the (DECLARE .. DONTCOPY ) expressions")))
((compiled loadfns)
(LIST (QUOTE N)
"Only some functions from" SOURCEFILE
"loaded via LOADFNS. Load all other expressions from it"))
NIL)))
(COND
((EQ (ASKUSER DWIMWAIT (CAR Z)
(CDR Z))
(QUOTE Y))
(SELECTQ (fetch LOADTYPE of FILEPROP)
(LOADCOMP (* file was never actually loaded, justloadcomped.
thus no filecoms)
(LOADFROM SOURCEFILE))
(Compiled
(* This is going to be a remake. If it was originally loaded as a compiled file, must first do a LOADFROM in order
to get the properties set up by declare: etc.)
(LOADVARS (QUOTE DONTCOPY)
SOURCEFILE)
(/replace LOADTYPE of FILEPROP with (QUOTE COMPILED))
(* So wont have to be done again.)
(* These are the only DECLARE:'s that are not also on the copiled file. Note that a DECLARE: DONTEVAL@LOAD will be
found and evaluated, but the corresponding expressions wont be evaluated from within the DECLARE: Not worthwhile to
bother setting up a complicated edit pattern to screen these out, especially if you consider expressions like
(DECLARE: -- DONTEVAL@LOAD -- DOEVAL@LOAD --))
)
((loadfns compiled)
(* This is going to be a remake, but the original call to LOADFNS didnt specify all the VARS, so some expressions
may not have been loaded.)
(LOADVARS T SOURCEFILE))
NIL))
(T (GO OUT]
(RESETLST [COND
((MEMB (QUOTE NOCLISP)
OPTIONS)
(RESETSAVE PRETTYTRANFLG T))
((MEMB (QUOTE CLISP% )
OPTIONS)
(RESETSAVE PRETTYTRANFLG (QUOTE BOTH]
(RESETSAVE #UNDOSAVES)
(COND
((MEMB (QUOTE FAST)
OPTIONS)
(RESETSAVE PRETTYFLG NIL)))
[COND
((OR (MEMB (QUOTE CLISPIFY)
OPTIONS)
(MEMB (QUOTE CLISP)
OPTIONS))
(RESETSAVE CLISPIFYPRETTYFLG T))
((OR (EQ FILETYPE (QUOTE CLISP))
(MEMB (QUOTE CLISP)
(LISTP FILETYPE)))
(RESETSAVE CLISPIFYPRETTYFLG (QUOTE CHANGES]
(SELECTQ (RADIX)
((8 10) (* make sure radix is either 8 or 10, because all
others don't read in like they print)
NIL)
(RESETSAVE (RADIX 10)))
(for X in MAKEFILEFORMS do (ERSETQ (EVAL X)))
(SETQ FILE (PRETTYDEF NIL FILE (fetch COMSNAME of FILEPROP)
REPRINTFNS SOURCEFILE CHANGES)))
(SETQ LASTFILE ROOTNAME)
(/replace TOBEDUMPED of FILEPROP with NIL)
(COND
((NOT (EQMEMB (QUOTE DON'TLIST)
FILETYPE))
(pushnew NOTLISTEDFILES ROOTNAME)))
(COND
((AND (NOT (EQMEMB (QUOTE DON'TCOMPILE)
FILETYPE))
(INFILECOMS? T (QUOTE FNS)
(fetch COMSNAME of FILEPROP)))
(* No functions in the file.)
(pushnew NOTCOMPILEDFILES ROOTNAME)))
[for TAIL OPT on OPTIONS
do (SETQ OPT (CAR TAIL))
(SELECTQ OPT
[RC (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
(MAKEFILE1 FILE T (CDR TAIL]
[C (AND (MEMB ROOTNAME NOTCOMPILEDFILES)
(MAKEFILE1 FILE NIL (CDR TAIL]
[LIST (AND (MEMB ROOTNAME NOTLISTEDFILES)
(APPLY (QUOTE LISTFILES)
(LIST FILE]
(COND
((MEMB OPT MAKEFILEOPTIONS))
((FIXSPELL OPT NIL MAKEFILEOPTIONS NIL OPTIONS)
(GO $$LP))
(T (ERROR "Unrecognized MAKEFILE option" OPT]
(RETURN FILE)
OUT (RETURN (CONS FILE (QUOTE (QUOTE (- MAKEFILE not performed.])
(FILECHANGES
[LAMBDA (FILE TYPE) (* rmk: "22-MAY-82 13:44"
)
(* If FILE is a list, it is assumed to be a
file-created expressions; otherwise, the filecreated
expression is read from FILE.
If TYPE, returns the list of changed items of that
type from the changes expression.
If TYPE=NIL, returns the whole list of typed
change-lists)
(PROG [FNS
CHANGES
(FCEXPR
(OR
(LISTP FILE)
(AND
FILE
(RESETLST
(PROG (OPENFLG)
[COND
((SETQ OPENFLG (OPENP FILE (QUOTE INPUT)))
(SETQ FILE OPENFLG))
(T (* INFILE used instead
of INFILEP to allow for
error correction.)
(RESETSAVE (SETQ FILE
(OPENFILE FILE
(QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF?
OLDVALUE]
LP (COND
((FILEPOS (QUOTE "(FILECREATED")
FILE NIL (IPLUS (GETFILEPTR
FILE)
20))
(RETURN (READ FILE FILERDTBL)))
((AND OPENFLG (RANDACCESSP FILE))
(* File was originally
open. If possible, reset
to beginning and try
again.)
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
FILE
(GETFILEPTR FILE)))
(SETQ OPENFLG NIL)
(SETFILEPTR FILE 0)
(GO LP]
(SETQ CHANGES (LDIFF (SETQ CHANGES
(CDR (MEMB (QUOTE to:)
FCEXPR)))
(MEMB (QUOTE previous)
CHANGES)))
[AND TYPE (NEQ TYPE (QUOTE FNS))
(RETURN (CDR (ASSOC TYPE CHANGES]
(SETQ FNS (SUBSET CHANGES (FUNCTION LITATOM)))
(RETURN (COND
[TYPE (* TYPE=FNS cause of
test above.)
(NCONC FNS (CDR (ASSOC (QUOTE FNS)
CHANGES]
[FNS (CONS (CONS (QUOTE FNS)
FNS)
(SUBSET CHANGES (FUNCTION LISTP]
(T CHANGES])
(FILEPKG.MERGECHANGES
[LAMBDA (C1 C2) (* rmk: "24-MAY-82 23:09"
)
(* Merges 2 changes lists into a single one.
Treat LITATOM's as FNS, to accomodate old-style
format on files.)
(for E2 TEMP (VAL ←(for E1 in C1 when (CDR (LISTP E1))
collect (APPEND E1)))
in C2 do [COND
((SETQ TEMP (ASSOC (CAR E2)
VAL))
(NCONC TEMP (for X in (CDR E2)
unless (MEMBER X (CDR TEMP))
collect X)))
(T (SETQ VAL (NCONC1 VAL (APPEND E2]
finally (RETURN VAL])
(FILEPKG.CHANGEDFNS
[LAMBDA (CHANGES) (* rmk: "20-MAY-82 22:00"
)
(* Returns list of function names from a
file-changes list. Interprets old format
(functios are atoms) and new format
(with explicit type headers))
(CDR (ASSOC (QUOTE FNS)
CHANGES])
(MAKEFILE1
[LAMBDA (FILE RECOMPFLG OPTIONS OTHERFILES) (* rmk: "19-FEB-83 21:43")
(PROG (GROUP (ROOTNAME (ROOTFILENAME FILE)))
(SETQ GROUP (GETPROP ROOTNAME (QUOTE FILEGROUP)))
(COND
([find X in GROUP suchthat (AND (NEQ X ROOTNAME)
(OR (fetch TOBEDUMPED of (fetch FILEPROP of X))
(MEMB X OTHERFILES]
(* The file in question must be recompiled with other files, and one of the remaining files still needs to be
dumped, or else one of the other file is further down the list of files being compiled. Wait..)
(RETURN)))
(LISPXPRIN1 (QUOTE "
compiling ")
T)
(LISPXPRINT (OR GROUP FILE)
T T)
[COND
((MEMB (CAR OPTIONS)
(QUOTE (ST F S STF)))
(LISPXUNREAD (LIST (CAR OPTIONS]
(LISPXPRINT [COND
[GROUP (* File contained in FILEGROUP.
Therefore must be blockcompiled.)
(COND
(RECOMPFLG (BRECOMPILE GROUP))
(T (BCOMPL GROUP]
[(INFILECOMS? T (QUOTE BLOCKS)
(FILECOMS ROOTNAME))
(COND
(RECOMPFLG (BRECOMPILE FILE))
(T (BCOMPL (LIST FILE]
(RECOMPFLG (RECOMPILE FILE))
(T (TCOMPL (LIST FILE]
T T])
(MAKEFILES
[LAMBDA (OPTIONS FILES) (* rmk: "23-FEB-83 21:20")
(RESETVARS (#UNDOSAVES)
(UPDATEFILES)
[COND
((NULL FILES)
(for TYPE FLG in FILEPKGTYPES when [FILES?1 TYPE (COND
((NULL FLG)
(* Gets printed the first time)
(QUOTE
"****NOTE: the following are not contained on any file:
"))
(T (QUOTE " "]
do (SETQ FLG T) finally (AND FLG (ADDTOFILES?]
(SETQ OPTIONS (MKLIST OPTIONS))
(RETURN (for FILE inside (OR FILES FILELST) when [fetch TOBEDUMPED
of (LISTP (fetch FILEPROP
of (ROOTFILENAME
FILE]
collect (LISPXPRIN2 FILE T T)
(LISPXPRIN1 (QUOTE ...)
T)
(PROG1 (MAKEFILE FILE OPTIONS)
(LISPXTERPRI T])
(ADDFILE
[LAMBDA (FILE LOADTYPE PRLST FCLST) (* rmk: "23-FEB-83 21:25")
(* PRLST is the FILEPKGCHANGES prior to this file operation, FCLST is a list of file-created arguments, a singleton
for a symbolic file, and a list whose car represents the compiled file and whose cdr represent symbolic files
compiled into it, for compiled files.)
(PROG (VAL FLST (ROOTNAME (ROOTFILENAME FILE)))
[COND
([AND LOADTYPE (NOT (MEMB FILE (GETTOPVAL (QUOTE LOADEDFILELST]
(/SETTOPVAL (QUOTE LOADEDFILELST)
(CONS FILE (GETTOPVAL (QUOTE LOADEDFILELST]
[COND
([AND (NOT FCLST)
(NOT (SETQ FCLST (CADDR (fetch FILEMAP of ROOTNAME]
(SETQ VAL (ADDFILE0 ROOTNAME LOADTYPE FILE)))
[(NULL (CDR FCLST)) (* A simple symbolic file)
(SETQ FCLST (CAR FCLST))
(SETQ VAL (ADDFILE0 (COND
((LITATOM (CADR FCLST))
(ROOTFILENAME (CADR FCLST)))
(T ROOTNAME))
LOADTYPE FILE (CAR FCLST]
(T (* A compiled file, skip the first expression
representing the compiled file itself, look at the cdr
representing the symbolic files.)
(SELECTQ LOADTYPE
((T LOADFNS)
(SETQ LOADTYPE (QUOTE Compiled)))
(loadfns (SETQ LOADTYPE (QUOTE compiled)))
(LOADCOMP (* loadcomp on compiled file.
Don't notice since we don't know what its state is)
NIL)
(SHOULDNT))
(for X in (CDR FCLST) when (LITATOM (CADR X))
do (push FLST (CADR X))
(OR (EQ LOADTYPE (QUOTE LOADCOMP))
(ADDFILE0 (ROOTFILENAME (CADR X))
LOADTYPE
(CADR X)
(CAR X]
(UPDATEFILES PRLST (OR FLST (LIST FILE)))
[AND LOADTYPE (for TYPE CHANGED in FILEPKGTYPES when (AND (LITATOM TYPE)
(SETQ CHANGED (fetch CHANGED of TYPE)))
do (/replace CHANGED of TYPE with (INTERSECTION (CDR (ASSOC TYPE PRLST))
CHANGED]
(AND ADDSPELLFLG (ADDSPELL ROOTNAME USERWORDS))
(RETURN VAL])
(ADDFILE0
[LAMBDA (ROOTNAME LOADTYPE FULLNAME DAT) (* lmm "12-AUG-84 15:08")
(PROG (COMS X FILEPROP FLG TEM)
TOP (SETQ COMS (FILECOMS ROOTNAME))
[COND
((SETQ FILEPROP (fetch FILEPROP of ROOTNAME))
(COND
([AND LOADTYPE (FMEMB LOADTYPE (CDR (FMEMB (fetch LOADTYPE of FILEPROP)
(QUOTE (LOADCOMP loadfns compiled Compiled LOADFNS COMPILED NIL T]
(/replace LOADTYPE of FILEPROP with LOADTYPE)
(* This call to aDDFILE reflects a 'higher' degree of loading, so upgrade property. 'loadfns' means just some
information from file, if go to do makefile, must do loadfrom, 'compiled' is like 'loadfns' but for compiled files
e.g. user does LOADFNS on compiled file. 'Compiled' means all but DECLARE: expressions are in.
e.g. user does LOAD of a compiled file. COMPILED means everything is in, e.g. user does LOADDFROM a compiled file.
LOADFNS means everything in, e.g. user des LOADFROM symbolic file. COMPILED and LOADFNS are equivaeltn in that means
dont have to do any more loading when go to do a makefile but makefile NEW isnt permitted. NIL is a makefile when
coms were set up in core. T is full load of symbolic file. The check on TYPE=NIL is bcause dont want to upgrade as
result of call from makefile, i.e. no new informaton there.)
(* LOADCOMP means file was loadcomp'ed. note that the actual structure is a tree, not a list, and the above is only
an approximation. if you do a loadcomp, and then load the compiled file, the state will be left with latter, but
then loadcomp? will loadcomp again because compiled files might not contain all the declare: EVAL@COMPILE
expressions, e.g. macros, records etc. however,in most cases, loadcomp is used independently of other loading, e.g.
for compilation purposes only, so this will at least permit loadcomp? to work.)
(GO OUT))
(T (GO OUT1]
(COND
[(OR LOADTYPE (LISTP (GETTOPVAL COMS)))
(SETQ FILEPROP (/replace FILEPROP of ROOTNAME with (create FILEPROP
COMSNAME ← COMS
LOADTYPE ← LOADTYPE]
(FLG (GO ERROR))
((AND DWIMFLG (EQ ROOTNAME FULLNAME)
(SETQ ROOTNAME (MISSPELLED? ROOTNAME 70 FILELST)))
(* The EQ check is so as not to try correcting if the user has specified a version number or directory, as it is too
messy trying to take them out, and then put them back in on the corrected root name.)
(SETQ FULLNAME ROOTNAME)
(SETQ FLG T) (* so wont try to spelling correct again if file isnt
there)
(GO TOP))
(T (GO ERROR)))
OUT [AND LOADTYPE DAT (/replace FILEDATES of ROOTNAME with (LIST (create FILEDATEPAIR
FILEDATE ← DAT
DATEFILENAME ← FULLNAME]
(AND (EQ LOADTYPE T)
(/replace TOBEDUMPED of FILEPROP with NIL))
OUT1[COND
([AND (LISTP (GETTOPVAL COMS))
(NOT (FMEMB ROOTNAME (GETTOPVAL (QUOTE FILELST]
(* coms wuld not be set up on a loadccomp.)
(/SETTOPVAL (QUOTE FILELST)
(CONS ROOTNAME (GETTOPVAL (QUOTE FILELST]
(RETURN (COND
((NULL LOADTYPE) (* call from makefile.)
(CONS FULLNAME (CONS ROOTNAME FILEPROP)))
(T FILEPROP)))
ERROR
(ERROR FULLNAME "not file name." T])
(LISTFILES
[NLAMBDA FILES (* lmm "17-Aug-84 23:29")
(DECLARE (GLOBALVARS NOTLISTEDFILES FILELST)) (* LISTFILES1 is machinedependent)
(for FILE FULLNAME in (COND
(FILES (SETQ FILES (NLAMBDA.ARGS FILES)))
(T NOTLISTEDFILES))
when (COND
((SETQ FULLNAME (FINDFILE FILE))
FULLNAME)
(T (printout T FILE " not found." T)
NIL))
collect [COND
((LISTFILES1 FULLNAME)
(SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
NOTLISTEDFILES]
FULLNAME])
)
(RPAQ? FILELST )
(RPAQ? LOADEDFILELST )
(RPAQ? NOTLISTEDFILES )
(RPAQ? NOTCOMPILEDFILES )
(RPAQ? MAKEFILEFORMS )
(RPAQ? NILCOMS )
(ADDTOVAR MAKEFILEOPTIONS RC C LIST FAST CLISP CLISPIFY NIL REMAKE NEW NOCLISP CLISP% F ST STF
(REC . RC)
(BREC . RC)
(TC . C)
(BC . C)
(TCOMPL . C)
(BCOMPL . C))
(RPAQ? MAKEFILEREMAKEFLG T)
(RPAQ? CLEANUPOPTIONS (QUOTE (RC)))
(* * "scanning file coms")
(DEFINEQ
(FILEPKGCHANGES
[LAMBDA N (* lmm "22-JUL-83 13:35")
(COND
[(EQ N 0)
(PROG (TEM)
(RETURN (for X in FILEPKGTYPES when (AND (LITATOM X)
(SETQ TEM (FILEPKGCHANGES X)))
collect (CONS X TEM]
[(EQ (ARG N 1)
T)
(for X in FILEPKGTYPES when (LITATOM X) collect (CONS X (FILEPKGCHANGES X]
[(EQ N 1)
(COND
[(LISTP (ARG N 1))
(for X in (ARG N 1) when (FMEMB (CAR X)
FILEPKGTYPES)
do (/replace CHANGED of (CAR X) with (CDR X]
(T (for Y on (fetch CHANGED of (ARG N 1)) when [AND (CAR Y)
(NOT (MEMBER (CAR Y)
(CDR Y]
collect (CAR Y]
(T (/replace CHANGED of (ARG N 1) with (ARG N 2])
(GETFILEPKGTYPE
[LAMBDA (TYPE ONLY NOERROR NAME) (* lmm "28-Sep-84 11:25")
(COND
[(LISTP TYPE)
(for X in TYPE collect (OR (GETFILEPKGTYPE X ONLY NOERROR NAME)
(RETURN]
((EQ TYPE (QUOTE ?))
(AND NAME (TYPESOF NAME)))
[(AND (NEQ ONLY (QUOTE COMS))
(LITATOM TYPE)
(OR (SELECTQ TYPE
(NIL (QUOTE FNS))
(T (QUOTE VARS))
NIL)
(PROG1 (CAR (FMEMB TYPE FILEPKGTYPES)) (* If the TYPE is exactly a filepkgtype ...)
)
(PROG1 (CDR (ASSOC TYPE FILEPKGTYPES)) (* or if it is synonym'd as a filepkgtype ...)
]
[(AND (NEQ ONLY (QUOTE TYPE))
(LITATOM TYPE)
(PROG1 (CAR (FMEMB TYPE FILEPKGCOMSPLST)) (* Prefer an exact match quickly)
]
[(AND (NEQ ONLY (QUOTE COMS))
(LITATOM TYPE)
(PROG1 (AND (NEQ (NTHCHARCODE TYPE -1)
(CHARCODE S))
(GETFILEPKGTYPE (PACK* TYPE (QUOTE S))
ONLY T)) (* or maybe it only needs pluralizing)
]
[(FIXSPELL TYPE NIL (SELECTQ ONLY
(TYPE FILEPKGTYPES)
(COMS FILEPKGCOMSPLST)
(UNION FILEPKGTYPES FILEPKGCOMSPLST]
((NOT NOERROR)
(ERROR (SELECTQ ONLY
(TYPE "invalid file package type")
(COMS "unrecognized file package command")
"Bad file package type/command")
TYPE])
(MARKASCHANGED
[LAMBDA (NAME TYPE REASON) (* rmk: "24-MAR-83 23:22")
(COND
(FILEPKGFLG (SELECTQ REASON
((DEFINED CHANGED DELETED CLISP))
(NIL (* For backward compatibility)
(SETQQ REASON CHANGED))
(T (SETQQ REASON DEFINED))
(ERROR "BAD REASON" REASON))
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(for X inside (fetch WHENCHANGED of TYPE) do (APPLY* X NAME TYPE
(SELECTQ REASON
(DEFINED
(* The user hasn't updated himself)
T)
(CHANGED NIL)
REASON)))
(AND MSDATABASELST (NEQ REASON (QUOTE CLISP))
(MSMARKCHANGED NAME TYPE REASON))
(COND
((EQ TYPE (QUOTE FILES))
(MARKASCHANGED (FILECOMS NAME)
(QUOTE VARS)
REASON))
((EQ REASON (QUOTE DELETED))
(for L on (fetch CHANGED of TYPE) when (EQ (CAR L)
NAME)
do (/RPLACA L NIL)) (* unmark as changed and remove from files)
(DELFROMFILES NAME TYPE))
((OR (NEQ REASON (QUOTE CLISP))
(NULL CLISPIFYPRETTYFLG))
(* If CLISPIFYPRETTYFLG=NIL, the user doesn't want clisp on files. The fact that we just removed some clisp suggests
that he'd like to see the new version dumped. But since this doesn't guarantee that clisp won't appear
(only the functions that get dwimified are noticed), this probably isn't worth doing. It also makes the file package
virtually useless for someone with CLISPIFYPRETTYFLG=NIL working on files made by a user who has
CLISPIFYPRETTYFLG=T.)
(SETQ TYPE (push (fetch CHANGED of TYPE)
NAME))
(COND
(LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA)
TYPE)
LISPXHIST))) (* Undone by smashing with NIL, so that each call to
MARKASCHANGED can be handled independently.)
))
NAME])
(FILECOMS
[LAMBDA (FILE X) (* rmk: "19-FEB-83 13:55")
(COND
((AND (NULL FILE)
(NULL X))
(QUOTE NILCOMS))
[(AND (OR (NULL X)
(EQ X (QUOTE COMS)))
(fetch COMSNAME of (LISTP (fetch FILEPROP of FILE]
(T (PACK* (NAMEFIELD FILE)
(OR X (QUOTE COMS])
(WHEREIS
(LAMBDA (NAME TYPE FILES FN) (* JonL "24-Jul-84 19:47")
(COND
((EQ NAME T) (* T as a NAME has a special meaning to INFILECOMS? so
don't pass through.)
NIL)
(FN (* TYPE is coerced by the innards of INFILECOMS?)
(for FILE in (OR (LISTP FILES)
FILELST)
when (INFILECOMS? NAME TYPE (FILECOMS FILE)) do (APPLY* FN NAME FILE)))
(T (SUBSET (OR (LISTP FILES)
FILELST)
(FUNCTION (LAMBDA (FILE)
(INFILECOMS? NAME TYPE (FILECOMS FILE)))))))))
(SMASHFILECOMS
[LAMBDA (FILE) (* rmk: "19-FEB-83 22:15")
(for X in (FILECOMSLST FILE (QUOTE FILEVARS)) when (LITATOM X) do (SETTOPVAL X (QUOTE NOBIND)))
FILE])
(FILEFNSLST
[LAMBDA (FILE) (* lmm " 7-SEP-78 18:47")
(FILECOMSLST FILE (QUOTE FNS])
(FILECOMSLST
(LAMBDA (FILE TYPE FLG) (* JonL "24-Jul-84 19:48")
(* TYPE is coerced in the innards of INFILECOMS?)
(COND
((EQ FLG (QUOTE UPDATE))
(CDR (INFILECOMS? NIL TYPE (FILECOMS FILE)
FLG)))
(T (INFILECOMS? NIL TYPE (FILECOMS FILE)
FLG)))))
(UPDATEFILES
[LAMBDA (PRLST FLST) (* rmk: "19-FEB-83 14:27")
(* PRLST may be the value of FILEPKGCHANGES before some
operation (e.g. LOAD, LOADFNS) involving the files in
FLST began.)
(for TYPE CHANGED in FILEPKGTYPES when (SETQ CHANGED (fetch CHANGED of TYPE))
do (COND
((NULL (SETQ CHANGED (FILEPKGCHANGES TYPE))) (* FILEPKGCHANGES eliminates duplicates)
(/replace CHANGED of TYPE with NIL))
(T (for FILE FOUND FILEPROP COMS LST TYPEDPROP PCHANGES (PREVITEMS ←(CDR (ASSOC TYPE
PRLST)))
in FILELST
first (SETQ LST (INFILECOMS? CHANGED TYPE (QUOTE NILCOMS)
(QUOTE UPDATE)))
(* First check NIL=Nowhere. LST:1 contains variables whose values are on the file literally.
These are "found" but not marked. LST::1 contains all other items.)
(SETQ FOUND (NCONC (CAR LST)
(CDR LST)
FOUND))
do (SETQ PCHANGES (COND
((FMEMB (fetch DATEFILENAME of (CAR (fetch FILEDATES of FILE)))
FLST)
(* PREVITEMS are changed items that were previously on the changed list, before PRLST was computed as this
LOAD/LOADFNS began. Thus, by this intersection we only worry about items that were previously changed;
any items that were only changed during this operation are ignored.)
(INTERSECTION CHANGED PREVITEMS))
(T CHANGED)))
[COND
([AND PCHANGES [SETQ COMS (fetch COMSNAME
of (SETQ FILEPROP (LISTP (fetch FILEPROP
of FILE]
(SETQ LST (INFILECOMS? PCHANGES TYPE COMS (QUOTE UPDATE]
(* LST:1 is a list of the times that literally appear on this file, LST::1 is a list of those whose literal values
are not in the coms)
[COND
((CDR LST) (* CDR items must be distributed)
[COND
((NULL (fetch TOBEDUMPED of FILEPROP))
(* Only finagle global lists the first time an item is
added to PROP, when PROP::1 goes from NIL to non-NIL)
[/SETTOPVAL (QUOTE NOTLISTEDFILES)
(REMOVE FILE (GETTOPVAL (QUOTE NOTLISTEDFILES]
(/SETTOPVAL (QUOTE NOTCOMPILEDFILES)
(REMOVE FILE (GETTOPVAL (QUOTE NOTCOMPILEDFILES]
(* Get the (possibly new) TYPE item list to smash)
[COND
[(SETQ TYPEDPROP (ASSOC TYPE (fetch TOBEDUMPED of FILEPROP]
(T (/NCONC1 FILEPROP (SETQ TYPEDPROP (CONS TYPE]
(* Now distribute items to the file property)
(for Y in (CDR LST) unless (MEMBER Y (CDR TYPEDPROP))
do (/NCONC1 TYPEDPROP Y]
(SETQ FOUND (NCONC (CAR LST)
(CDR LST)
FOUND]
finally (/replace CHANGED of TYPE with (LDIFFERENCE CHANGED FOUND])
(INFILECOMS?
[LAMBDA (NAME TYPE COMS ONFILETYPE) (* rmk: " 3-JAN-82 22:56")
(* Returns T if NAME is 'CONTAINED' in COMS. If NAME is NIL, then value is a list of all of the functions
contained in COMS. If NAME=T, value is T if there are any elements of type TYPE, otherwise NIL
(this feature is used for deciding whether or not (and how) to compile files.) Called by FILEFNSLST
(which is used by BRECOMPILE) and by NEWFILE1. while elements are the subset of NAME which are on the file in
other case)
(* if ONFILETYPE is UPDATE, then NAME is a list of elements, and INFILECOMS? returns the dotted pair of
(literals . elements) where literals are those which are "literally" on the file (e.g. (VARS
(X 3))) -
if ONEFILETYPE is EDIT, then NAME is interpreted as for ONFILETYPE=NIL, but only those elements which are not on
the file literally and which are not subparts of other types are returned)
(PROG (VAL LITERALS ORIGFLG)
(SETQ TYPE (GETFILEPKGTYPE TYPE))
(SELECTQ ONFILETYPE
(EDIT (SELECTQ TYPE
(FILEVARS (RETURN))
NIL))
NIL)
[COND
((LITATOM COMS)
(SELECTQ TYPE
((VARS FILEVARS) (* the COMS of a file are also on it)
(INFILECOMSVAL COMS))
NIL)
(SETQ COMS (GETATOMVAL COMS]
(INFILECOMS COMS)
(SETQ VAL (DREVERSE VAL))
(RETURN (COND
((EQ ONFILETYPE (QUOTE UPDATE))
(CONS LITERALS VAL))
(T VAL])
(INFILECOMTAIL
[LAMBDA (COM FLG) (* lmm "27-Aug-84 21:42")
[SETQ COM (COND
((EQ (CADR COM)
(QUOTE *))
(COND
[(LITATOM (CADDR COM))
(LISTP (GETATOMVAL (CADDR COM]
(T [RESETVARS (DWIMLOADFNSFLG)
(NLSETQ (SETQ COM (EVAL (CADDR COM]
COM)))
(T (CDR COM]
(if (NOT FLG)
then [SUBSET COM (FUNCTION (LAMBDA (X)
(OR (NLISTP X)
(NEQ (CAR X)
COMMENTFLG]
else COM])
(INFILECOMS
[LAMBDA (COMS) (* rmk: "19-FEB-83 22:17")
(for X in COMS do (INFILECOM X])
(INFILECOM
[LAMBDA (COM) (* lmm "27-Aug-84 21:43")
(COND
[(NLISTP COM)
(COND
((EQ TYPE (QUOTE VARS))
(INFILECOMSVAL COM]
((EQ (CAR COM)
COMMENTFLG) (* must be special case'd first so that
(* * values) doesn't make it look like "values" is a
variable -)
(* don't know why I should bother, but someone might
want to know all of the comments on a file???)
(COND
((EQ TYPE COMMENTFLG)
(INFILECOMSVAL COM T)))
NIL)
(T (PROG ((COMNAME (CAR COM))
(TAIL (CDR COM))
CFN TEM)
(COND
[[COND
((SETQ CFN (fetch (FILEPKGCOM CONTENTS) of COMNAME))
(SETQ TEM (APPLY* CFN COM (COND
((AND (NULL ONFILETYPE)
(LISTP NAME))
(* call from WHEREIS of a name which is a list)
(LIST NAME))
(T NAME))
TYPE ONFILETYPE)))
((SETQ CFN (fetch (FILEPKGCOM PRETTYTYPE) of COMNAME))
(* for compatability)
(SETQ TEM (APPLY* CFN COM TYPE NAME]
(COND
[(NLISTP TEM)
(COND
((EQ TEM T)
(COND
((OR (EQ NAME T)
(NULL ONFILETYPE))
(RETFROM (QUOTE INFILECOMS?)
T]
(T (INFILECOMSVALS TEM]
((LISTP TAIL)
(* this SELECTQ handles the "exceptional cases" for the built in types. There is an explicit RETURN in the SELECTQ
clause if the default is handled)
(SELECTQ COMNAME
((PROP IFPROP)
(SETQ TAIL (CDR TAIL)))
NIL)
[COND
((EQ (CAR TAIL)
(QUOTE *))
(COND
((LITATOM (CADR TAIL))
(SELECTQ TYPE
((VARS FILEVARS)
(INFILECOMSVAL (CADR TAIL)))
NIL))
((AND (LISTP (CADR TAIL))
(EQ ONFILETYPE (QUOTE UPDATE))
(EQ TYPE (QUOTE VARS))
(EQ (CAADR TAIL)
(QUOTE PROGN))
(FMEMB (CAR (LAST (CADR TAIL)))
NAME))
(SETQ VAL (CONS (CADR TAIL)
VAL]
(SELECTQ COMNAME
((COMS EXPORT)
(INFILECOMS (INFILECOMTAIL COM)))
[DECLARE: (* skip over DECLARE: tags)
(RETURN (IFCDECLARE (INFILECOMTAIL COM)
(EQ TYPE (QUOTE DECLARE:]
[ORIGINAL (* dont expand macros)
(PROG ((ORIGFLG T))
(INFILECOMS (INFILECOMTAIL COM]
((PROP IFPROP) (* this currently does not handle "pseudo-types" of
PROPNAMES)
(SELECTQ TYPE
(PROPS (IFCPROPSCAN (INFILECOMTAIL (CDR COM))
(CADR COM)))
(MACROS (INFILECOMSMACRO (INFILECOMTAIL (CDR COM))
(CADR COM)))
NIL))
(PROPS (RETURN (IFCPROPS COM)))
(MACROS (RETURN (SELECTQ TYPE
(PROPS (IFCPROPSCAN (INFILECOMTAIL COM)
MACROPROPS))
(MACROS (INFILECOMSVALS (INFILECOMTAIL COM)))
NIL)))
(ALISTS (* sigh. This should probably also "coerce" when asking
for LISPXMACROS, etc.)
(RETURN (SELECTQ TYPE
(ALISTS (INFILEPAIRS (INFILECOMTAIL COM)))
NIL)))
[(ADVICE ADVISE) (* this code turns (ADVISE (FOO IN FOOBLOCK)) to
FOO-IN-FOOBLOCK)
(RETURN (COND
((OR (EQ TYPE (QUOTE ADVICE))
(EQ TYPE (QUOTE ADVISE)))
(for X in (INFILECOMTAIL COM) do (INFILECOMSVALS
(PACK-IN- X]
[P (RETURN (SELECTQ TYPE
((EXPRESSIONS P)
(INFILECOMSVALS (INFILECOMTAIL COM T)
T))
(COND
((NULL ONFILETYPE)
(* for WHEREIS and FILECOMSLST)
(SELECTQ TYPE
(I.S.OPRS (IFCEXPRTYPE COM (QUOTE
I.S.OPR)))
(TEMPLATES (IFCEXPRTYPE COM
(QUOTE
SETTEMPLATE)))
(ADVICE (IFCEXPRTYPE COM (QUOTE ADVISE)))
NIL]
[(ADDVARS APPENDVARS)
(SELECTQ TYPE
[VARS (RETURN (AND (NULL ONFILETYPE)
(for X in (INFILECOMTAIL COM T)
do (INFILECOMSVAL (CAR X)
T]
[ALISTS (RETURN (for X in (INFILECOMTAIL COM)
when (EQMEMB (QUOTE ALIST)
(GETPROP (CAR X)
(QUOTE VARTYPE)))
do (for Z in (CDR X)
do (INFILECOMSVAL
(LIST (CAR X)
(CAR Z))
T]
(OR (EQ TYPE COMNAME)
(RETURN]
[(VARS INITVARS FILEVARS UGLYVARS HORRIBLEVARS CONSTANTS ARRAY)
(RETURN (COND
((EQ TYPE (QUOTE EXPRESSIONS))
(for X in (INFILECOMTAIL COM) when (LISTP X)
do (INFILECOMSVAL (CONS (QUOTE SETQ)
X)
T)))
((OR (EQ TYPE (QUOTE VARS))
(EQ TYPE COMNAME))
(* either want all VARS, or else want all FILEVARS and
this is a FILEVARS command)
(for X in (INFILECOMTAIL COM)
do (COND
((LISTP X)
(INFILECOMSVAL (CAR X)
T))
(T (INFILECOMSVAL X (EQ COMNAME (QUOTE INITVARS]
[DEFS (RETURN (for X in (INFILECOMTAIL COM) when (EQ TYPE (CAR X))
do (INFILECOMSVALS (CDR X]
(FILES (RETURN))
NIL)
(* * Exceptional cases now handled. If TYPE matches (CAR COM) then scan the tail as usual.
Else expand the com's MACRO, if it has one, unless there was a CONTENTS function)
(COND
((EQ COMNAME TYPE)
(INFILECOMSVALS (INFILECOMTAIL COM)))
((AND (OR (NULL CFN)
(AND (EQ CFN T)
(NULL ONFILETYPE)))
(NULL ORIGFLG)
(SETQ TEM (fetch (FILEPKGCOM MACRO) of COMNAME)))
(INFILECOMS (SUBPAIR (CAR TEM)
(INFILECOMTAIL COM)
(CDR TEM])
(INFILECOMSVALS
[LAMBDA (X FLG) (* rmk: "19-FEB-83 22:22")
(for Y in X do (INFILECOMSVAL Y FLG])
(INFILECOMSVAL
[LAMBDA (X FLG) (* bvm: " 2-Dec-83 14:58")
(COND
[(EQ ONFILETYPE (QUOTE UPDATE))
(AND (OR (NULL NAME)
(MEMBER X NAME))
(COND
(FLG (SETQ LITERALS (CONS X LITERALS)))
(T (SETQ VAL (CONS X VAL]
((AND (EQ ONFILETYPE (QUOTE EDIT))
FLG) (* literals should not be edited as they are on the
fileCOMS)
NIL)
([OR (EQ NAME T)
(COND
((LITATOM NAME)
(EQ NAME X))
(T (EQUAL NAME X]
(RETFROM (FUNCTION INFILECOMS?)
T))
((NULL NAME)
(SETQ VAL (CONS X VAL])
(INFILECOMSPROP
[LAMBDA (AT PROP) (* lmm "25-SEP-81 17:15")
(COND
[(EQ ONFILETYPE (QUOTE UPDATE))
(AND [OR (NULL NAME)
(find X in NAME suchthat (AND (EQ (CAR X)
AT)
(EQ (CADR X)
PROP]
(SETQ VAL (CONS (LIST AT PROP)
VAL]
((OR (EQ NAME T)
(AND (EQ (CAR NAME)
AT)
(EQ (CADR NAME)
PROP)))
(RETFROM (FUNCTION INFILECOMS?)
T))
((NULL NAME)
(SETQ VAL (CONS (LIST AT PROP)
VAL])
(IFCPROPS
[LAMBDA (COM) (* bvm: " 2-Dec-83 14:24")
(* * Examine a PROPS com for objects of specified TYPE)
(SELECTQ TYPE
(PROPS (* the PROPS command can actually take
(PROPNAME at1 at2 ...))
(INFILEPAIRS (INFILECOMTAIL COM)))
[PROP (* return the atoms which have any properties at all)
(for PAIR in (INFILECOMTAIL COM) do (for ATNAME inside (CAR PAIR)
do (INFILECOMSVAL ATNAME]
[MACROS (* only MACRO properties)
(for PAIR in (INFILECOMTAIL COM) do (INFILECOMSMACRO (CAR PAIR)
(CDR PAIR]
NIL])
(IFCEXPRTYPE
[LAMBDA (COM FN) (* bvm: " 2-Dec-83 14:30")
(* * Recognizes expressions in COM (a P com) that are calls to function FN)
(for SUBCOM in (INFILECOMTAIL COM) when (AND (EQ (CAR SUBCOM)
FN)
(EQ (CAR (LISTP (CADR SUBCOM)))
(QUOTE QUOTE)))
do (INFILECOMSVAL [COND
[(EQ FN (QUOTE ADVISE))
(PACK-IN- (CADR (CADR COM]
(T (CADR (CADR SUBCOM]
T])
(IFCPROPSCAN
[LAMBDA (ATOMS PROPNAMES) (* bvm: " 2-Dec-83 15:10")
(* * Recognizes members of ATOMS as being names (atom prop) of type PROPS for any prop in PROPNAMES)
(for AT in ATOMS unless [COND
[(EQ ONFILETYPE (QUOTE UPDATE))
(COND
(NAME (NOT (ASSOC AT NAME]
((LISTP NAME)
(NEQ AT (CAR NAME]
do (COND
((EQ PROPNAMES (QUOTE ALL))
(for PROP in (GETPROPLIST AT) by (CDDR PROP) when (NOT (FMEMB PROP SYSPROPS))
collect (INFILECOMSPROP AT PROP)))
(T (for PROP inside PROPNAMES do (INFILECOMSPROP AT PROP])
(IFCDECLARE
[LAMBDA (TAIL WANTDECLARE) (* lmm "19-Aug-84 14:17")
(PROG ((TAIL TAIL))
LP (COND
((LISTP TAIL)
[SELECTQ (CAR TAIL)
((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN)
[AND WANTDECLARE (INFILECOMSVAL (LIST (CAR TAIL)
(CADR TAIL]
(SETQ TAIL (CDR TAIL)))
(COMPILERVARS (RETURN))
(COND
[(FMEMB (CAR TAIL)
DECLARETAGSLST)
(COND
(WANTDECLARE (INFILECOMSVAL (CAR TAIL]
(T (INFILECOM (CAR TAIL]
(SETQ TAIL (CDR TAIL))
(GO LP])
(INFILEPAIRS
[LAMBDA (LST) (* lmm " 4-DEC-78 09:51")
(for LL in LST do (for X inside (CAR LL) do (for Y inside (CDR LL)
do (INFILECOMSVAL (LIST X Y])
(INFILECOMSMACRO
[LAMBDA (ATS PROPS) (* lmm "28-SEP-78 18:35")
(* this function is used, given a PROP or PROPS command, to tell which MACROS are contained in it.
-
Normally (e.g. for WHEREIS and FILECOMSLST) it wants to return if the command contains any of the MACROPROPS for the
given atom. However, for UPDATE, it only wants a "hit" if the command contains ALL of the macro properties)
(for AT inside ATS do (AND [OR (NEQ ONFILETYPE (QUOTE UPDATE))
(EVERY (PROPNAMES AT)
(FUNCTION (LAMBDA (X)
(OR (NOT (FMEMB X MACROPROPS))
(EQMEMB X PROPS]
[SOME MACROPROPS (FUNCTION (LAMBDA (PROP)
(EQMEMB PROP PROPS]
(INFILECOMSVAL AT])
)
(* * "adding to a file")
(DEFINEQ
(FILES?
[LAMBDA NIL (* rmk: "19-FEB-83 22:26")
(UPDATEFILES)
(PROG (FILES)
(COND
((SETQ FILES (for FL in FILELST when (fetch TOBEDUMPED
of (LISTP (fetch FILEPROP of FL)))
collect FL))
(MAPRINT FILES T NIL (QUOTE "...to be dumped.
")
(QUOTE ,)
NIL T)))
(for TYPE FLG in FILEPKGTYPES when (FILES?1 TYPE (AND FILES " plus ")
(AND (NULL FILES)
"...to be dumped."))
do (SETQ FLG T) finally (AND FLG (ADDTOFILES?)))
(AND (SETQ FILES NOTLISTEDFILES)
(MAPRINT FILES T NIL (QUOTE "...to be listed.
")
(QUOTE ,)
NIL T))
(AND (SETQ FILES NOTCOMPILEDFILES)
(MAPRINT FILES T NIL (QUOTE "...to be compiled.
")
(QUOTE ,)
NIL T))
(RETURN])
(FILES?1
[LAMBDA (TYPE X Y) (* rmk: "22-MAY-81 13:51")
(PROG (STR LST)
(COND
([NOT (AND (LITATOM TYPE)
(SETQ STR (fetch DESCRIPTION of TYPE))
(LISTP (SETQ LST (fetch CHANGED of TYPE]
(RETURN NIL)))
(AND X (LISPXPRIN1 X T))
(LISPXPRIN1 (QUOTE "the ")
T)
(LISPXPRIN1 STR T)
(COND
(NIL (IGREATERP (LENGTH LST)
6)
(LISPXPRIN1 (QUOTE " on ")
T)
(LISPXPRIN2 (CAR TYPE)
T T))
(T (MAPRINT LST T (QUOTE ": ")
NIL
(QUOTE ,)
(FUNCTION [LAMBDA (X)
(COND
((NOT (ILESSP (IPLUS (POSITION T)
(NCHARS X T T)
3)
(LINELENGTH NIL T)))
(LISPXTERPRI T)
(LISPXPRIN1 " " T)))
(LISPXPRIN2 X T T])
T)))
(AND Y (LISPXPRIN1 Y T))
(LISPXTERPRI T)
(RETURN T])
(ADDTOFILES?
[LAMBDA (NOASKSTR) (* rmk: " 9-JUN-82 22:57")
(* ask user about all of the things that need to be
dumped, and distribute them to the files that he says)
(ERSETQ
(PROG [BUFS (VARSCHANGES (fetch CHANGED of (QUOTE VARS]
(* Save VARS list at the beginning, so that changes that might occur from adding things to files
(e.g. changing NILCOMS) will not be processed differently depending on the order of elements in FILEPKGTYPES)
[COND
(NOASKSTR (PRIN1 NOASKSTR T))
(T (DOBE)
(SETQ BUFS (READP T))
(SELECTQ (ASKUSER DWIMWAIT (QUOTE N)
(QUOTE ("want to say where the above go"))
(QUOTE ((Y "es
")
(N "o
")
(%] "Nowhere
" EXPLAINSTRING "] - nowhere, all items will be marked as dummy
" NOECHOFLG T)))
T)
(N (RETURN))
(%] (for TYPE in FILEPKGTYPES do (for NAME in (fetch CHANGED of TYPE)
do (ADDTOFILE NAME TYPE NIL)))
(RETURN))
NIL) (* if there was type-ahead BEFORE the askuser, then
don't allow it now)
(COND
(BUFS (SETQ BUFS (COND
((READP T)
(LINBUF)
(SYSBUF)
(SETQ BUFS (CLBUFS NIL T READBUF]
[for TYPE STR LST in FILEPKGTYPES when [AND (SETQ STR (fetch DESCRIPTION of TYPE))
(LISTP (SETQ LST
(COND
((EQ TYPE (QUOTE VARS))
VARSCHANGES)
(T (fetch CHANGED of TYPE]
do
(printout T "(" STR ")" T)
(for NAME TEM FILE in LST when NAME
do
(PROG NIL
LP (PRIN2 NAME T)
(SPACES 2 T) (* if user typed ahead before entering addtofiles?? then
dont allow typeahead here, because it will justgobble
his earlier typeahead.)
(SELECTQ (SETQ TEM (ASKUSER NIL NIL NIL ADDTOFILEKEYLST T))
(%[ (ERSETQ (PROGN (SHOWDEF NAME TYPE T)
(* the DOBE is so that if the user control-E's after the printout is done but before it appears on the screen that
the control-E will merely clear output buffer)
(DOBE)))
(GO LP))
(%] (SETQ FILE))
(% (* space. means no action)
(RETURN))
(%
(PRINT (OR (SETQ FILE LASTFILE)
(QUOTE Nowhere))
T))
(SETQ FILE TEM))
(OR
(ERSETQ (PROG (TEM COMSNAME PLACE LISTNAME NEAR)
(SETQ PLACE (WHATIS FILE NIL TYPE))
[COND
((LITATOM PLACE)
(* file name)
(SETQ FILE PLACE)
(OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
NAME TYPE NEAR LISTNAME)
(ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
(for F in (fetch WHENFILED of TYPE)
do (APPLY* F NAME TYPE FILE))
(* This isn't factored to the end, cause ADDTOLISTNAME
might have to deal with a set of old elements on the
listname.)
)
((EQ (CAR PLACE)
(QUOTE Near:))
(SETQ NEAR (CADR PLACE))
(COND
([SOME FILELST (FUNCTION (LAMBDA (FL)
(ADDTOCOMS (FILECOMS (SETQ FILE FL))
NAME TYPE NEAR LISTNAME]
(PRINT (LIST (QUOTE on)
FILE)
T T))
(T (PRINT (LIST (CADR PLACE)
(QUOTE not)
(QUOTE found))
T T)
(ERROR!)))
(for F in (fetch WHENFILED of TYPE)
do (APPLY* F NAME TYPE FILE)))
([OR [UNDONLSETQ
(PROGN (SAVESET (SETQ LISTNAME (CAR PLACE))
(MERGEINSERT NAME
(LISTP (GETTOPVAL
LISTNAME))
T)
T
(QUOTE NOPRINT))
(OR (SETQ FILE
(CAR (WHEREIS NAME TYPE FILELST)))
(ERROR!]
(SOME FILELST (FUNCTION (LAMBDA (X)
(ADDTOCOMS (FILECOMS (SETQ FILE X))
NAME TYPE NEAR LISTNAME]
(PRIN1 " value is filed on " T)
(PRINT FILE T T)
(for F in (fetch WHENFILED of TYPE)
do (APPLY* F NAME TYPE FILE))
(* Only have to notice the single new item here, unlike the case in ADDNEWCOM below, cause other items on the list
already belong and were previously noticed)
)
(T (PRIN1 " put list " T)
(PRIN2 (CAR PLACE)
T T)
(SETQ FILE
(WHATIS (ASKUSER NIL NIL " on file: "
[QUOTE (("" "" EXPLAINSTRING
"a file name"
KEYLST
(]
T)
(QUOTE FILE)))
(SAVESET (CAR PLACE)
(MERGEINSERT NAME (LISTP (GETTOPVAL
(CAR PLACE)))
T)
T
(QUOTE NOPRINT))
(* Add new item before new command, so that user's new
command function can inspect
(CAR PLACE) and see all the items involved.)
(ADDNEWCOM (FILECOMS FILE)
NAME TYPE (CAR PLACE)
FILE)
(for F in (fetch WHENFILED of TYPE)
do (for I in (GETTOPVAL (CAR PLACE))
do (APPLY* F I TYPE FILE]
(AND FILE (ADDFILE FILE))
(SETQ LASTFILE PLACE)))
(GO LP]
(AND BUFS (BKBUFS BUFS))
(UPDATEFILES])
(ADDTOFILE
[LAMBDA (NAME TYPE FILE NEAR LISTNAME) (* rmk: " 3-JAN-82 09:26")
(* adds NAME to the file FILE)
(PROG (TEM COMSNAME)
[SETQ TYPE (OR (GETFILEPKGTYPE TYPE NIL T)
(COND
((FMEMB TYPE FILELST)
(GETFILEPKGTYPE (swap TYPE FILE)))
(T (GETFILEPKGTYPE TYPE]
(SETQ FILE (WHATIS FILE (QUOTE FILE)))
(OR (ADDTOCOMS (SETQ COMSNAME (FILECOMS FILE))
NAME TYPE NEAR LISTNAME)
(ADDNEWCOM COMSNAME NAME TYPE NIL FILE))
(for F in (fetch WHENFILED of TYPE) do (APPLY* F NAME TYPE FILE))
(AND FILE (ADDFILE FILE))
(RETURN FILE])
(WHATIS
[LAMBDA (USERINPUT ONLY) (* lmm "27-Aug-84 20:55")
(* decides whether USERINPUT is a file or a list name -
if ONLY is nil, means either a listname or a filename is accepatble; if ONLY is LIST then only a listname is
acceptable and if ONLY is FILE then only a file name is acceptable)
(PROG (TEM UCASE)
(RETURN (COND
((NULL USERINPUT) (* nowhere)
NIL)
[(LISTP USERINPUT)
(COND
(ONLY (ERROR!))
(T (SELECTQ (CAR USERINPUT)
((@ Near:)
(CONS (QUOTE Near:)
(CDR USERINPUT)))
(WHATIS (CAR USERINPUT)
(QUOTE LIST]
([AND (NEQ ONLY (QUOTE LIST))
(OR (FMEMB (SETQ UCASE (U-CASE USERINPUT))
FILELST)
(LISTP (GETTOPVAL (FILECOMS UCASE]
UCASE)
((AND (NEQ ONLY (QUOTE LIST))
(SETQ TEM (MISSPELLED? USERINPUT NIL FILELST)))
TEM)
((AND (NEQ ONLY (QUOTE FILE))
(LISTP (GETTOPVAL USERINPUT)))
(LIST USERINPUT))
((AND (NEQ ONLY (QUOTE LIST))
(EQ (ASKUSER NIL NIL (LIST "create new file" UCASE)
NIL T)
(QUOTE Y)))
UCASE)
((AND (NEQ ONLY (QUOTE FILE))
(EQ (ASKUSER NIL NIL (LIST "create new list" USERINPUT)
NIL T)
(QUOTE Y)))
(LIST USERINPUT))
(T (* none of above)
(ERROR!])
(ADDTOCOMS
[LAMBDA (COMS NAME TYPE NEAR LISTNAME) (* rmk: "10-JUN-82 22:53"
)
(* try to insert NAME of type TYPE command list COMS
(either a coms name, or a just a list of coms);
return NIL if unsuccessful. If LISTNAME is given,
then only insert by adding to LISTNAME %.
If NEAR is given, only insert near it)
(COND
((NULL COMS)
NIL)
[(LITATOM COMS)
(* given a name of a command;
rebind COMSNAME to current variable and try to add
to its value)
(OR [PROG ((COMSNAME COMS))
(RETURN (ADDTOCOMS (LISTP (GETTOPVAL COMSNAME))
NAME TYPE NEAR
(AND (NEQ COMS LISTNAME)
LISTNAME]
(AND (EQ COMS LISTNAME)
(ADDNEWCOM COMS NAME TYPE]
(T (SETQ TYPE (GETFILEPKGTYPE TYPE))
(for TAIL on COMS do (COND
[(LISTP (CAR TAIL))
(COND
((ADDTOCOM (CAR TAIL)
NAME TYPE NEAR LISTNAME)
(RETURN T]
(T (SELECTQ (CAR TAIL)
((EVAL@LOADWHEN
EVAL@COMPILEWHEN
COPYWHEN)
(SETQ TAIL (CDR TAIL)))
NIL])
(ADDTOCOM
[LAMBDA (COM NAME TYPE NEAR LISTNAME) (* rmk: "10-JUN-82 23:09"
) (* tries to insert NAME
into the prettycom COM;
returns NIL if
unsuccessful)
(PROG (TEM)
(COND
([AND NEAR (NOT (INFILECOMS? NEAR TYPE (LIST COM]
(RETURN)))
[COND
((SETQ TEM (fetch ADD of (CAR COM)))
(RETURN (COND
((OR (NULL LISTNAME)
(INFILECOMS? LISTNAME (QUOTE FILEVARS)
(LIST COM)))
(AND (SETQ TEM
(APPLY* TEM COM NAME TYPE NEAR))
(MARKASCHANGED COMSNAME (QUOTE VARS)))
TEM]
(RETURN
(SELECTQ
(CAR COM)
[FNS
(AND
(EQ TYPE (QUOTE FNS))
(OR [AND (NOT LISTNAME)
(NOT NEAR)
(NOT (FMEMB NAME (CDR COM)))
MSDATABASELST
(for X (CALLERS ←(GETRELATION NAME
(QUOTE CALL)
T))
(CALLEES ←(GETRELATION NAME
(QUOTE CALL)))
on (CDR COM) first (OR CALLERS CALLEES
(RETURN))
do
(* If there is no particular specification, try
adding it before its callees or after its callers.)
(COND
((FMEMB (CAR X)
CALLEES)
(/ATTACH NAME X)
(RETURN T))
((FMEMB (CAR X)
CALLERS)
(/RPLACD X (CONS NAME
(CDR X)))
(RETURN T]
(ADDTOCOM1 COM NAME NEAR LISTNAME]
[(VARS INITVARS)
(COND
((OR (EQ (CAR COM)
(QUOTE VARS))
NEAR LISTNAME) (* Don't stick on
INITVARS unless NEAR or
LISTNAME says we
should.)
(SELECTQ TYPE
[EXPRESSIONS (COND
((EQ (CAR NAME)
(QUOTE SETQ))
(ADDTOCOM1 COM
(CDR NAME)
NEAR LISTNAME]
(VARS (ADDTOCOM1 COM NAME NEAR LISTNAME))
NIL]
(COMS (ADDTOCOMS (COND
[(EQ (CADR COM)
(QUOTE *))
(COND
((LITATOM (CADDR COM))
(CADDR COM))
(T (RETURN]
(T (CDR COM)))
NAME TYPE NEAR LISTNAME))
(DECLARE: (AND (OR LISTNAME NEAR)
(ADDTOCOMS (COND
[(EQ (CADR COM)
(QUOTE *))
(COND
((LITATOM (CADDR COM))
(CADDR COM))
(T (RETURN]
(T (CDR COM)))
NAME TYPE NEAR LISTNAME)))
((ADVISE ADVICE)
(AND (EQ TYPE (QUOTE ADVICE))
(ADDTOCOM1 COM NAME NEAR LISTNAME)))
((PROP IFPROP)
(SELECTQ
TYPE
(PROPS (COND
((EQ (CADR COM)
(CADR NAME))
(ADDTOCOM1 (CDR COM)
(CAR NAME)
NEAR LISTNAME))
((AND (EQ (CAR NAME)
(CADDR COM))
(NULL (CDDDR COM)))
[/RPLACA (CDR COM)
(UNION (MKLIST (CDR NAME))
(MKLIST (CADR COM]
(MARKASCHANGED COMSNAME (QUOTE VARS))
T)))
[MACROS (COND
([AND (for PROP inside (CADR COM)
always (EQMEMB PROP MACROPROPS))
(for PROP in MACROPROPS
always (OR (EQMEMB PROP
(CADR COM))
(NOT (GETPROP NAME PROP]
(* every property in the command is a macro prop
and, either this is an IFPROP or else the MACROS are
changed)
(ADDTOCOM1 (CDR COM)
NAME NEAR LISTNAME]
NIL))
((PROPS ALISTS)
(AND
(EQ TYPE (CAR COM))
(ADDTOCOM1
COM
(/NCONC1
(OR
[ASSOC
(CAR NAME)
(COND
[(EQ (CADR COM)
(QUOTE *))
(COND
[(LITATOM (CADDR COM))
(AND (OR (NULL LISTNAME)
(EQ (CADDR COM)
LISTNAME))
(GETTOPVAL (CADDR COM]
(T (RETURN]
(T (CDR COM]
(LIST (CAR NAME)))
(CADR NAME))
NEAR LISTNAME)))
[P (COND
((AND (EQ TYPE (QUOTE EXPRESSIONS))
(NEQ (CAR NAME)
(QUOTE SETQ)))
(ADDTOCOM1 COM NAME NEAR LISTNAME]
(AND (EQ (CAR COM)
TYPE)
(ADDTOCOM1 COM NAME NEAR LISTNAME])
(ADDTOCOM1
[LAMBDA (COM NAME NEAR LISTNAME) (* rmk: " 3-JAN-82 22:53")
(COND
[(EQ (CADR COM)
(QUOTE *)) (* add to list name)
(AND [COND
(LISTNAME (EQ (CADDR COM)
LISTNAME))
(T (LITATOM (CADDR COM]
(SAVESET (CADDR COM)
[PROGN [SETQ COM (LISTP (GETTOPVAL (CADDR COM]
(COND
((AND NEAR (SETQ NEAR (MEMBER NEAR COM)))
(/RPLACD NEAR (CONS NAME (CDR NEAR)))
COM)
(T (MERGEINSERT NAME COM T]
T
(QUOTE NOPRINT]
((NULL LISTNAME) (* add to standard com)
[AND (NOT (MEMBER NAME (CDR COM)))
(COND
[(SETQ NEAR (MEMBER NEAR COM))
(/RPLACD NEAR (CONS NAME (CDR NEAR]
(T (/RPLACD COM (MERGEINSERT NAME (CDR COM]
(MARKASCHANGED COMSNAME (QUOTE VARS))
T])
(ADDNEWCOM
[LAMBDA (COMSNAME NAME TYPE LISTNAME FILE) (* rmk: " 3-JAN-82 22:53")
(* Adds to COMSNAME a new command that will dump NAME as a TYPE on FILE. -
if LISTNAME is given, then use it as the listname)
(PROG (NEWCOM OLDCOM TAIL)
(SETQ NEWCOM (MAKENEWCOM NAME TYPE LISTNAME FILE))
[COND
((NLISTP (SETQ TAIL (GETTOPVAL COMSNAME)))
(RETURN (SAVESET COMSNAME (LIST NEWCOM)
T
(QUOTE NOPRINT]
LP [COND
((OR (NLISTP (SETQ OLDCOM (CAR TAIL)))
(SELECTQ (CAR OLDCOM)
((LOCALVARS SPECVARS BLOCKS)
T)
(DECLARE: (FMEMB (QUOTE COMPILERVARS)
(CDR OLDCOM)))
NIL))
(/ATTACH NEWCOM TAIL))
((LISTP (CDR TAIL))
(SETQ TAIL (CDR TAIL))
(GO LP))
(T (/RPLACD TAIL (LIST NEWCOM]
(MARKASCHANGED COMSNAME (QUOTE VARS])
(MAKENEWCOM
(LAMBDA (NAME TYPE LISTNAME FILE) (* JonL "24-Jul-84 19:56")
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(PROG (TEM)
(* the user function MUST (a) check if FILE = T and not do anything destructive (since this is only for showdef)
and (b) if LISTNAME is given, then use it rather than generating a different listname)
(AND (LISTP NAME)
(SETQ NAME (COPY NAME)))
(RETURN (OR (AND (SETQ TEM (fetch NEWCOM of TYPE))
(APPLY* TEM NAME TYPE LISTNAME FILE))
(SELECTQ TYPE
(PROPS (AND (NULL LISTNAME)
(CONS (QUOTE PROP)
(CONS (COND
((AND (LISTP (CDR NAME))
(NULL (CDDR NAME)))
(CADR NAME))
(T (CDR NAME)))
(OR (LISTP (CAR NAME))
(LIST (CAR NAME)))))))
(EXPRESSIONS (COND
((EQ (CAR NAME)
(QUOTE SETQ))
(MAKENEWCOM (CDR NAME)
(QUOTE VARS)
LISTNAME FILE))
(T (CONS (QUOTE P)
(COND
(LISTNAME (LIST (QUOTE *)
LISTNAME))
(T (LIST NAME)))))))
(ADVICE (DEFAULTMAKENEWCOM NAME (QUOTE ADVISE)
LISTNAME FILE))
NIL)
(DEFAULTMAKENEWCOM NAME TYPE LISTNAME FILE))))))
(DEFAULTMAKENEWCOM
[LAMBDA (NAME TYPE LISTNAME FILE)
(* lmm "20-OCT-82 22:48")
(COND
((NOT (OR (FMEMB TYPE FILEPKGCOMSPLST)
(fetch MACRO of TYPE)
(fetch GETDEF of TYPE)))
(ERROR "no defined way to dump or obtain the definition of " (OR (fetch DESCRIPTION
of TYPE)
TYPE)
T))
((NULL DEFAULTCOMHASFILEFLG)
(* disable FOOFNS FOOVARS junk)
(LIST TYPE NAME))
((EQ FILE T) (* FILE=T only when called from SHOWDEF)
(LIST TYPE NAME))
([OR LISTNAME (AND FILE (SAVESET (SETQ LISTNAME (FILECOMS FILE TYPE))
(MERGEINSERT NAME (LISTP (GETTOPVAL LISTNAME))
T)
T
(QUOTE NOPRINT]
(* The check (AND FILE --) is so that it will not bother with making listnames
just for deleting items)
(LIST TYPE (QUOTE *)
LISTNAME))
(T (LIST TYPE NAME])
)
(RPAQ? DEFAULTCOMHASFILEFLG )
(DEFINEQ
(MERGEINSERT
[LAMBDA (NEW LST ONEFLG) (* edited: "15-AUG-78 21:46")
(* searches LST to find the most reasonable place to insert NEW. DOES NOTHING IF ONEFLG IS T AND NEW IS ALREADY A
MEMBER OF LST)
(COND
((AND ONEFLG (MEMBER NEW LST))
LST)
(T (PROG ((N 0)
LST1 PLACE TEM)
(SETQ LST1 LST)
LP
(* finds the function with the longest leading common substring. The idea is that if the list is only paatially
sorted, want to insert the new thing in among those function that look like they are related.)
(COND
((NULL LST1)
(GO OUT))
((SETQ TEM (STRPOS (CAR LST1)
NEW 1 NIL T T))
(* this takes precedence over even a longer string so that for example in the list (ADDTOFILES? ADDTOFILE),
ADDTOFILE1 will be inserted aater ADDTOFILE)
(SETQ N (SUB1 TEM))
(SETQ PLACE LST1)
(GO OUT))
((IGREATERP (SETQ TEM (MERGEINSERT1 (CAR LST1)
NEW))
N)
(SETQ N TEM)
(SETQ PLACE LST1)))
(SETQ LST1 (CDR LST1))
(GO LP)
OUT (SETQ TEM (CAR PLACE))
(OR [SOME (OR PLACE LST)
(FUNCTION (LAMBDA (X LST)
(COND
([OR (ALPHORDER NEW X)
(AND PLACE (NOT (ALPHORDER TEM X]
(* for example, if the FNS list is something like (... FOO FOO1 ...) where the ... may ormay not be in order, e.g.
(ZAP FOO FOO1 BLAH), then want to insert FOO2 after FOO1, i.e. before BLAH, even though FOO2 wold not come before
BLAH in a sorted lit.)
(/ATTACH NEW LST))
(T (SETQ TEM X)
NIL]
(SETQ LST (/NCONC1 LST NEW)))
(RETURN LST])
(MERGEINSERT1
[LAMBDA (X Y) (* rmk: "24-MAY-82 00:05"
)
(* value is the number of leading characters of X
and Y that agree.)
(PROG ((N 1)
C1 C2)
LP [COND
((OR (NULL (SETQ C1 (NTHCHARCODE X N)))
(NULL (SETQ C2 (NTHCHARCODE Y N)))
(NEQ C1 C2))
(RETURN (SUB1 N]
(SETQ N (ADD1 N))
(GO LP])
)
(RPAQ? ADDTOFILEKEYLST (QUOTE ((%[ "" EXPLAINSTRING
"[ -- prettyprint the item to terminal and then ask again"
NOECHOFLG T)
(%
"" EXPLAINSTRING "{line-feed} - same as previous response"
NOECHOFLG T)
(% "
" EXPLAINSTRING "{space} - no action" NOECHOFLG T)
(%] "Nowhere
" EXPLAINSTRING "] - nowhere, item is marked as a dummy
" NOECHOFLG T)
(%( "List: (" EXPLAINSTRING "(list name)" NOECHOFLG T KEYLST
(( "" CONFIRMFLG (%) %] % %
)
RETURN
(CDR ANSWER))))
(@ "Near: " EXPLAINSTRING
"@ other-item -- put the item near the other item"
NOECHOFLG T KEYLST (( "" CONFIRMFLG (%
)
RETURN ANSWER)))
(%
"" RETURN (QUOTE % ))
("" "File name: " EXPLAINSTRING "a file name" KEYLST ()))))
(RPAQ? LASTFILE )
(* * "deleting an item from a file")
(DEFINEQ
(DELFROMFILES
[LAMBDA (NAME TYPE FILES) (* rmk: " 6-MAR-82 13:16")
(* Eliminates NAME as an item of type TYPE in COMS.)
(PROG (COMS)
(SETQ TYPE (GETFILEPKGTYPE TYPE))
(RETURN (for FILE inside (OR FILES FILELST)
when [PROG1 (DELFROMCOMS (SETQ COMS (FILECOMS FILE))
NAME TYPE)
(COND
((INFILECOMS? NAME TYPE COMS)
(printout T "(could not delete " NAME " from " FILE ")" T]
collect (for FN in (fetch WHENUNFILED of TYPE)
do (APPLY* FN NAME TYPE FILE))
FILE])
(DELFROMCOM
[LAMBDA (COM NAME TYPE) (* rmk: "10-JUN-82 22:34"
) (* Tries to delete NAME
from COM)
(PROG (TEM VAR NEW)
(COND
((SETQ TEM (fetch DELETE of (CAR COM)))
(AND (SETQ TEM (APPLY* TEM COM NAME TYPE))
(MARKASCHANGED COMSNAME (QUOTE VARS)))
(RETURN TEM)))
(RETURN
(SELECTQ
(CAR COM)
((DECLARE: COMS)
(DELFROMCOMS (COND
[(EQ (CADR COM)
(QUOTE *))
(COND
((LITATOM (CADDR COM))
(CADDR COM))
(T (RETURN]
(T (CDR COM)))
NAME TYPE))
[(ALISTS PROPS)
(AND (EQ TYPE (CAR COM))
(COND
((EQ (CADR COM)
(QUOTE *))
(COND
([AND (LITATOM (SETQ VAR (CADDR COM)))
(SETQ TEM (ASSOC (CAR NAME)
(GETTOPVAL VAR)))
(NEQ (CDR TEM)
(SETQ TEM (REMOVEITEM
(CADR NAME)
(CDR TEM]
(SAVESET VAR TEM T (QUOTE NOPRINT))
T)))
([AND [CDR (SETQ TEM (ASSOC (CAR NAME)
(CDR COM]
(NEQ (CDR TEM)
(SETQ NEW (REMOVEITEM (CADR NAME)
(CDR TEM]
(/RPLACD TEM NEW)
(MARKASCHANGED COMSNAME (QUOTE VARS))
T]
[BLOCKS
(* Remove function name from blocks declarations.
This isn't entirely correctly, since in removing the
name from the block variables, it will hit homonyms
in globalvars, specvars, etc.)
(AND (EQ TYPE (QUOTE FNS))
(for BLOCK in (INFILECOMTAIL COM T)
do (AND (MEMB NAME BLOCK)
(/DREMOVE NAME BLOCK))
(for X in BLOCK
when (AND (LISTP X)
(MEMB NAME (CDR X)))
do (/RPLACD X (REMOVE NAME
(CDR X]
[(PROP IFPROP)
(SELECTQ
TYPE
[PROPS
(RETURN
(COND
((EQ (CADR COM)
(CADR NAME))
(DELFROMCOM1 (CDR COM)
(CAR NAME)))
((AND (EQMEMB (CADR NAME)
(CADR COM))
[NULL (CDR (SETQ TEM (PRETTYCOM1
(CDR COM]
(EQ (CAR TEM)
(CAR NAME)))
[/RPLACA (CDR COM)
(REMOVE (CADR NAME)
(MKLIST (CADR COM]
(MARKASCHANGED COMSNAME (QUOTE VARS))
T]
(COND
([for PROP inside (CADR COM)
always (EQ TYPE (GETPROP PROP (QUOTE PROPTYPE]
(DELFROMCOM1 (CDR COM)
NAME]
((RECORDS INITRECORDS SYSRECORDS)
(AND (EQ TYPE (QUOTE RECORDS))
(DELFROMCOM1 COM NAME)))
(P (AND (EQ TYPE (QUOTE EXPRESSIONS))
(DELFROMCOM1 COM NAME)))
((VARS INITVARS)
(AND (EQ TYPE (QUOTE VARS))
(DELFROMCOM1 COM NAME T)))
(AND (EQ TYPE (CAR COM))
(DELFROMCOM1 COM NAME])
(DELFROMCOM1
[LAMBDA (COM NAME FLG) (* rmk: "10-JUN-82 22:44"
)
(* FLG is passed on to REMOVEITEM, determines
whether lists whose CAR is NAME will be removed)
(PROG (TEM VAL)
(RETURN (COND
((EQ (CADR COM)
(QUOTE *))
(COND
([AND (LITATOM (SETQ TEM (CADDR COM)))
(NEQ (SETQ VAL (GETTOPVAL TEM))
(SETQ VAL (REMOVEITEM NAME VAL FLG]
(SAVESET TEM VAL T (QUOTE NOPRINT))
T)))
((NEQ (CDR COM)
(SETQ TEM (REMOVEITEM NAME (CDR COM)
FLG)))
(/RPLACD COM TEM)
(MARKASCHANGED COMSNAME (QUOTE VARS))
T])
(DELFROMCOMS
[LAMBDA (COMS NAME TYPE) (* rmk: " 7-MAR-82 14:12")
(* delete NAME of type TYPE from the coms COMS (either the name of some coms or a list) -
return T if it does anything)
(COND
[(LITATOM COMS)
(PROG ((COMSNAME COMS))
(RETURN (AND (LISTP (SETQ COMS (GETTOPVAL COMSNAME)))
(DELFROMCOMS COMS NAME TYPE]
(T (PROG (DONE)
(SETQ TYPE (GETFILEPKGTYPE TYPE))
LP (COND
((NLISTP COMS)
(RETURN DONE)))
[COND
((LISTP (CAR COMS))
(SELECTQ (DELFROMCOM (CAR COMS)
NAME TYPE)
(ALL (/RPLNODE2 COMS (CDR COMS))
(SETQQ DONE ALL)
(GO LP))
(NIL)
(SETQ DONE T)))
(T (SELECTQ (CAR COMS)
((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN)
(SETQ COMS (CDR COMS)))
(COND
((AND (EQ TYPE (QUOTE VARS))
(EQ NAME (CAR COMS)))
(/RPLNODE2 COMS (CDR COMS))
(SETQ DONE T)
(GO LP]
(SETQ COMS (CDR COMS))
(GO LP])
(REMOVEITEM
[LAMBDA (X LST FLG) (* lmm "10-FEB-78 17:29")
(* returns a subset of LST with X deleted;
if FLG is set, also remove elements whose CAR is X)
(COND
[[OR (FMEMB X LST)
(AND FLG (SOME LST (FUNCTION (LAMBDA (Y)
(EQ (CAR (LISTP Y))
X]
(SUBSET LST (FUNCTION (LAMBDA (Y)
(AND (NEQ Y X)
(OR (NOT FLG)
(NLISTP Y)
(NEQ (CAR Y)
X]
(T LST])
(MOVETOFILE
[LAMBDA (TOFILE NAME TYPE FROMFILE) (* rmk: "18-OCT-79 19:51")
(* To move items between files)
(SETQ TYPE (GETFILEPKGTYPE TYPE))
[COND
((OR (EQ TYPE (QUOTE FNS))
FROMFILE) (* FNS definition can reside on file if LOADFNS was
done. This guarantees that it is loaded.)
(PUTDEF NAME TYPE (GETDEF NAME TYPE FROMFILE (QUOTE (NOCOPY NODWIM]
(AND (EQ TYPE (QUOTE FNS))
(MARKASCHANGED NAME TYPE)) (* FNS won't get dumped unless they are "changed")
(DELFROMFILES NAME TYPE FROMFILE)
(ADDTOFILE NAME TYPE TOFILE])
)
(MOVD? (QUOTE DELFROMFILES)
(QUOTE DELFROMFILE))
(MOVD? (QUOTE MOVETOFILE)
(QUOTE MOVEITEM))
(ADDTOVAR SYSPROPS PROPTYPE VARTYPE)
(ADDTOVAR SYSPROPS MACRO BYTEMACRO ALTOMACRO JMACRO VAXMACRO DMACRO 10MACRO)
(* * "functions for doing things and marking them changed and auxiliary functions")
(DEFINEQ
(SAVEPUT
[LAMBDA (ATM PROP VAL) (* lmm " 7-May-84 16:56")
(* analogous to SAVESET but also marks changed property
lists; LISPXFNS are marked to change PUT and PUTPROP to
SAVEPUT)
[COND
((NOT (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0 TEM OLDFLG)
LOOP(COND
((NLISTP X)
(COND
((AND (NULL X)
X0) (* typical case. property list ran out on an even parity
position. e.g. (A B C D))
(SETQ TEM (LIST PROP VAL))
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1)
ATM TEM)
LISPXHIST))
(FRPLACD (CDR X0)
TEM)
(GO RET)))
(* propety list was initially NIL or a non-list, or else it ended in a non-list following an even parity position,
e.g. (A B . C) fall through and add new property at beginning)
)
((NLISTP (CDR X))
(* property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.
(A B C) or (A B C . D) fall through and add at beginning.)
)
[(EQ (CAR X)
PROP)
(SETQ OLDFLG (NEQ (EQUALN (CADR X)
VAL 400)
T)) (* i.e. it probably changed)
(/RPLACA (CDR X)
VAL)
(COND
((NOT OLDFLG)
(GO RET1))
(T (OR (EQ DFNFLG T)
(LISPXPRINT (LIST (QUOTE new)
PROP
(QUOTE property)
(QUOTE for)
ATM)
T T))
(GO RET]
(T (SETQ X (CDDR (SETQ X0 X)))
(GO LOOP)))
[SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM]
(SETPROPLIST ATM TEM)
(AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1)
ATM TEM)
LISPXHIST))
RET (MARKASCHANGED (LIST ATM PROP)
(QUOTE PROPS)
(NOT OLDFLG))
RET1(AND ADDSPELLFLG (ADDSPELL ATM 0))
(RETURN VAL])
(PUTPROPS
[NLAMBDA X (* lmm: " 5-FEB-77 21:33:16")
(* redefined to call SAVEPUT rather than /PUT)
(MAP (CDR X)
(FUNCTION [LAMBDA (Y)
(SAVEPUT (CAR X)
(CAR Y)
(CADR Y)
T])
(FUNCTION CDDR])
(ADDTOVAR
[NLAMBDA X (* rmk: "18-FEB-82 21:49")
(* redefined to handle alists specially)
(PROG ((VAR (CAR X))
[VAL (OR (AND (EQ DFNFLG (QUOTE ALLPROP))
(GETPROP (CAR X)
(QUOTE VALUE)))
(LISTP (GETTOPVAL (CAR X]
TYPE FLG)
[COND
[[AND (NEQ DFNFLG (QUOTE ALLPROP))
(SETQ TYPE (GETPROP VAR (QUOTE VARTYPE)))
(SETQ TYPE (OR (LISTGET1 (LISTP TYPE)
(QUOTE ALIST))
(EQ TYPE (QUOTE ALIST]
[MAPC
(CDR X)
(FUNCTION (LAMBDA (PAIR OLDENTRY)
(COND
((NLISTP PAIR)
(SETQ VAL (CONS PAIR VAL))
(SETQ FLG T))
((NOT
(EQUAL (SETQ OLDENTRY
(SELECTQ
TYPE
[USERMACROS (CAR (SOME VAL
(FUNCTION (LAMBDA (OP)
(AND (EQ (CAR OP)
(CAR PAIR))
(EQ (NULL (CADR OP))
(NULL (CADR PAIR]
(FASSOC (CAR PAIR)
VAL)))
PAIR))
(OR (NULL OLDENTRY)
(EQ DFNFLG T)
(LISPXPRINT (LIST (QUOTE new)
VAR
(QUOTE entry)
(QUOTE for)
(CAR PAIR))
T T))
(MARKASCHANGED (LIST VAR (CAR PAIR))
(QUOTE ALISTS)
(NULL OLDENTRY))
(SETQ VAL (CONS PAIR (COND
(OLDENTRY (/DREMOVE OLDENTRY VAL))
(T VAL]
(COND
(FLG (SAVESET VAR VAL T (QUOTE NOPRINT)))
(T (/SETTOPVAL VAR VAL]
(T (* in shallow system, addtovar works on current
binding.)
(RESETVARS [(DFNFLG (COND
((EQ DFNFLG (QUOTE ALLPROP))
(QUOTE PROP))
(T DFNFLG]
(COND
((OR VAL (CDR X))
(SAVESET VAR (UNION (CDR X)
VAL)
T
(QUOTE NOPRINT)))
((EQ (QUOTE NOBIND)
(GETTOPVAL VAR)) (* The semantics of (ADDVARS
(FOO)) are to initiilize FOO to NIL if it is NOBIND,
otherwise leave it alone.)
(/SETTOPVAL VAR NIL]
(RETURN VAR])
(APPENDTOVAR
[NLAMBDA X (* rmk: "18-FEB-82 21:49")
(* redefined to handle alists specially)
(PROG ((VAR (CAR X))
[VAL (OR (AND (EQ DFNFLG (QUOTE ALLPROP))
(GETPROP (CAR X)
(QUOTE VALUE)))
(LISTP (GETTOPVAL (CAR X]
TYPE FLG)
[COND
[[AND (NEQ DFNFLG (QUOTE ALLPROP))
(SETQ TYPE (GETPROP VAR (QUOTE VARTYPE)))
(SETQ TYPE (OR (LISTGET1 (LISTP TYPE)
(QUOTE ALIST))
(EQ TYPE (QUOTE ALIST]
[MAPC
(CDR X)
(FUNCTION (LAMBDA (PAIR OLDENTRY)
(COND
((NLISTP PAIR)
(SETQ VAL (CONS PAIR VAL))
(SETQ FLG T))
((NOT
(EQUAL (SETQ OLDENTRY
(SELECTQ
TYPE
[USERMACROS (CAR (SOME VAL
(FUNCTION (LAMBDA (OP)
(AND (EQ (CAR OP)
(CAR PAIR))
(EQ (NULL (CADR OP))
(NULL (CADR PAIR]
(FASSOC (CAR PAIR)
VAL)))
PAIR))
(OR (NULL OLDENTRY)
(EQ DFNFLG T)
(LISPXPRINT (LIST (QUOTE new)
VAR
(QUOTE entry)
(QUOTE for)
(CAR PAIR))
T T))
(MARKASCHANGED (LIST VAR (CAR PAIR))
(QUOTE ALISTS)
(NULL OLDENTRY))
(SETQ VAL (APPEND (COND
(OLDENTRY (/DREMOVE OLDENTRY VAL))
(T VAL))
(LIST PAIR]
(COND
(FLG (SAVESET VAR VAL T (QUOTE NOPRINT)))
(T (/SETTOPVAL VAR VAL]
(T (* in shallow system, addtovar works on current
binding.)
(RESETVARS [(DFNFLG (COND
((EQ DFNFLG (QUOTE ALLPROP))
(QUOTE PROP))
(T DFNFLG]
(COND
((OR VAL (CDR X))
(SAVESET VAR (APPEND VAL (LDIFFERENCE (CDR X)
VAL))
T
(QUOTE NOPRINT)))
((EQ (QUOTE NOBIND)
(GETTOPVAL VAR)) (* The semantics of (ADDVARS
(FOO)) are to initiilize FOO to NIL if it is NOBIND,
otherwise leave it alone.)
(/SETTOPVAL VAR NIL]
(RETURN VAR])
)
(DEFINEQ
(UNMARKASCHANGED
(LAMBDA (NAME TYPE) (* JonL "24-Jul-84 19:59")
(* says to remove NAME from TYPE's changedlst, and also
to remove it from any FILE properties.
Value is name if anything is done)
(PROG (ANYFLG)
(bind TAIL (CHANGED ←(fetch CHANGED of (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))))
while (SETQ TAIL (MEMBER NAME CHANGED))
do (/RPLACA TAIL)
(SETQ ANYFLG T))
(for F TAIL PROP TYPEDPROP in FILELST
when (SETQ TAIL (MEMBER NAME (CDR (SETQ TYPEDPROP (ASSOC TYPE
(fetch TOBEDUMPED
of (SETQ PROP
(fetch FILEPROP
of F))))))))
do (SETQ ANYFLG T)
(COND
((SETQ TAIL (REMOVE (CAR TAIL)
(CDR TYPEDPROP)))
(/RPLACD TYPEDPROP TAIL))
(T (/replace TOBEDUMPED of PROP with (REMOVE TYPEDPROP (fetch TOBEDUMPED
of PROP))))))
(RETURN (AND ANYFLG NAME)))))
(PREEDITFN
[LAMBDA (ATM TYPE EDITCHANGES) (* rmk: "18-FEB-82 21:49")
(* EDITL is advised to call this before editing
something)
(AND FILEPKGFLG (SELECTQ TYPE
[PROPLST [AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
(CONS))
CLISPARRAY))
(for X in (GETPROPLIST ATM)
do (OR (NLISTP X)
(GETHASH X CLISPARRAY)
(PUTHASH X (CONS (CAR X)
(CDR X))
CLISPARRAY]
(* note that if CLISPARRAY is disabled that ALL properties of an edited prop list will get marked as changed if any
destructive edit is made)
(RESETSAVE NIL (LIST (FUNCTION POSTEDITPROPS)
EDITCHANGES
(APPEND (GETPROPLIST ATM]
[VARS (COND
((EQMEMB (QUOTE ALIST)
(GETPROP ATM (QUOTE VARTYPE)))
[AND (OR CLISPARRAY (PROGN (CLISPTRAN (CONS)
(CONS))
CLISPARRAY))
(for X in (EVALV ATM)
do (OR (NLISTP X)
(GETHASH X CLISPARRAY)
(PUTHASH X (CONS (CAR X)
(CDR X))
CLISPARRAY]
(RESETSAVE NIL (LIST (FUNCTION POSTEDITALISTS)
EDITCHANGES
(for X in (EVALV ATM)
collect (CAR X]
NIL])
(POSTEDITPROPS
[LAMBDA (EDITCHANGES OLDPROPS) (* rmk: "18-FEB-82 21:50")
(* was RESETSAVE'd from PREEDITFN)
(PROG (OV FOUNDCHANGE)
(OR FILEPKGFLG (RETURN))
(COND
((CADR EDITCHANGES)
(for NEWPROP on (GETPROPLIST (CAR EDITCHANGES)) by (CDDR NEWPROP)
when (for OLDPROP on OLDPROPS by (CDDR OLDPROP)
do (COND
((EQ (CAR OLDPROP)
(CAR NEWPROP)) (* Found the property)
[AND (EQ (CADR OLDPROP)
(CADR NEWPROP))
(COND
((NLISTP (CADR OLDPROP))
(* value is same)
(RETURN))
((AND CLISPARRAY (SETQ OV (GETHASH (CADR NEWPROP)
CLISPARRAY))
(EQ (CAADR NEWPROP)
(CAR OV))
(EQ (CDADR NEWPROP)
(CDR OV)))
(PUTHASH (CADR NEWPROP)
NIL CLISPARRAY)
(* value has been edited (CLISPARRAY translation went
away))
(RETURN]
(RETURN T)))
finally (* didn't find the property)
(RETURN T))
do (MARKASCHANGED (LIST (CAR EDITCHANGES)
(CAR NEWPROP))
(QUOTE PROPS)
NIL)
(SETQ FOUNDCHANGE T))
(AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
NIL])
(POSTEDITALISTS
[LAMBDA (EDITCHANGES OLDTOKENS) (* rmk: " 4-JAN-82 10:14")
(PROG [OV FOUNDCHANGE (NEWENTRIES (GETTOPVAL (CAR EDITCHANGES]
(* called after an ALIST has been edited)
(OR FILEPKGFLG (RETURN))
(COND
((CADR EDITCHANGES)
(for X in OLDTOKENS when (NOT (FASSOC X NEWENTRIES)) do (MARKASCHANGED
(LIST (CAR EDITCHANGES)
X)
(QUOTE ALISTS)
NIL)
(SETQ FOUNDCHANGE T))
[for NEWENTRY in NEWENTRIES do (COND
([AND (LISTP NEWENTRY)
(NOT (AND CLISPARRAY (SETQ OV (GETHASH NEWENTRY
CLISPARRAY))
(EQ (CAR NEWENTRY)
(CAR OV))
(EQ (CDR NEWENTRY)
(CDR OV]
(PUTHASH NEWENTRY NIL CLISPARRAY)
(MARKASCHANGED (LIST (CAR EDITCHANGES)
(CAR NEWENTRY))
(QUOTE ALISTS)
NIL)
(SETQ FOUNDCHANGE T]
(AND FOUNDCHANGE (RPLACA (CDR EDITCHANGES)
NIL])
)
(ADDTOVAR LISPXFNS (PUT . SAVEPUT)
(PUTPROP . SAVEPUT))
(* * "sub-functions for file package commands & types")
(DEFINEQ
(ALISTS.WHENCHANGED
[LAMBDA (NAME TYPE NEWFLG) (* lmm "16-OCT-78 20:02")
(* called by MARKASCHANGED when an ALIST entry has
changed)
(PROG [(VARTYPE (GETPROP (CAR NAME)
(QUOTE VARTYPE]
(AND (LISTP VARTYPE)
(EQ (CAR VARTYPE)
(QUOTE ALIST))
(RETFROM (QUOTE MARKASCHANGED)
(MARKASCHANGED (CADR NAME)
(CADR VARTYPE)
NEWFLG])
(CLEARCLISPARRAY
[LAMBDA (NAME TYPE REASON)
(DECLARE (SPECVARS NAME TYPE REASON)) (* lmm "14-Aug-84 15:03")
(AND CLISPARRAY (MAPHASH CLISPARRAY (COND
[(EQ TYPE (QUOTE I.S.OPRS))
(FUNCTION (LAMBDA (TRAN FORM)
(AND (MEMB NAME FORM)
(PUTHASH FORM NIL CLISPARRAY]
(T (* MACRO CHANGED)
(FUNCTION (LAMBDA (TRAN FORM)
(COND
((OR (EQ NAME (CAR FORM))
(EQ (CAR (GETPROP (CAR FORM)
(QUOTE CLISPWORD)))
(QUOTE CHANGETRAN)))
(PUTHASH FORM NIL CLISPARRAY])
(EXPRESSIONS.WHENCHANGED
[LAMBDA (EXPR) (* rmk: "19-FEB-83 22:28")
(SELECTQ (CAR EXPR)
((SETQ SETQQ)
(UNMARKASCHANGED (CADR EXPR)
(QUOTE VARS)))
((PROGN PROG)
(for X in (CDR EXPR) do (EXPRESSIONS.WHENCHANGED X)))
[ADVISE (AND (EQ (CAADR EXPR)
(QUOTE QUOTE))
(for FN in (PACK-IN- (CADR (CADR EXPR))) do (UNMARKASCHANGED FN
(QUOTE ADVICE]
NIL])
(MAKEALISTCOMS
[NLAMBDA X (* rmk: "14-OCT-83 13:34")
(* make command to dump prettydefmacros)
(LIST (CONS (QUOTE ADDVARS)
(for PR in X join (for ALISTNAME inside (CAR PR)
collect
(CONS ALISTNAME
(for ATNAME inside (CDR PR) bind ENTRY
when (SETQ ENTRY
(OR (SASSOC ATNAME (GETTOPVAL ALISTNAME))
(PROGN (LISPXPRINT (LIST (QUOTE no)
ATNAME
(QUOTE entry)
(QUOTE on)
ALISTNAME)
T T)
NIL)))
collect ENTRY])
(MAKEFILESCOMS
(NLAMBDA FILES (* JonL "12-FEB-83 19:02")
(* This scans the command just to warn the user about
any errors. Must match up with the big SELECTQ in
FILESLOAD NIL)
(for FILE in FILES
do (OR (LITATOM FILE)
(while (LISTP FILE)
do (SELECTQ (CAR (OR (LISTP FILE)
(RETURN)))
((LOADCOMP LOADFROM))
(FROM (pop FILE)
(if (OR (EQ (CAR FILE)
(QUOTE VALUEOF))
(if (AND (EQ (CAR FILE)
(QUOTE VALUE))
(EQ (CADR FILE)
(QUOTE OF)))
then (pop FILE)))
then (pop FILE)))
((COMPILED LOAD EXTENSION EXT SOURCE SYMBOLIC IMPORT NOERROR))
(OR (FMEMB (CAR FILE)
LOADOPTIONS)
(PRINT (CONS (CAR FILE)
(QUOTE (-- unrecognized FILES option)))
T)))
(pop FILE))))
(CONS (QUOTE FILESLOAD)
FILES)))
(MAKELISPXMACROSCOMS
[NLAMBDA X (* lmm " 5-SEP-78 23:15")
(PROG (TEM TEM2)
(RETURN (CONS [CONS (QUOTE ALISTS)
(SETQ TEM (NCONC (AND [SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z)
(FASSOC Z
LISPXHISTORYMACROS]
(LIST (CONS (QUOTE LISPXHISTORYMACROS)
TEM)))
(AND [SETQ TEM (SUBSET X (FUNCTION (LAMBDA (Z)
(FASSOC Z LISPXMACROS]
(LIST (CONS (QUOTE LISPXMACROS)
TEM]
(SETQ TEM2 (NCONC [AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
(FMEMB Z LISPXCOMS]
(LIST (LIST (QUOTE ADDVARS)
(CONS (QUOTE LISPXCOMS)
TEM2]
(AND [SETQ TEM2 (SUBSET X (FUNCTION (LAMBDA (Z)
(FMEMB Z HISTORYCOMS]
(LIST (LIST (QUOTE ADDVARS)
(CONS (QUOTE HISTORYCOMS)
TEM2])
(MAKEPROPSCOMS
[NLAMBDA X (* lmm "26-FEB-78 17:10")
(* make command to dump PROPS)
(for PAIR in X collect (CONS (QUOTE PROP)
(CONS (COND
((AND (LISTP (CDR PAIR))
(NULL (CDDR PAIR)))
(CADR PAIR))
(T (CDR PAIR)))
(OR (LISTP (CAR PAIR))
(LIST (CAR PAIR])
(MAKEUSERMACROSCOMS
[NLAMBDA X (* rmk: " 3-JAN-82 23:20")
(PROG (TEM)
[COND
[X (for Y in X do (OR (FASSOC Y USERMACROS)
(FASSOC Y EDITMACROS)
(LISPXPRINT (CONS Y (QUOTE (-- no entry on USERMACROS)))
T T]
(T (SETQ X (INTERSECTION (SETQ X (MAPCAR USERMACROS (QUOTE CAR)))
X]
(RETURN (LIST (CONS (QUOTE ADDVARS)
(NCONC (for VAR in (QUOTE (USERMACROS EDITMACROS))
when (SETQ TEM (for Y in (GETTOPVAL VAR)
when (FMEMB (CAR Y)
X)
collect Y))
collect (CONS VAR TEM))
(for LST in (QUOTE (EDITCOMSA EDITCOMSL COMPACTHISTORYCOMS
DONTSAVEHISTORYCOMS))
when [SETQ TEM (SUBSET (GETTOPVAL LST)
(FUNCTION (LAMBDA (Y)
(OR (FMEMB Y X)
(AND (LISTP Y)
(FMEMB (CAR Y)
X]
collect (CONS LST TEM])
(PROPS.WHENCHANGED
[LAMBDA (NAME TYPE NEWFLG) (* lmm " 7-SEP-78 22:08")
(PROG [(PROPTYPE (GETPROP (CADR NAME)
(QUOTE PROPTYPE]
(COND
[PROPTYPE (RETFROM (QUOTE MARKASCHANGED)
(COND
((NEQ PROPTYPE (QUOTE IGNORE))
(MARKASCHANGED (CAR NAME)
PROPTYPE NEWFLG]
(T (SELECTQ (CADR NAME)
(CLISPWORD (CLEARCLISPARRAY (CAR NAME)))
NIL])
)
(ADDTOVAR MACROPROPS MACRO BYTEMACRO ALTOMACRO JMACRO VAXMACRO DMACRO 10MACRO)
(ADDTOVAR SYSPROPS PROPTYPE)
(PUTPROPS I.S.OPR PROPTYPE I.S.OPRS)
(PUTPROPS SUBR PROPTYPE IGNORE)
(PUTPROPS LIST PROPTYPE IGNORE)
(PUTPROPS CODE PROPTYPE IGNORE)
(PUTPROPS BRKINFO PROPTYPE IGNORE)
(PUTPROPS BROKEN-IN PROPTYPE IGNORE)
(PUTPROPS BROKEN PROPTYPE IGNORE)
(PUTPROPS FILEDATES PROPTYPE IGNORE)
(PUTPROPS FILE PROPTYPE IGNORE)
(PUTPROPS FILEMAP PROPTYPE IGNORE)
(PUTPROPS EXPR PROPTYPE FNS)
(PUTPROPS ADVICE PROPTYPE ADVICE)
(PUTPROPS READVICE PROPTYPE ADVICE)
(PUTPROPS ADVISED PROPTYPE ADVICE)
(PUTPROPS VALUE PROPTYPE VARS)
(PUTPROPS BAKTRACELST VARTYPE ALIST)
(PUTPROPS BREAKMACROS VARTYPE ALIST)
(PUTPROPS COMPILETYPELST VARTYPE ALIST)
(PUTPROPS EDITMACROS VARTYPE (ALIST USERMACROS))
(PUTPROPS ERRORTYPELST VARTYPE ALIST)
(PUTPROPS FONTDEFS VARTYPE ALIST)
(PUTPROPS LISPXHISTORYMACROS VARTYPE (ALIST LISPXMACROS))
(PUTPROPS LISPXMACROS VARTYPE (ALIST LISPXMACROS))
(PUTPROPS PRETTYDEFMACROS VARTYPE (ALIST FILEPKGCOMS))
(PUTPROPS PRETTYEQUIVLST VARTYPE ALIST)
(PUTPROPS PRETTYPRINTMACROS VARTYPE ALIST)
(PUTPROPS PRETTYPRINTYPEMACROS VARTYPE ALIST)
(PUTPROPS USERMACROS VARTYPE (ALIST USERMACROS))
(PUTPROPS MACRO PROPTYPE MACROS)
(PUTPROPS BYTEMACRO PROPTYPE MACROS)
(PUTPROPS ALTOMACRO PROPTYPE MACROS)
(PUTPROPS JMACRO PROPTYPE MACROS)
(PUTPROPS VAXMACRO PROPTYPE MACROS)
(PUTPROPS DMACRO PROPTYPE MACROS)
(PUTPROPS 10MACRO PROPTYPE MACROS)
(* * "Define the commands below AFTER the various properties have been established.")
(ADDTOVAR USERMACROS (M (X . Y)
(E (MARKASCHANGED (COND ((LISTP (QUOTE X))
(CAR (QUOTE X)))
(T (QUOTE X)))
(QUOTE USERMACROS))
T)
(ORIGINAL (M X . Y))))
(ADDTOVAR EDITMACROS (M (X . Y)
(E (MARKASCHANGED (COND ((LISTP (QUOTE X))
(CAR (QUOTE X)))
(T (QUOTE X)))
(QUOTE USERMACROS))
T)
(ORIGINAL (M X . Y))))
(ADDTOVAR EDITCOMSL M)
(* * GETDEF "functions")
(DEFINEQ
(RENAME
(LAMBDA (OLD NEW TYPES FILES METHOD) (* JonL "24-Jul-84 20:01")
(PROG ((TYPES (GETFILEPKGTYPE TYPES (QUOTE TYPE)
NIL OLD)))
(* special kludge: change the callers BEFORE if we are changing a field; this is so the CHANGECALLERS won't get an
UNABLE TO DWIMIFY message)
(for TYPE inside TYPES when (NEQ TYPE (QUOTE FIELDS)) do (COPYDEF OLD NEW TYPE NIL
(COND
((EQ TYPE (QUOTE VARS))
(QUOTE NOERROR)))))
(CHANGECALLERS OLD NEW TYPES FILES METHOD)
(for TYPE inside TYPES do (COND
((AND (EQ TYPE (QUOTE FIELDS))
(HASDEF OLD (QUOTE FIELDS)))
(* The HASDEF test is because the rename might already have been done in EDITFROMFILE in the CHANGECALLERS, if it
found a record with the field on a file. Otherwise, COPYDEF essentially will just do the necessary substitution in
the existing record declarations, given that definitions for FIELDS are mutually exclusive.)
(COPYDEF OLD NEW (QUOTE FIELDS)))
(T (DELDEF OLD TYPE))))
(RETURN NEW))))
(CHANGECALLERS
(LAMBDA (OLD NEW TYPES FILES METHOD) (* JonL "24-Jul-84 20:03")
(PROG (REL TEM EDITCOMS (TYPES (GETFILEPKGTYPE (OR TYPES (QUOTE (FNS MACROS TEMPLATES)))))
FNS)
(SETQ EDITCOMS
(LIST (COND
((SETQ TEM (TYPESOF OLD NIL TYPES))
(printout T "Warning --" OLD " is also used as " TEM T)
(* This creates a "command" that searches like EXAM, but interrogates the user about whether to do the R.
Y means do it, No means skip, anything else goes into TTY.)
(SUBPAIR (QUOTE (OLD NEW))
(LIST OLD NEW)
(QUOTE (BIND (LPQ (F OLD N)
(MARK #1)
(ORR (1 !0 P)
NIL)
(MARK #2)
(COMS (SELECTQ (ASKUSER NIL NIL " Replace ? "
(QUOTE ((Y "Yes
")
(N "No
")
(%
"")
(% "")
(%
"")
(& "")))
NIL NIL (QUOTE (NOECHOFLG
T)))
(Y (QUOTE (R1 OLD NEW)))
(N NIL)
(QUOTE TTY:)))
(MARK #3)
(IF (EQ (## (\ #3))
(## (\ #2)))
((\ #1))
NIL))))))
(T (LIST (QUOTE R)
OLD NEW)))))
(SELECTQ (OR METHOD (COND
((AND (EQ DEFAULTRENAMEMETHOD (QUOTE MASTERSCOPE))
MSDATABASELST)
(QUOTE MASTERSCOPE))
(T (QUOTE EDITCALLERS))))
(MASTERSCOPE (for TYPE inside TYPES
do (COND
((SETQ TEM (SELECTQ TYPE
(FNS (QUOTE CALL))
(MACROS (QUOTE (CALL DIRECTLY)))
(VARS (QUOTE (USE OR BIND)))
((RECORDS FIELDS I.S.OPRS TYPES)
(LIST (QUOTE USE)
(QUOTE AS)
TYPE))
NIL))
(COND
(REL (SETQ REL (LIST TEM (QUOTE OR)
REL)))
(T (SETQ REL TEM))))))
(COND
(REL (MAPC (SETQ FNS (NCONC (COND
((NULL FILES)
(UPDATEFILES)
(FILEPKGCHANGES (QUOTE FNS))))
(for FILE inside (OR FILES FILELST)
join (FILEFNSLST FILE))))
(FUNCTION UPDATEFN))
(SETQ FNS (INTERSECTION (GETRELATION OLD (SETQ REL
(PARSERELATION REL))
T)
FNS)))))
(EDITCALLERS (SETQ FILES (for X inside (OR FILES FILELST)
when (SETQ TEM (EDITCALLERS OLD X T))
collect (PROGN (SETQ FNS (NCONC FNS (CDR TEM)))
X))))
(ERROR "UNRECOGNIZED RENAME METHOD" METHOD))
(AND (EQMEMB (QUOTE FNS)
TYPES)
(FMEMB OLD FNS)
(SETQ FNS (REMOVE OLD FNS)))
(EDITFROMFILE FNS FILES OLD EDITCOMS)
(for TYPE inside TYPES
do (for FILE in (WHEREIS OLD TYPE FILES)
do (AND (ADDTOFILE NEW TYPE FILE)
(DELFROMFILES OLD TYPE FILE)
(printout T OLD " changed to " NEW " on " FILE)))
(COND
((SETQ TEM (WHEREIS OLD TYPE FILES))
(printout T "Couldn't change " OLD " to " NEW " as " TYPE " on " TEM))))
(COND
(REL (UPDATECHANGED)
(COND
((AND (SETQ TEM (GETRELATION OLD REL T))
(WHEREIS TEM (QUOTE FNS)
FILES))
(printout T "Couldn't find where " OLD " is referenced in " TEM T))))))))
)
(DEFINEQ
(SHOWDEF
(LAMBDA (NAME TYPE FILE) (* JonL "24-Jul-84 20:04")
(* prettyprint NAME as it would be dumped as a TYPE)
(PRETTYDEF NIL FILE (LIST (MAKENEWCOM NAME (GETFILEPKGTYPE TYPE (QUOTE TYPE)))))))
(COPYDEF
[LAMBDA (OLD NEW TYPE SOURCE OPTIONS) (* lmm "14-Aug-84 18:38")
(* like MOVD, but takes a type.)
(PROG (TEM DEF)
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
[SETQ DEF (GETDEF OLD TYPE SOURCE (COND
((EQ OPTIONS (QUOTE NOCOPY))
NIL)
(T (REMOVE (QUOTE NOCOPY)
(MKLIST OPTIONS] (* The default is for GETDEF to return a COPY.
Make sure that NOCOPY isn't in options though.)
(SELECTQ TYPE
(VARS)
[FILES (for X in (CAR DEF)
do (* change all the listnames which are of form
filenameTYPE)
(SELECTQ (CAR X)
((PROP IFPROP)
(SETQ X (CDR X)))
NIL)
(COND
((EQ (CADR X)
(QUOTE *))
(SETQ X (CDDR X))
(COND
((AND (LITATOM (CAR X))
(SETQ TEM (STRPOS OLD (CAR X)
1 NIL T T)))
(SAVESET (SETQ TEM (PACK* NEW (SUBATOM (CAR X)
TEM -1)))
(COPY (GETTOPVAL (CAR X)))
T)
(FRPLACA X TEM]
((PROPS ALISTS)
(OR (EQ (CAR NEW)
(CAR OLD))
(DSUBST (CAR NEW)
(CAR OLD)
DEF))
(OR (EQ (CADR NEW)
(CADR OLD))
(DSUBST (CADR NEW)
(CADR OLD)
DEF)))
(DSUBST NEW OLD DEF))
(PUTDEF NEW TYPE DEF)
(RETURN NEW])
(GETDEF
[LAMBDA (NAME TYPE SOURCE OPTIONS) (* rmk: "13-JUL-83 02:58")
(* returns the definition of NAME as a TYPE from SOURCE; cause ERROR if not found unless OPTIONS is NOERROR -
usually returns a copy unless OPTIONS is NOCOPY in which case it tries not to return a copy -
FLG=NOCOPY is currently only used from SAVEDEF where SOURCE is always 0 -
If options is or contains a string, returns that string instead of causing error if no def found.
The caller can figure out what happened, even for types for which NIL/NOBIND might have defs.)
(PROG (DEF TEM NODEF (NOCOPY (EQMEMB (QUOTE NOCOPY)
OPTIONS)))
(DECLARE (SPECVARS NODEF NOCOPY))
(SELECTQ OPTIONS
(0 (SETQQ OPTIONS (NOERROR NODWIM))
(SETQ NOCOPY T))
(1 (SETQQ OPTIONS (NOERROR NODWIM FAST ARGLIST))
(SETQ NOCOPY T))
(T (SETQQ OPTIONS SPELL))
NIL)
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(SELECTQ SOURCE
(0 (SETQQ SOURCE CURRENT))
(T (SETQQ SOURCE SAVED))
(NIL (SETQQ SOURCE ?))
NIL)
[SELECTQ SOURCE
(CURRENT (SETQ DEF (GETDEFCURRENT NAME TYPE OPTIONS)))
[? (SETQ DEF (GETDEFCURRENT NAME TYPE (QUOTE NOERROR)))
(COND
(NODEF (SETQ NODEF NIL)
(SETQ DEF (GETDEFSAVED NAME TYPE (QUOTE NOERROR)))
(COND
(NODEF (SETQ NODEF NIL)
(SETQ DEF (GETDEFFROMFILE NAME TYPE (QUOTE FILE)
OPTIONS]
(SAVED (SETQ DEF (GETDEFSAVED NAME TYPE OPTIONS)))
(COND
((AND (LISTP SOURCE)
(EQ (CAR SOURCE)
(QUOTE =)))
(SETQ DEF (CDR SOURCE)))
(T (SETQ DEF (GETDEFFROMFILE NAME TYPE SOURCE OPTIONS))
(SETQ NOCOPY T]
(OR NOCOPY (SETQ DEF (COPY DEF)))
(COND
((AND (EQ TYPE (QUOTE FNS))
(NOT (EQMEMB (QUOTE NODWIM)
OPTIONS)))
(DWIMDEF DEF NAME SOURCE)))
(RETURN DEF])
(GETDEFCOM
[LAMBDA (X) (* rmk: " 8-FEB-81 21:49")
(* In the case where GETDEF doesn't know how to get the definition of something, it resorts to asking the file
package to print it out to a file and then reading the file back in. Actually, though, that is a two stage process
where the "command" to print out the datum is first macro expanded and then executed. -
In some cases, you can tell what would be printed without printing it by looking at the prettydef-macro expansion.
That is what GETDEFCOM does: it takes a list of prettydef commands and returns what Would be printed by those
commands (or NIL if it is "too hard" to figure out.) -
A few of the commands are special-cased inside GETDEFCOM0 because they occur frequently or are simple.)
(for Y in X join (GETDEFCOM0 Y])
(GETDEFCOM0
[LAMBDA (COM) (* wt: " 7-FEB-79 23:28")
(PROG (TEM)
(RETURN (COND
((SETQ TEM (fetch MACRO of (CAR COM)))
(* COND ((fetch CONTENTS of (CAR COM)) (* if it has a CONTENTS function, generally means it is not safe to evaluate)
(RETFROM (QUOTE GETDEFCOM))))
(for Y in (SUBPAIR (CAR TEM)
(PRETTYCOM1 COM)
(CDR TEM))
join (GETDEFCOM0 Y)))
(T (SELECTQ (CAR COM)
(COMS (for X in (PRETTYCOM1 COM) join (GETDEFCOM0 X)))
(ADDVARS (for Y in (PRETTYCOM1 COM) collect (CONS (QUOTE ADDTOVAR)
Y)))
(APPENDVARS (for Y in (PRETTYCOM1 COM) collect (CONS (QUOTE
APPENDTOVAR)
Y)))
(P (APPEND (PRETTYCOM1 COM)))
(RETFROM (QUOTE GETDEFCOM])
(GETDEFCURRENT
[LAMBDA (NAME TYPE OPTIONS) (* rrb "22-Mar-84 11:37")
(* Gets the current definition--source=0)
(DECLARE (USEDFREE NOCOPY))
(PROG (DEF)
(RETURN
(COND
((AND (SETQ DEF (fetch GETDEF of TYPE))
(NEQ DEF T))
(* We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted
to the PUTDEF/GETDEF in PRETTYCOM.)
(OR (APPLY* DEF NAME TYPE OPTIONS)
(GETDEFERR NAME TYPE OPTIONS)))
(T (SELECTQ
TYPE
(FNS (OR (EXPRP (SETQ DEF (VIRGINFN NAME)))
(RETURN (GETDEFERR NAME TYPE OPTIONS)))
DEF)
(VARS (COND
((EQ (SETQ DEF (GETTOPVAL NAME))
(QUOTE NOBIND))
(GETDEFERR NAME TYPE OPTIONS))
(T DEF)))
[RECORDS (* always copy because of consequences of not doing so)
(COND
((SETQ DEF (RECLOOK NAME))
(SETQ NOCOPY T) (* Don't copy twice)
(SETQ DEF (COPY DEF)))
(T (GETDEFERR NAME TYPE OPTIONS]
[FILES (* what is the "definition" of a file? -- I guess the
COMS which say what it contains)
(UPDATEFILES)
(PROG (COMPLETENAME)
(RETURN (LIST (OR [AND (SETQ COMPLETENAME (GETFILEDEF NAME))
(LISTP (GETTOPVAL (FILECOMS COMPLETENAME]
(RETURN (GETDEFERR NAME TYPE OPTIONS)))
(fetch TOBEDUMPED of (fetch FILEPROP of COMPLETENAME))
(LISTP (fetch FILEDATES of COMPLETENAME]
[FIELDS (COND
((SETQ DEF (FIELDLOOK NAME))
(SETQ NOCOPY T)
(MKPROGN (COPY DEF)))
(T (GETDEFERR NAME TYPE OPTIONS]
[TEMPLATES (LIST (QUOTE SETTEMPLATE)
(KWOTE NAME)
(KWOTE (OR (GETTEMPLATE NAME)
(RETURN (GETDEFERR NAME TYPE OPTIONS]
[MACROS (CONS (QUOTE PUTPROPS)
(CONS NAME (OR (for X on (GETPROPLIST NAME) by (CDDR X)
when (FMEMB (CAR X)
MACROPROPS)
join (LIST (CAR X)
(CADR X)))
(RETURN (GETDEFERR NAME TYPE OPTIONS]
(ADVISE (OR (GETPROP NAME (QUOTE ADVICE))
(CDR (GETPROP NAME (QUOTE READVICE)))
(GETDEFERR NAME TYPE OPTIONS)))
(EXPRESSIONS NAME)
[PROPS (LIST (QUOTE PUTPROPS)
(CAR NAME)
(CADR NAME)
(CADR (OR (SOME (GETPROPLIST (CAR NAME))
[FUNCTION (LAMBDA (X)
(EQ X (CADR NAME]
(FUNCTION CDDR))
(RETURN (GETDEFERR NAME TYPE OPTIONS]
[FILEPKGCOMS (PROG ((COM (FILEPKGCOM NAME))
(TYP (FILEPKGTYPE NAME)))
(RETURN (COND
((AND COM TYP)
(LIST (CONS (QUOTE COM)
COM)
(CONS (QUOTE TYPE)
TYP)))
(COM (LIST (CONS (QUOTE COM)
COM)))
(TYP (LIST (CONS (QUOTE TYPE)
TYP]
[FILEVARS (COND
((AND (LISTP (SETQ DEF (GETTOPVAL NAME)))
(WHEREIS NAME (QUOTE FILEVARS)))
DEF)
(T (GETDEFERR NAME TYPE OPTIONS]
(PROG [FILE (COMS (LIST (MAKENEWCOM NAME TYPE]
[COND
((NOT (SETQ DEF (GETDEFCOM COMS)))
(RESETLST (RESETSAVE PRETTYFLG)
(RESETSAVE FONTCHANGEFLG)
(RESETSAVE BUILDMAPFLG)
[RESETSAVE (PRETTYDEF NIL (SETQ FILE
(OPENFILE (SELECTQ
(SYSTEMTYPE)
(D (QUOTE
{CORE}FILEPKG.SCRATCH))
(QUOTE FILEPKG.SCRATCH;T))
(QUOTE OUTPUT)))
COMS)
(QUOTE (PROGN (CLOSEF? OLDVALUE)
(DELFILE OLDVALUE]
(CLOSEF? FILE)
[SETQ DEF
(for X in (READFILE FILE)
join (SELECTQ (CAR X)
((PRETTYCOMPRINT FILEMAP *)
NIL)
(DECLARE:
(for Y on (CDR X)
unless (SELECTQ (CAR Y)
((COPYWHEN
EVAL@LOADWHEN
EVAL@COMPILEWHEN)
(RETURN
(LIST Y)))
(FMEMB (CAR Y)
DECLARETAGSLST))
collect (CAR Y)))
(PROGN (CDR X))
(LIST X]
(SETQ NOCOPY T))
(OR DEF (RETURN (GETDEFERR NAME TYPE OPTIONS]
(RETURN (MKPROGN DEF])
(GETDEFERR
[LAMBDA (NAME TYPE OPTIONS MSG) (* rmk: "13-JUL-83 03:01")
(DECLARE (USEDFREE NODEF)) (* Message non-null if looking for saved or filed
definition.)
(PROG (TEM)
(RETURN (COND
((AND (EQMEMB (QUOTE NOERROR)
OPTIONS)
(NOT (EQMEMB (QUOTE HASDEF)
OPTIONS))) (* We want to do the string search in the HASDEF case)
(SETQ NODEF T) (* Return the null definition--NIL or NOBIND)
(AND (EQ TYPE (QUOTE VARS))
(QUOTE NOBIND)))
[(AND (NULL MSG)
(EQMEMB (QUOTE SPELL)
OPTIONS)
(SETQ TEM (HASDEF NAME TYPE NIL (OR (LISTGET1 (LISTP OPTIONS)
(QUOTE SPELL))
T)))
(NEQ TEM NAME))
(RETFROM (QUOTE GETDEF)
(GETDEF TEM TYPE (QUOTE ?)
(CONS (QUOTE NOERROR)
(MKLIST OPTIONS]
(T (for O inside OPTIONS when (STRINGP O) do (RETFROM (QUOTE GETDEF)
O)
finally (ERROR NAME (CONS TYPE (QUOTE (definition not found)))
T])
(GETDEFFROMFILE
[LAMBDA (NAME TYPE SOURCE OPTIONS) (* rmk: " 3-AUG-83 22:07")
(* Tries to get definition from source file.
If successful, returns the definition.
Otherwise returns NIL or NOBIND if OPTIONS contains
NOERROR.)
(DECLARE (SPECVARS NAME)
(USEDFREE NODEF))
(RESETVARS (NOT-FOUNDTAG)
(RETURN
(for FILE DEF TEM TEM2 inside (COND
((EQ SOURCE (QUOTE FILE))
(WHEREIS NAME TYPE T))
(T SOURCE))
when
[AND
(SETQ TEM (OR (AND (FMEMB FILE FILELST)
[SETQ TEM (fetch DATEFILENAME
of (CAR (LISTP (fetch FILEDATES of FILE]
(INFILEP TEM))
(FINDFILE FILE T)))
(COND
((SETQ TEM2 (fetch FILEGETDEF of TYPE))
(SETQ DEF (APPLY* TEM2 NAME TYPE TEM OPTIONS)))
(T
(SELECTQ
TYPE
[FNS (SETQ DEF (COND
[[AND (EQMEMB (QUOTE FAST)
OPTIONS)
(EQ TEM (CAR (SETQ TEM2 (fetch FILEMAP of FILE]
(for PAIR TEM3 in (CDADR TEM2)
when [SETQ TEM3 (CADR (ASSOC NAME (CDDR PAIR]
do [OR (OPENP TEM)
(RESETSAVE NIL (LIST (QUOTE CLOSEF?)
(INPUT (INFILE TEM]
(SETFILEPTR TEM TEM3)
(RETURN (COND
((EQMEMB (QUOTE ARGLIST)
OPTIONS)
(RATOM TEM FILERDTBL)
(READ TEM FILERDTBL)
(RATOM TEM FILERDTBL)
(LIST (READ TEM FILERDTBL)
(READ TEM FILERDTBL)))
(T (CADR (READ TEM FILERDTBL]
(T (CADR (FASSOC NAME (LOADEFS NAME TEM]
((VARS FILEVARS)
(for X in (LOADFNS NIL TEM (QUOTE GETDEF)
NAME)
do (SELECTQ (CAR X)
((RPAQQ SETQQ)
(SETQ DEF (CADDR X))
(RETURN T))
((RPAQ SETQ RPAQ?)
(SETQ DEF (EVAL (CADDR X)))
(RETURN T))
NIL)))
[MACROS (for X in [LOADFNS NIL TEM (QUOTE GETDEF)
(QUOTE (LAMBDA (FIRST SECOND)
(AND (EQ FIRST (QUOTE PUTPROPS)
)
(EQ SECOND NAME]
join (for TAIL on (CDDR X) by (CDDR TAIL)
when (FMEMB (CAR TAIL)
MACROPROPS)
join (LIST (CAR TAIL)
(CADR TAIL)))
finally (RETURN (AND $$VAL (SETQ DEF (CONS (QUOTE PUTPROPS)
(CONS NAME $$VAL]
[PROPS (for X in [LOADFNS NIL TEM (QUOTE GETDEF)
(QUOTE (LAMBDA (FIRST SECOND)
(AND (EQ FIRST (QUOTE PUTPROPS))
(EQ SECOND (CAR NAME]
join (for TAIL on (CDDR X) by (CDDR TAIL)
when (EQ (CAR TAIL)
(CADR NAME))
join (LIST (CAR TAIL)
(CADR TAIL)))
finally (RETURN (AND $$VAL (SETQ DEF
(CONS (QUOTE PUTPROPS)
(CONS (CAR NAME)
$$VAL]
[RECORDS
(SETQ DEF
(MKPROGN
(LOADFNS NIL TEM (QUOTE GETDEF)
(QUOTE (LAMBDA
(FIRST SECOND)
(AND (MEMB FIRST CLISPRECORDTYPES)
(OR (EQ SECOND NAME)
(AND (MEMB SECOND (QUOTE (%( %[)))
(PROGN (RATOM)
(RATOM)
(RATOM)
(EQ NAME (RATOM]
[ALISTS (for X in [LOADFNS NIL TEM (QUOTE GETDEF)
(QUOTE (LAMBDA (FIRST SECOND)
(AND (EQ FIRST (QUOTE ADDTOVAR)
)
(EQ SECOND (CAR NAME]
when (SETQ X (ASSOC (CADR NAME)
(CDDR X)))
collect X finally (RETURN
(AND $$VAL (SETQ DEF
(CONS (QUOTE ADDTOVAR)
(CONS (CAR NAME)
$$VAL]
[LISPXMACROS
(SETQ DEF
(MKPROGN (for X
in [LOADFNS NIL TEM (QUOTE GETDEF)
(QUOTE (LAMBDA
(FIRST SECOND)
(AND (EQ FIRST (QUOTE ADDTOVAR))
(MEMB SECOND
(QUOTE (LISPXMACROS
LISPXCOMS)))
T]
when (SELECTQ (CADR X)
[LISPXMACROS
(* Rebuild the expressions cause there might be other
elements in the ADDTOVAR)
(AND (SETQ X
(ASSOC NAME
(CDDR X)))
(SETQ X
(LIST (QUOTE ADDTOVAR)
(QUOTE
LISPXMACROS)
X]
[LISPXCOMS (COND
((MEMB NAME (CDDR X))
(SETQ X
(LIST (QUOTE ADDTOVAR)
(QUOTE LISPXCOMS)
NAME)))
((SETQ X (ASSOC NAME
(CDDR X)))
(* For synonym pairs)
(SETQ X
(LIST (QUOTE ADDTOVAR)
(QUOTE LISPXCOMS)
X]
NIL)
collect X]
(RESETLST (RESETSAVE (RESETUNDO))
[RESETVARS (PRETTYHEADER)
(LOADFNS NIL TEM T (COND
((LITATOM NAME)
(* If an atom, only bother with expressions that contain
it)
(CONS (LIST (QUOTE &)
(QUOTE ..)
NAME)))
(T T]
[SETQ DEF (GETDEFCURRENT NAME TYPE (CONS (QUOTE NOERROR)
(MKLIST OPTIONS]
(PROG1 (NULL NODEF)
(SETQ NODEF NIL]
do (AND (EQ SOURCE (QUOTE FILE))
(OR (FMEMB FILE FILELST)
(PRINT (LIST (QUOTE from)
TEM)
T T))) (* Copying and dwimifying are done in GETDEF)
(RETURN DEF)
finally (RETURN (GETDEFERR NAME TYPE OPTIONS (APPEND (QUOTE (no definition on))
(MKLIST SOURCE])
(GETDEFSAVED
[LAMBDA (NAME TYPE OPTIONS) (* rmk: "14-JAN-81 22:58")
(* Gets the "saved" definition--source=T)
(SELECTQ TYPE
(FNS (OR (GETPROP NAME (QUOTE EXPR))
(GETDEFERR NAME TYPE OPTIONS "no saved definition for")))
[VARS (* The value of a variable is never substituted into and
never COPIED)
(for X on (GETPROPLIST NAME) by (CDDR X) when (EQ (CAR X)
(QUOTE VALUE))
do (RETURN (CADR X)) finally (RETURN (GETDEFERR NAME TYPE OPTIONS
"no saved value for "]
(CDR (OR (SASSOC NAME (FASSOC TYPE SAVEDDEFS))
(GETDEFERR NAME TYPE OPTIONS "no saved definition for "])
(PUTDEF
(LAMBDA (NAME TYPE DEFINITION) (* JonL "24-Jul-84 17:58")
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(PROG (TEM)
(COND
((SETQ TEM (fetch PUTDEF of TYPE))
(APPLY* TEM NAME TYPE DEFINITION))
(T (SELECTQ TYPE
(FNS (DEFINE (LIST (LIST NAME DEFINITION))))
(VARS (SAVESET NAME DEFINITION T))
(FILES (PUTDEF (FILECOMS NAME)
(QUOTE VARS)
(CAR DEFINITION)) (* DEFINE THE COMS)
(ADDFILE NAME) (* MAKE SURE IT IS A FILE PACKAGE ENTITY)
(change (fetch TOBEDUMPED of (fetch FILEPROP of NAME))
(FILEPKG.MERGECHANGES (CADR DEFINITION)
DATUM))
(OR (fetch FILEDATES of NAME)
(replace FILEDATES of NAME with (CADDR DEFINITION))))
(ADVISE (PROG (TEM)
(/PUT NAME (QUOTE READVICE)
(CONS (COND
((SETQ TEM (STRPOS "-IN-" NAME))
(CONS (SUBATOM NAME 1 (SUB1 TEM))
(SUBATOM NAME (IPLUS TEM 4)
-1))))
DEFINITION)))
(APPLY* (QUOTE READVISE)
NAME))
(FILEPKGCOMS (PROG (COM TYP)
(SELECTQ (CAR (LISTP DEFINITION))
(COM (SETQ COM (CDR DEFINITION)))
(TYPE (SETQ TYP (CDR DEFINITION)))
(PROGN (SETQ COM (CDR (ASSOC (QUOTE COM)
DEFINITION)))
(SETQ TYP (CDR (ASSOC (QUOTE TYPE)
DEFINITION)))))
(* Check properties first, so that we don't smash some
and then get an error in a later call to
FILEPKGCOM/TYPE)
(for I in COM by (CDDR I)
do (SELECTQ I
((ADD DELETE MACRO CONTENTS CONTAIN COM))
(ERROR I
"not file package command property")))
(* COM merely adds to spelling list, for builtins)
(FILEPKGCOM NAME (QUOTE CONTENTS)
(OR (LISTGET COM (QUOTE CONTENTS))
(LISTGET COM (QUOTE CONTAIN))))
(* Until CONTAIN is de-documented.)
(for PROP in (QUOTE (ADD DELETE MACRO COM))
do (FILEPKGCOM NAME PROP (LISTGET COM PROP)))
(for I in TYP by (CDDR I)
do (SELECTQ I
((DESCRIPTION WHENCHANGED WHENFILED
WHENUNFILED NEWCOM GETDEF
FILEGETDEF PUTDEF EDITDEF
DELDEF TYPE))
(ERROR I
"not file package type/command property")))
(* TYPE merely adds to spelling list, for builtins)
(for PROP
in (QUOTE (DESCRIPTION WHENCHANGED WHENFILED
WHENUNFILED NEWCOM GETDEF
FILEGETDEF PUTDEF EDITDEF DELDEF
TYPE))
do (FILEPKGTYPE NAME PROP (LISTGET TYP PROP)))))
(EVAL DEFINITION)))))
NAME))
(EDITDEF
[LAMBDA (NAME TYPE SOURCE EDITCOMS) (* rmk: "13-JUL-83 03:02")
(DECLARE (SPECVARS SOURCE))
(* lets you edit anything. Given name and type, call editor on the definition (loading it in from SOURCE if
necessary). If you change it, then the definition gets "unsaved")
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(OR SOURCE (SETQQ SOURCE ?))
[COND
((AND (EQ TYPE (QUOTE FNS))
(EQ SOURCE (QUOTE ?))
EDITLOADFNSFLG
(WHEREIS NAME TYPE))
(APPLY (FUNCTION EDITF)
(CONS NAME EDITCOMS)))
(T (PROG ((DEF (GETDEF NAME TYPE SOURCE (QUOTE NOCOPY)))
RETRY)
LP (SETQ RETRY)
[EDITE DEF EDITCOMS NAME TYPE
(FUNCTION (LAMBDA (NAME DEF TYPE EXITFLG)
(PROG ((OLDDEF (GETDEF NAME TYPE (QUOTE CURRENT)
0))) (* this function is called when there were changes made)
(MARKASCHANGED NAME TYPE)
(COND
[EXITFLG (* exited with OK)
(RESETVARS ((DFNFLG T))
(* rebind DFNFLG to T because we do not want to warn the user (he knows that the thing got edited, since the exit
was a normal one))
(COND
((NEQ (EQUALN DEF OLDDEF 1000)
T)
(* not sure the definitions are identical)
(SELECTQ SOURCE
((? 0))
(printout T "unsaved" T))
(SAVEDEF NAME TYPE OLDDEF)
(* save old definition)
(OR (ERSETQ (PUTDEF NAME TYPE DEF))
(SETQ RETRY T]
(T (* abnormal exit, but changes made;
save the definition but don't PUTDEF it.
Don't warn user about unsaving if the definitions are
equal)
(OR (EQ T (EQUALN DEF OLDDEF 1000))
(printout T NAME " definition as " TYPE " not changed." T))
(SAVEDEF NAME TYPE DEF]
(COND
(RETRY (SETQ EDITCOMS)
(GO LP]
NAME])
(LOADDEF
[LAMBDA (NAME TYPE SOURCE) (* lmm "13-SEP-78 01:34")
(PUTDEF NAME TYPE (GETDEF NAME TYPE SOURCE (QUOTE (NODWIM NOCOPY])
(DWIMDEF
[LAMBDA (DEF FN SOURCE) (* rmk: "13-JUL-83 02:59")
(AND [OR (EQ DWIMIFYCOMPFLG T)
(EQ CLISPIFYPRETTYFLG T)
(EQ (CAR (CADDR DEF))
(QUOTE CLISP:))
(SELECTQ SOURCE
((CURRENT SAVED FILE ?)
NIL)
(AND (LITATOM SOURCE)
(EQMEMB (QUOTE CLISP)
(GETPROP SOURCE (QUOTE FILETYPE]
(RESETVARS ((NOSPELLFLG T)
(DWIMESSGAG T)
FILEPKGFLG)
(PROG (LISPXHIST)
(DWIMIFY0 DEF (COND
((OR (LISTP FN)
(NULL FN))
(QUOTE ?))
(T FN))
NIL DEF])
(DELDEF
(LAMBDA (NAME TYPE) (* JonL "24-Jul-84 20:05")
(PROG (TEM)
(SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
LP (COND
((SETQ TEM (fetch DELDEF of TYPE))
(APPLY* TEM NAME TYPE))
(T (SELECTQ TYPE
(FNS (* special because GETDEF of a FNS is only its EXPR
definitio, and DELDEF should only remove such)
(AND (EXPRP NAME)
(/PUTD NAME))
(REMPROP NAME (QUOTE EXPR))
(AND MSDATABASELST (MASTERSCOPE (LIST (QUOTE ERASE)
(KWOTE NAME)))))
(VARS (/SETTOPVAL NAME (QUOTE NOBIND)))
(FILES (for LST in (QUOTE (FILELST NOTCOMPILEDFILES NOTLISTEDFILES))
do (/SETTOPVAL LST (REMOVE NAME (GETTOPVAL LST))))
(/replace FILEPROP of NAME with NIL)
(/replace FILECHANGES of NAME with NIL)
(/replace FILEMAP of NAME with NIL)
(/replace FILEDATES of NAME with NIL))
(RECORDS (APPLY* (QUOTE EDITREC)
NIL
(LIST (QUOTE DELETE)
(LIST (QUOTE F)
(RECLOOK NAME NIL NIL NIL T)))))
(FIELDS (APPLY (FUNCTION PROGN)
(SUBST NIL NAME (FIELDLOOK NAME))))
(FILEPKGCOMS (DELFROMLIST (QUOTE FILEPKGCOMSPLST)
NAME)
(DELFROMLIST (QUOTE FILEPKGTYPES)
NAME)
(for FIELD on (FILEPKGCOM NAME) by (CDDR FIELD)
do (FILEPKGCOM NAME (CAR FIELD)
NIL))
(for FIELD on (FILEPKGTYPE NAME) by (CDDR FIELD)
do (FILEPKGTYPE NAME (CAR FIELD)
NIL))
(/replace ALLFIELDS of NAME with NIL))
(ALISTS (AND (LISTP NAME)
(DELFROMLIST (CAR NAME)
(FASSOC (CADR NAME)
(GETTOPVAL (CAR NAME))))))
(MACROS (for P in MACROPROPS do (/REMPROP NAME P)))
(PROPS (AND (LISTP NAME)
(/REMPROP (CAR NAME)
(CADR NAME))))
(LISPXMACROS (DELFROMLIST (QUOTE LISPXMACROS)
(FASSOC NAME LISPXMACROS))
(DELFROMLIST (QUOTE LISPXHISTORYMACROS)
(FASSOC NAME LISPXHISTORYMACROS))
(DELFROMLIST (QUOTE LISPXCOMS)
NAME)
(DELFROMLIST (QUOTE HISTORYCOMS)
NAME))
(PRIN1 (LIST "Note: deleting" TYPE "not implemented yet")
T))))
(MARKASCHANGED NAME TYPE (QUOTE DELETED))
(RETURN NAME))))
(DELFROMLIST
[LAMBDA (VAR VAL) (* rmk: " 3-JAN-82 23:22")
(AND (FMEMB VAL (GETTOPVAL VAR))
(/SETTOPVAL VAR (SUBSET (GETTOPVAL VAR)
(FUNCTION (LAMBDA (X)
(AND (NEQ X VAL)
(OR (NLISTP X)
(NEQ (CDR X)
VAL])
(HASDEF
[LAMBDA (NAME TYPE SOURCE SPELLFLG) (* lmm "27-Aug-84 23:51")
(* is NAME the name of something of type TYPE? NIL
SOURCE means 0, not ?)
(DECLARE (SPECVARS TYPE))
(if [OR (LISTP TYPE)
(LISTP (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE]
then (* ignore SPELLFLG)
(for TY in TYPE do (AND (SETQ $$VAL (HASDEF NAME TY SOURCE))
(RETURN $$VAL)))
else
(PROG [NODEF (OPTS (QUOTE ("no def" NODWIM NOCOPY NOERROR HASDEF]
(SETQ NODEF (CAR OPTS))
(OR SOURCE (SETQQ SOURCE CURRENT))
(RETURN
(SELECTQ SOURCE
[(CURRENT 0)
(COND
([OR (MEMBER NAME (fetch CHANGED of TYPE))
(COND
[(LISTP NAME)
(SELECTQ TYPE
(PROPS (GETPROP (CAR NAME)
(CADR NAME)))
((FILES TEMPLATES MACROS LISPXMACROS VARS I.S.OPRS FNS
FIELDS USERMACROS ADVICE FILEVARS FILEPKGCOMS)
NIL)
(NEQ NODEF (GETDEF NAME TYPE (QUOTE CURRENT)
OPTS]
(T (SELECTQ TYPE
(FILES (* if NAME is FOO, look for FOO.LSP on FILELST)
(GETFILEDEF NAME))
(TEMPLATES (GETTEMPLATE NAME))
(MACROS (GETLIS NAME MACROPROPS))
(LISPXMACROS (OR (FASSOC NAME LISPXMACROS)
(FASSOC NAME LISPXHISTORYMACROS)))
(VARS (NEQ (GETTOPVAL NAME)
(QUOTE NOBIND)))
(RECORDS (RECLOOK NAME))
[I.S.OPRS (PROG [(TEM (GETPROP NAME (QUOTE CLISPWORD]
(RETURN (AND TEM (EQ (CAR TEM)
(QUOTE FORWORD))
(GETPROP (CDR TEM)
(QUOTE I.S.OPR]
[FNS (AND (GETD NAME)
(EXPRP (GETD NAME]
(FIELDS (RECORDFIELD? NAME))
(USERMACROS (FASSOC NAME USERMACROS))
[ADVICE (GETLIS NAME (QUOTE (ADVICE READVICE]
(FILEVARS)
((PROPS ALISTS DEFS EXPRESSIONS)
NIL)
(FILEPKGCOMS (OR (FMEMB NAME FILEPKGCOMSPLST)
(FMEMB NAME FILEPKGTYPES)))
(NEQ NODEF (GETDEF NAME TYPE (QUOTE CURRENT)
OPTS]
(OR NAME T))
(SPELLFLG (SELECTQ TYPE
((ALISTS PROPS)
(ERROR NAME "?"))
(FIXSPELL NAME NIL
(SELECTQ
TYPE
(FILES FILELST)
(FILEPKGCOMS (UNION FILEPKGCOMSPLST
FILEPKGTYPES))
[FIELDS (for X in USERRECLST
join (APPEND (RECORDFIELDNAMES
X]
(RECORDS (for X in USERRECLST
when (LITATOM (CADR X))
collect (CADR X)))
(LISPXMACROS LISPXCOMS)
(I.S.OPRS I.S.OPRLST)
(USERMACROS (MAPCAR
USERMACROS
(FUNCTION CAR)))
USERWORDS)
NIL
(LISTP SPELLFLG)
[FUNCTION (LAMBDA (X)
(HASDEF X TYPE (QUOTE CURRENT]
NIL T]
[? (OR (HASDEF NAME TYPE (QUOTE CURRENT)
SPELLFLG)
(HASDEF NAME TYPE (QUOTE SAVED))
(AND (EQ TYPE (QUOTE FNS))
(WHEREIS NAME TYPE T]
((SAVED T)
(NEQ NODEF (GETDEF NAME TYPE (QUOTE SAVED)
OPTS)))
(NEQ NODEF (GETDEF NAME TYPE SOURCE OPTS])
(GETFILEDEF
[LAMBDA (FILENAME) (* rrb "22-Mar-84 11:40")
(* returns the official file name from a file name if
NAME is FOO, look for FOO.LSP on FILELST)
(OR (CAR (FMEMB FILENAME FILELST))
(for FILE in FILELST when (STRPOS FILENAME FILE 1 NIL T)
do (COND
((EQ (FILENAMEFIELD FILE (QUOTE NAME))
FILENAME)
(RETURN FILE])
(SAVEDEF
(LAMBDA (NAME TYPE DEFINITION) (* JonL "24-Jul-84 20:11")
(COND
((AND (LISTP NAME)
(NULL TYPE))
(MAPCAR NAME (FUNCTION (LAMBDA (I)
(SAVEDEF I (QUOTE FNS))))))
(T (SELECTQ (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(FNS (AND (OR DEFINITION (SETQ DEFINITION (GETD NAME)))
(/PUT NAME (SETQ TYPE (COND
((SUBRP DEFINITION)
(QUOTE SUBR))
((EXPRP DEFINITION)
(QUOTE EXPR))
((CCODEP DEFINITION)
(QUOTE CODE))
(T (QUOTE LIST))))
DEFINITION)))
(VARS (AND (NEQ (OR DEFINITION (SETQ DEFINITION (GETTOPVAL NAME)))
(QUOTE NOBIND))
(EQ DEFINITION (GETTOPVAL NAME))
(/PUT NAME (SETQ TYPE (QUOTE VALUE))
DEFINITION)))
(AND (OR DEFINITION (SETQ DEFINITION (GETDEF NAME TYPE (QUOTE CURRENT)
(QUOTE (NOCOPY NOERROR NODWIM)))))
(/PUTASSOC NAME DEFINITION (OR (CDR (FASSOC TYPE SAVEDDEFS))
(CAR (SETQ SAVEDDEFS
(CONS (LIST TYPE (CONS NAME))
SAVEDDEFS)))))))
TYPE))))
(UNSAVEDEF
(LAMBDA (NAME TYPE DEF) (* JonL "24-Jul-84 20:11")
(SELECTQ TYPE
((NIL EXPR CODE SUBR LIST)
(COND
((LISTP NAME) (* for compatibility)
(MAPCAR NAME (FUNCTION (LAMBDA (X)
(UNSAVED1 X TYPE)))))
(T (UNSAVED1 NAME TYPE))))
(PROG NIL
(OR DEF (SETQ DEF (GETDEF NAME (SETQ TYPE (GETFILEPKGTYPE TYPE (QUOTE TYPE)))
(QUOTE SAVED)
0))
(RETURN (CONS TYPE (QUOTE (not found)))))
(OR (EQ DFNFLG T)
(SAVEDEF NAME TYPE))
(RESETVARS ((DFNFLG T))
(PUTDEF NAME TYPE DEF))
(RETURN TYPE)))))
(COMPAREDEFS
[LAMBDA (NAME TYPE SOURCES) (* rmk: "19-FEB-83 14:06")
(COND
((AND (LISTP TYPE)
(GETFILEPKGTYPE SOURCES NIL T))
(swap TYPE SOURCES)))
(PROG (DEF DEFS)
[COND
((NULL SOURCES)
(SETQ SOURCES (WHEREIS NAME TYPE T))
(AND [OR (MEMBER NAME (FILEPKGCHANGES TYPE))
(SOME SOURCES (FUNCTION (LAMBDA (FILE)
(MEMBER NAME (fetch TOBEDUMPED of (fetch FILEPROP of FILE]
(push SOURCES NIL]
[COND
[(NULL SOURCES)
(RETURN (QUOTE (not found]
((NULL (CDR SOURCES))
(RETURN (QUOTE (one only]
[for SRC in SOURCES do (AND [SETQ DEF (GETDEF NAME TYPE SRC (QUOTE (NOERROR NOCOPY]
(OR [SOME DEFS (FUNCTION (LAMBDA (DP)
(COMPARELST DEF (CDR DP]
(push DEFS (CONS SRC DEF]
(RETURN (COND
((CDR DEFS)
[for S1 on (DREVERSE DEFS) do (for S2 on (CDR S1)
do (PRIN2 NAME T T)
(AND (CAAR S1)
(PRIN1 " from " T)
(PRIN2 (CAAR S1)
T T))
(PRIN1 " and " T)
(PRIN2 NAME T T)
(COND
((CAAR S2)
(PRIN1 " from " T)
(PRIN2 (CAAR S2)
T T)))
(PRIN1 " differ:" T)
(TERPRI T)
(COMPARELISTS (CDAR S1)
(CDAR S2]
(QUOTE DIFFERENT))
(T (QUOTE SAME])
(COMPARE
[LAMBDA (NAME1 NAME2 TYPE SOURCE1 SOURCE2) (* lmm " 5-SEP-78 13:37")
(PROG [[DEF1 (GETDEF NAME1 TYPE SOURCE1 (QUOTE (NOERROR NOCOPY]
(DEF2 (GETDEF NAME2 TYPE SOURCE2 (QUOTE (NOERROR NOCOPY]
(COND
((COMPARELST DEF1 DEF2)
(RETURN)))
(PRIN2 NAME1 T T)
(COND
(SOURCE1 (PRIN1 " from " T)
(PRIN2 SOURCE1 T T)))
(PRIN1 " and " T)
(PRIN2 NAME2 T T)
(COND
(SOURCE2 (PRIN1 " from " T)
(PRIN2 SOURCE2 T T)))
(PRIN1 " differ:" T)
(TERPRI T)
(COMPARELISTS DEF1 DEF2)
(RETURN T])
(TYPESOF
[LAMBDA (NAME POSSIBLETYPES IMPOSSIBLETYPES SOURCE) (* bvm: "28-Mar-84 14:36")
(* return list of all known types which NAME names)
(for TYPE inside (OR POSSIBLETYPES FILEPKGTYPES) when (AND (LITATOM TYPE)
(NOT (EQMEMB TYPE IMPOSSIBLETYPES))
(HASDEF NAME TYPE SOURCE))
collect TYPE])
)
(* Must come after PUTDEF)
(* *
"how to dump FILEPKGCOMS. The SPLST must be initialized to contain FILEPKGCOMS
in order to get started.")
(DEFINEQ
(FILEPKGCOM
(LAMBDA N (* JonL "10-Jul-84 19:38")
(PROG (TEM (COM (ARG N 1)))
(RETURN (COND
((EQ N 1)
(OR (for FIELD in (QUOTE (MACRO CONTENTS DELETE ADD))
when (SETQ TEM (FILEPKGCOM COM FIELD)) join (LIST FIELD TEM))
(AND (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))
(LIST (QUOTE COM)
T))
(AND (SETQ TEM (CDR (ASSOC COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))))
(LIST (QUOTE COM)
TEM))))
((EQ N 2)
(SELECTQ
(ARG N 2)
(ADD (fetch ADD of COM))
(DELETE (fetch DELETE of COM))
(MACRO (fetch MACRO of COM))
((CONTENTS CONTAIN)
(OR (fetch (FILEPKGCOM CONTENTS) of COM)
(COND
((SETQ COM (fetch (FILEPKGCOM PRETTYTYPE) of COM))
(COND
((EQ COM (QUOTE NILL))
COM)
((EQ (CAR COM)
(QUOTE LAMBDA))
(CONS (CAR COM)
(CONS (CONS (CAADR COM)
(CONS (OR (CADDR (CADR COM))
(QUOTE NAME))
(CONS (CADR (CADR COM))
(CDDDR (CADR COM)))))
(SUBST (QUOTE INFILECOMTAIL)
(QUOTE PRETTYCOM1)
(CDDR COM)))))
(T (LIST (QUOTE LAMBDA)
(QUOTE (COM TYPE NAME))
(CONS COM (QUOTE (COM TYPE NAME))))))))))
(COM (OR (AND (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))
T)
(CDR (ASSOC COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))))))
(ERROR (ARG N 2)
"not file package command property")))
(T (for I TEM2 from 2 to N by 2
do (SETQ TEM (ARG N (ADD1 I)))
(COND
((EQ (ARG N I)
(QUOTE COM))
(SELECTQ TEM
(NIL)
(T (OR (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))
(/SETTOPVAL (QUOTE FILEPKGCOMSPLST)
(CONS COM (GETTOPVAL (QUOTE
FILEPKGCOMSPLST)))))
)
(COND
((SETQ TEM2 (ASSOC COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST))
))
(/RPLACD TEM2 TEM))
(T (/SETTOPVAL (QUOTE FILEPKGCOMSPLST)
(CONS (CONS COM TEM)
(GETTOPVAL (QUOTE FILEPKGCOMSPLST))))
))))
(T (AND TEM (OR (FMEMB COM (GETTOPVAL (QUOTE FILEPKGCOMSPLST)))
(/SETTOPVAL (QUOTE FILEPKGCOMSPLST)
(CONS COM (GETTOPVAL (QUOTE
FILEPKGCOMSPLST)))))
)
(SELECTQ (ARG N I)
(ADD (/replace (FILEPKGCOM ADD) of COM with TEM))
(DELETE (/replace (FILEPKGCOM DELETE) of COM with TEM))
(MACRO (/replace (FILEPKGCOM MACRO) of COM with TEM))
((CONTENTS CONTAIN)
(/replace (FILEPKGCOM CONTENTS) of COM with TEM))
(ERROR (ARG N I)
"not file package command property")))))
(MARKASCHANGED COM (QUOTE FILEPKGCOMS))))))))
(FILEPKGTYPE
[LAMBDA N (* rmk: "19-FEB-82 13:28")
(PROG ((TYPE (ARG N 1))
TEM)
(RETURN (COND
[(EQ N 1)
(OR (for FIELD
in (QUOTE (DESCRIPTION WHENCHANGED WHENFILED WHENUNFILED NEWCOM GETDEF
FILEGETDEF PUTDEF EDITDEF DELDEF))
when (SETQ TEM (FILEPKGTYPE TYPE FIELD)) join (LIST FIELD TEM))
(AND (FMEMB TYPE (GETTOPVAL (QUOTE FILEPKGTYPES)))
(LIST (QUOTE TYPE)
T))
(AND [SETQ TEM (CDR (ASSOC TYPE (GETTOPVAL (QUOTE FILEPKGTYPES]
(LIST (QUOTE TYPE)
TEM]
((EQ N 2)
(SELECTQ (ARG N 2)
(DESCRIPTION (fetch DESCRIPTION of TYPE))
(WHENCHANGED (fetch WHENCHANGED of TYPE))
(WHENFILED (fetch WHENFILED of TYPE))
(WHENUNFILED (fetch WHENUNFILED of TYPE))
(NEWCOM (fetch NEWCOM of TYPE))
(GETDEF (fetch GETDEF of TYPE))
(FILEGETDEF (fetch FILEGETDEF of TYPE))
(PUTDEF (fetch PUTDEF of TYPE))
(DELDEF (fetch DELDEF of TYPE))
(EDITDEF (fetch EDITDEF of TYPE))
[TYPE (OR (AND (FMEMB TYPE (GETTOPVAL (QUOTE FILEPKGTYPES)))
T)
(CDR (ASSOC TYPE (GETTOPVAL (QUOTE FILEPKGTYPES]
(ERROR (ARG N 2)
"not file package type property")))
(T [for I TEM2 from 2 to N by 2
do (SETQ TEM (ARG N (ADD1 I)))
(COND
[(EQ (ARG N I)
(QUOTE TYPE))
(SELECTQ TEM
(NIL)
[T (OR (FMEMB TYPE (GETTOPVAL (QUOTE FILEPKGTYPES)))
(/SETTOPVAL (QUOTE FILEPKGTYPES)
(CONS TYPE (GETTOPVAL (QUOTE
FILEPKGTYPES]
(COND
([SETQ TEM2 (ASSOC TYPE (GETTOPVAL (QUOTE FILEPKGTYPES]
(/RPLACD TEM2 TEM))
(T (/SETTOPVAL (QUOTE FILEPKGTYPES)
(CONS (CONS TYPE TEM)
(GETTOPVAL (QUOTE FILEPKGTYPES]
(T [AND TEM (OR (FMEMB TYPE (GETTOPVAL (QUOTE FILEPKGTYPES)))
(/SETTOPVAL (QUOTE FILEPKGTYPES)
(CONS TYPE (GETTOPVAL (QUOTE FILEPKGTYPES]
(SELECTQ (ARG N I)
(DESCRIPTION (/replace DESCRIPTION of TYPE with TEM))
(WHENCHANGED (/replace WHENCHANGED of TYPE with TEM))
(WHENFILED (/replace WHENFILED of TYPE with TEM))
(WHENUNFILED (/replace WHENUNFILED of TYPE with TEM))
(NEWCOM (/replace NEWCOM of TYPE with TEM))
(GETDEF (/replace GETDEF of TYPE with TEM))
(FILEGETDEF (/replace FILEGETDEF of TYPE with TEM))
(PUTDEF (/replace PUTDEF of TYPE with TEM))
(DELDEF (/replace DELDEF of TYPE with TEM))
(EDITDEF (/replace EDITDEF of TYPE with TEM))
(ERROR (ARG N I)
"not file package command/type property"]
(MARKASCHANGED TYPE (QUOTE FILEPKGCOMS])
)
(PUTPROPS FILEPKGCOM ARGNAMES
(COMMANDNAME (KEYWORDS: MACRO ADD DELETE CONTENTS)))
(ADDTOVAR FILEPKGCOMSPLST FILEPKGCOMS)
(ADDTOVAR FILEPKGTYPES FILEPKGCOMS)
(PUTDEF (QUOTE FILEPKGCOMS) (QUOTE FILEPKGCOMS) (QUOTE ((COM CONTENTS (LAMBDA
(COM NAME TYPE)
(* Revert to NILL when no longer
coercing PRETTYDEFMACROS to
FILEPKGCOMS)
(AND (EQ TYPE (QUOTE FILEPKGCOMS))
(INFILECOMTAIL COM))))
(TYPE DESCRIPTION
"file package commands/types"
GETDEF T))))
(PUTDEF (QUOTE ADVICE) (QUOTE FILEPKGCOMS) (QUOTE ((COM COM T)
(TYPE DESCRIPTION "advice"))))
(PUTDEF (QUOTE ALISTS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (COMS * (MAKEALISTCOMS . X))))
(TYPE DESCRIPTION "alist entries" WHENCHANGED
(ALISTS.WHENCHANGED)))))
(PUTDEF (QUOTE DEFS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (COMS . X))))))
(PUTDEF (QUOTE EDITMACROS) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE TYPE USERMACROS))))
(PUTDEF (QUOTE EXPRESSIONS) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE DESCRIPTION "expressions" WHENCHANGED
(EXPRESSIONS.WHENCHANGED)
EDITDEF NILL))))
(PUTDEF (QUOTE FIELDS) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE EDITDEF NILL))))
(PUTDEF (QUOTE FILES) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (P * (CONS (MAKEFILESCOMS . X))))
CONTENTS
(LAMBDA (COM NAME TYPE)
(AND (EQ TYPE (QUOTE FILES))
(SUBSET (INFILECOMTAIL COM)
(FUNCTION LITATOM)))))
(TYPE EDITDEF NILL))))
(PUTDEF (QUOTE FILEPKGTYPES) (QUOTE FILEPKGCOMS) (QUOTE ((COM COM FILEPKGCOMS)
(TYPE TYPE FILEPKGCOMS))))
(PUTDEF (QUOTE FILEVARS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (VARS . X)))
(TYPE EDITDEF NILL))))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) (QUOTE ((COM COM T)
(TYPE DESCRIPTION "functions"))))
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) (QUOTE ((COM COM T))))
(PUTDEF (QUOTE INITRECORDS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (P * (RECORDALLOCATIONS . X)))
CONTENTS
(LAMBDA (COM NAME TYPE ONFILETYPE)
(AND (NULL ONFILETYPE)
(EQ TYPE (QUOTE RECORDS))
(INFILECOMTAIL COM)))))))
(PUTDEF (QUOTE LISPXCOMS) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE TYPE LISPXMACROS))))
(PUTDEF (QUOTE LISPXMACROS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (COMS * (MAKELISPXMACROSCOMS .
X)))
CONTENTS NILL)
(TYPE DESCRIPTION "LISPX commands"))))
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) (QUOTE
((COM
MACRO
(X
(DECLARE:
EVAL@COMPILE
(PROPS
*
(MAPCAR (QUOTE X)
(FUNCTION
(LAMBDA
(Y)
(CONS Y (OR (INTERSECTION
(PROPNAMES Y)
MACROPROPS)
(CAR MACROPROPS)))))))))
)
(TYPE DESCRIPTION "compiler macros" WHENCHANGED
(CLEARCLISPARRAY)
EDITDEF NILL))))
(PUTDEF (QUOTE PRETTYDEFMACROS) (QUOTE FILEPKGCOMS) (QUOTE ((COM COM FILEPKGCOMS))))
(PUTDEF (QUOTE PROPS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (COMS * (MAKEPROPSCOMS . X))))
(TYPE DESCRIPTION "property lists" WHENCHANGED
(PROPS.WHENCHANGED)))))
(PUTDEF (QUOTE RECORDS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (RECORDECLARATIONS . X))
(INITRECORDS . X))
CONTENTS
(LAMBDA
(COM NAME TYPE ONFILETYPE)
(AND (EQ TYPE (QUOTE FIELDS))
(NULL ONFILETYPE)
(MAPCONC (INFILECOMTAIL COM)
(FUNCTION
(LAMBDA
(X)
(APPEND (RECORDFIELDNAMES
X))))))))
(TYPE DESCRIPTION "records"))))
(PUTDEF (QUOTE SYSRECORDS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (SAVEONSYSRECLST . X)))
CONTENTS
(LAMBDA (COM NAME TYPE ONFILETYPE)
(AND (NULL ONFILETYPE)
(EQ TYPE (QUOTE RECORDS))
(INFILECOMTAIL COM)))))))
(PUTDEF (QUOTE USERMACROS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (COMS * (MAKEUSERMACROSCOMS . X))
)
CONTENTS NILL)
(TYPE DESCRIPTION "edit macros"))))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) (QUOTE ((COM COM T)
(TYPE DESCRIPTION "variables"))))
(PUTDEF (QUOTE *) (QUOTE FILEPKGCOMS) (QUOTE ((COM CONTENTS NILL))))
(RPAQ? SAVEDDEFS )
(RPAQ? DEFAULTRENAMEMETHOD )
(* * EDITCALLERS)
(DEFINEQ
(FINDCALLERS
[LAMBDA (ATOMS FILES) (* lmm "30-SEP-78 01:36")
(PROG ((X (EDITCALLERS ATOMS FILES T)))
(RETURN (NCONC (DREVERSE (CDR X))
(AND (CAR X)
(LIST (CONS (COND
((CDR X)
(QUOTE "plus other places on"))
(T (QUOTE on)))
(CAR X])
(EDITCALLERS
[LAMBDA (ATOMS FILES COMS) (* lmm " 4-JUN-83 23:41")
(PROG (FFILEPOSPATTERNS I FNS OTHERSFILES EDITPATTERN NOMAPFLG)
[SETQ FFILEPOSPATTERNS (for ATOM in (SETQ ATOMS (MKLIST ATOMS))
collect (CONCAT (COND
((EQ (CHCON1 ATOM)
(CHARCODE ESCAPE))
(SETQ ATOM (SUBSTRING ATOM 2 -1))
"")
(T " "))
(COND
((SETQ I (STRPOS (QUOTE )
ATOM))
(SUBSTRING ATOM 1 (SUB1 I)))
(T ATOM))
(COND
(I "")
(T " "]
(SETQ EDITPATTERN (EDITFPAT (CONS (QUOTE *ANY*)
ATOMS)))
[for FILE in (COND
((NULL FILES)
FILELST)
((EQ FILES T)
(UNION SYSFILES FILELST))
((LISTP FILES)
FILES)
(T (LIST FILES)))
do
(PROG (MAP FULL PRINTFLG)
(OR (SETQ FULL (FINDFILE FILE))
(RETURN (LISPXPRINT (CONS FILE (QUOTE (not found)))
T T)))
(PRIN2 (SETQ FULL (INPUT (INFILE FULL)))
T T)
(PRIN1 ": " T)
(for PATTERN in FFILEPOSPATTERNS
do
(SETFILEPTR FULL (SETQ I 0))
(while (SETQ I (FFILEPOS PATTERN FULL I NIL NIL T (SEPRCASE DWIMIFYCOMPFLG)))
do
(COND
((NULL PRINTFLG)
(* cause the printing of the filename to be saved on history list)
(SETQ PRINTFLG T)
(LISPXPRIN2 FULL T T T)
(* print with NODOFLG=T means just to record the printing; the idea is that only those files in which something is
found will be remembered on the history list)
(LISPXPRIN1 ": " T NIL T)))
[OR
[AND (NEQ MAP T)
(SOME (CDR (OR MAP [PROGN (SETFILEPTR FULL 0)
(SETQ MAP (OR (GETFILEMAP FULL FILE)
(LOADFILEMAP FULL]
(PROGN
(* file has no filemap)
(SETQ MAP (SETQ NOMAPFLG T))
(LISPXPRIN1 " no filemap!" T)
NIL)))
(FUNCTION (LAMBDA (X)
(AND (ILESSP (CAR X)
I)
(IGREATERP (CADR X)
I)
(SOME (CDDR X)
(FUNCTION (LAMBDA (Z)
(COND
((AND (ILESSP (CADR Z)
I)
(IGREATERP (CDDR Z)
I))
[COND
((NOT (FMEMB (CAR Z)
FNS))
(SETQ FNS
(CONS (LISPXPRIN2 (CAR Z)
T T)
FNS]
(SETQ I (CDDR Z))
T]
(PROGN (LISPXPRIN2 I T T)
(OR (FMEMB FILE OTHERSFILES)
(SETQ OTHERSFILES (CONS FILE OTHERSFILES]
(LISPXSPACES 1 T)))
(CLOSEF FULL)
(COND
(PRINTFLG (LISPXTERPRI T))
(T (TERPRI T)))
(COND
((NEQ COMS T)
(COND
((OR FNS OTHERSFILES)
(EDITFROMFILE (OR NOMAPFLG (DREVERSE FNS))
FULL EDITPATTERN COMS (NULL OTHERSFILES))
(SETQ OTHERSFILES)
(SETQ FNS]
(COND
((EQ COMS T)
(RETURN (CONS OTHERSFILES FNS])
(EDITFROMFILE
[LAMBDA (FNS FILES EDITPATTERN EDITCOMS ONLYTYPES) (* rmk: "13-JUL-83 03:09")
(RESETVARS [(EDITLOADFNSFLG (COND
((EQ EDITLOADFNSFLG T)
(QUOTE (T . NO)))
(T EDITLOADFNSFLG]
(PROG NIL
[OR EDITCOMS (SETQ EDITCOMS (LIST (LIST (QUOTE EXAM)
EDITPATTERN]
(AND
(SETQ FILES (for FILE inside (OR FILES FILELST)
when (OR (AND EDITLOADFNSFLG (FMEMB (ROOTFILENAME FILE)
FILELST))
(COND
((EQ (QUOTE Y)
(ASKUSER DWIMWAIT (QUOTE Y)
(LIST "load from" FILE)
NIL T))
(LOADFROM FILE FNS (QUOTE ALLPROP))
T)))
collect FILE))
(for TYPE in [COND
((LISTP ONLYTYPES))
(ONLYTYPES (QUOTE (FNS)))
(T
(* Move FNS to the front. This means that all the fns will be dwimified and editted before anything else
(like a rename of fields) is done.)
(CONS (QUOTE FNS)
(REMOVE (QUOTE FNS)
FILEPKGTYPES]
when (AND (LITATOM TYPE)
(NEQ (fetch EDITDEF of TYPE)
(QUOTE NILL)))
do
(PROG (SEEN)
(for FILE inside FILES
do
(for NAME in [COND
((AND (EQ TYPE (QUOTE FNS))
(NEQ FNS T))
(* for this type, we are given the list of items)
(PROG1 FNS (SETQ FNS NIL)))
(T (* only want the values of "TYPE" which are not part of
some other type)
(FILECOMSLST FILE TYPE (QUOTE EDIT]
unless (MEMBER NAME SEEN)
do
(ERSETQ
(PROG (DEF)
(COND
((OR (AND (EQ TYPE (QUOTE FNS))
(NEQ FNS T))
(AND (LISTP (SETQ DEF (GETDEF NAME TYPE
(QUOTE CURRENT)
0)))
(LOOKIN DEF EDITPATTERN)))
(COND
((NULL SEEN)
(LISPXPRIN1 "editing the " T)
(LISPXPRIN1 (OR (fetch DESCRIPTION
of TYPE)
TYPE)
T)
(LISPXSPACES 1 T)))
(SETQ SEEN (CONS NAME SEEN))
(LISPXPRIN2 NAME T T)
(LISPXPRIN1 ":
" T)
(COND
((NOT
(ERSETQ (EDITDEF
NAME TYPE
(AND DEF (CONS (QUOTE =)
DEF))
EDITCOMS)))
(LISPXPRIN1 "failed" T)))
(LISPXTERPRI T])
(FINDATS
[LAMBDA (X L) (* lmm "11-FEB-78 16:03")
(COND
((NLISTP X)
(FMEMB X L))
(T (OR (FINDATS (CAR X)
L)
(FINDATS (CDR X)
L])
(LOOKIN
[LAMBDA (X PAT) (* lmm "11-MAR-78 14:20")
(COND
([AND (EQ (CAR PAT)
(QUOTE *ANY*))
(EVERY (CDR PAT)
(FUNCTION (LAMBDA (X)
(AND (LITATOM X)
(NOT (STRPOS (QUOTE )
X]
(FINDATS X (CDR PAT)))
(T (EDITFINDP X PAT T])
)
(DEFINEQ
(SEPRCASE
[LAMBDA (CLFLG) (* rmk: "19-FEB-83 22:42")
(* make a case array for FFILEPOS in which all of the
seprs, breaks, and (possibly) clisp chars are all
equivalent)
(OR (COND
(CLFLG (ARRAYP CLISPCASE))
(T (ARRAYP SEPRCASE)))
(for X (CA ←(CASEARRAY)) in (NCONC (AND CLFLG (for Y in CLISPCHARS collect (CHCON1 Y)))
(GETSEPR FILERDTBL)
(GETBRK FILERDTBL))
do (SETCASEARRAY CA X 0) finally (RETURN (COND
(CLFLG (SETQ CLISPCASE CA))
(T (SETQ SEPRCASE CA])
)
(RPAQ? SEPRCASE )
(RPAQ? CLISPCASE )
(MOVD? (QUOTE INFILEP)
(QUOTE FINDFILE))
(* "or else from SPELLFILE")
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: FINDATS FINDATS)
(BLOCK: EDITFROMFILE EDITFROMFILE LOOKIN (GLOBALVARS EDITLOADFNSFLG)
(NOLINKFNS LOADFROM))
(BLOCK: NIL SEPRCASE FINDCALLERS EDITCALLERS (LOCALVARS . T)
(GLOBALVARS SYSFILES CLISPCASE SEPRCASE CLISPFLG CLISPCHARS FCHARAR))
]
(* * EXPORT)
(DEFINEQ
(IMPORTFILE
(LAMBDA (FILE RETURNFLG) (* JonL "20-Jul-84 03:23")
(DECLARE (GLOBALVARS EXPORTDEFSTRING)) (* This is not a literal so that filepkg can be
imported. Not a constant cause it is used in the EXPORT
command.)
(SETQ FILE (OPENFILE FILE (QUOTE INPUT)))
(PROG1 (NCONC (RESETFORM (INPUT FILE)
(RESETVARS (FILEPKGFLG DFNFLG MSDATABASELST (NORMALCOMMENTSFLG T))
(RETURN (while (FFILEPOS EXPORTDEFSTRING FILE NIL NIL NIL T)
bind DEF join (until (EQUAL (SETQ DEF
(READ FILE FILERDTBL)
)
(QUOTE (* END EXPORTED
DEFINITIONS)))
join (IMPORTEVAL DEF RETURNFLG))))
))
(IMPORTEVAL (LIST (QUOTE PUTPROP)
(KWOTE (ROOTFILENAME FILE))
(QUOTE (QUOTE IMPORTDATE))
(LIST (QUOTE IDATE)
(GETFILEINFO FILE (QUOTE CREATIONDATE))))
RETURNFLG))
(CLOSEF? FILE))))
(IMPORTEVAL
[LAMBDA (FORM RETURNFLG) (* lmm " 7-MAY-81 00:03")
(* Ignore DONTEVAL@LOAD'S -
If RETURNFLG is on, return list of forms)
(AND (LISTP FORM)
(COND
((EQ (CAR FORM)
(QUOTE DECLARE:))
(for Z in (CDR FORM) join (IMPORTEVAL Z RETURNFLG)))
(T (AND (NEQ RETURNFLG T)
(EVAL FORM))
(AND RETURNFLG (LIST FORM])
(CHECKIMPORTS
[LAMBDA (FILES NOASKFLG) (* rmk: "19-FEB-83 16:31")
(* Loads exported definitions from new versions of
FILES.)
(COND
((AND (SETQ FILES (for FILE inside FILES bind FULLFILENAME DATE
when [AND (SETQ FULLFILENAME (FINDFILE FILE T))
(OR [NOT (SETQ DATE (GETPROP (ROOTFILENAME FILE)
(QUOTE IMPORTDATE]
(NOT (IEQP DATE (GETFILEINFO FULLFILENAME (QUOTE
ICREATIONDATE]
collect (LIST FILE FULLFILENAME)))
(OR NOASKFLG (SELECTQ (ASKUSER 5 (QUOTE Y)
(LIST "load new exports from "
(MAPCAR FILES (FUNCTION CAR)))
(QUOTE ((Y "es
")
(N "o
")))
T)
(N NIL)
T)))
(for FILE in FILES do (IMPORTFILE (CADR FILE])
(GATHEREXPORTS
[LAMBDA (FROMFILES TOFILE FLG) (* rmk: "15-Jun-84 10:42")
(* Copies all exported definitions from FROMFILES to
TOFILE.)
(RESETLST [RESETSAVE (OUTFILE TOFILE)
(QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE]
(printout TOFILE "(LISPXPRIN1 %"EXPORTS GATHERED FROM " (DIRECTORYNAME T)
" ON "
(DATE)
"%" T)" T "(LISPXTERPRI T)" T)
(for F inside FROMFILES
do (if (SETQ F (FINDFILE F T))
then (MAPC (IMPORTFILE F (OR FLG T))
(FUNCTION PRINT))
else (printout NIL T "(HELP (QUOTE " .P2 F
") %"File not found during GATHEREXPORTS%")"))
(TERPRI))
(PRINT (QUOTE STOP))
(TERPRI)
(OUTPUT])
)
(PUTDEF (QUOTE EXPORT) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (PRIN1 EXPORTDEFSTRING)
(TERPRI)
(TERPRI)
(TERPRI))
(COMS . X)
(E (PRIN1
"
(* END EXPORTED DEFINITIONS)
")))))))
(RPAQ? EXPORTDEFSTRING (CONCAT "(* FOLLOWING " "DEFINITIONS EXPORTED)"))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: IMPORTFILE IMPORTFILE IMPORTEVAL)
]
(* * for GAINSPACE)
(DEFINEQ
(CLEARFILEPKG
[LAMBDA (FLG) (* rmk: "19-FEB-83 14:07")
(PROG NIL
(SELECTQ FLG
((NIL T))
(SETQ SMASHPROPSLST1 (CONS (QUOTE FILEMAP)
SMASHPROPSLST1)))
(COND
((SELECTQ FLG
((E T)
T)
(Y (TERPRI T)
(PRIN1 "you can delete just the filemaps -
" T)
(PROG1 [ASKUSER NIL NIL "are you sure you want to delete EVERYTHING ? "
(QUOTE ((Y "es - everything" RETURN T)
(N "o - just the filemaps" RETURN NIL)
(E "verything" RETURN T)
(F "ilemaps only" RETURN NIL]
(TERPRI T)))
NIL)
(UPDATEFILES)
[SETQ FILELST (SUBSET FILELST (FUNCTION (LAMBDA (FILE)
(COND
((fetch TOBEDUMPED of (fetch FILEPROP of FILE))
(PRINT FILE T T)
(PRIN1 " has changes, not wiped." T)
(TERPRI T)
T)
(T (replace FILEPROP of FILE with NIL)
(replace FILECHANGES of FILE with NIL)
(replace FILEMAP of FILE with NIL)
(SMASHFILECOMS FILE)
(NCONC1 SYSFILES FILE)
NIL]
(SETQ LOADEDFILELST])
)
(ADDTOVAR GAINSPACEFORMS (FILELST "erase filepkg information" (CLEARFILEPKG RESPONSE)
((Y "es")
(N "o")
(E . "verything")
(F "ilemaps only
"))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL CLEARFILEPKG (GLOBALVARS SMASHPROPSLST1))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS #LISTFILESCHARS #UNDOSAVES ADDTOFILEKEYLST BUILDMAPFLG CLEANUPOPTIONS CLISPARRAY
CLISPIFYPRETTYFLG COMPILE.EXT DECLARETAGSLST DEFAULTRENAMEMETHOD DFNFLG DWIMESSGAG
DWIMFLG DWIMIFYCOMPFLG DWIMLOADFNSFLG DWIMWAIT FILELST FILEPKGCOMSPLST FILEPKGFLG
FILEPKGTYPES FILERDTBL FONTCHANGEFLG HISTORYCOMS HISTSTR0 I.S.OPRLST LASTFILE LISPXCOMS
LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS LISTFILESTR LOADEDFILELST MACROPROPS
MAKEFILEFORMS MAKEFILEOPTIONS MAKEFILEREMAKEFLG MSDATABASELST NOSPELLFLG NOTCOMPILEDFILES
NOTLISTEDFILES PRETTYDEFMACROS PRETTYFLG PRETTYHEADER PRETTYTRANFLG PRETTYTYPELST
SAVEDDEFS SYSFILES SYSPROPS USERMACROS USERRECLST USERWORDS)
)
(* RESOURCE "management")
(DECLARE: EVAL@COMPILE
(PUTPROPS NEWRESOURCE MACRO (X
(\GR.METHODEXPANDER X (QUOTE NEW))))
(PUTPROPS GETRESOURCE MACRO (X
(\GR.METHODEXPANDER X (QUOTE GET))))
(PUTPROPS FREERESOURCE MACRO (X
(\GR.METHODEXPANDER X (QUOTE FREE))))
(PUTPROPS WITH-RESOURCE MACRO (= . WITH-RESOURCES))
(PUTPROPS WITH-RESOURCES MACRO (X
(\GR.WITHRESOURCEMAC X)))
)
(DEFINEQ
(\GR.METHODEXPANDER
(LAMBDA (X METHOD) (* JonL " 8-Oct-84 16:05")
(PROG (DEF RVAR (NAME (OR (CAR (LISTP X))
X)))
(RETURN (if (NULL (SETQ DEF (LISTGET (SETQ DEF (GETDEF NAME (QUOTE RESOURCES)))
METHOD)))
then (* Although these could all be implemented by
functions, this is the default
(and common) case; so just put in-line here.)
(SETQ RVAR (PACK* (QUOTE \)
NAME
(QUOTE .GLOBALRESOURCE)))
(SELECTQ METHOD
(GET (BQUOTE (PROGN (DECLARE (GLOBALVARS , RVAR))
(COND
(, RVAR (PROG1 , RVAR (SETQ , RVAR NIL)))
(T (NEWRESOURCE , NAME))))))
(FREE (BQUOTE (PROGN (DECLARE (GLOBALVARS , RVAR))
(SETQ , RVAR , (CADR X)))))
(INIT (BQUOTE (/SETTOPVAL (QUOTE , RVAR))))
(NEW (ERROR "No NEW method for resource" NAME))
(SHOULDNT))
elseif (FNTYP DEF)
then (APPLY DEF X)
elseif (LISTP DEF)
then (SUBPAIR (QUOTE (RESOURCENAME ARGS))
(LIST NAME (CDR X))
DEF)
else (ERROR (CONCAT "Bad resource " METHOD " method for " NAME)
DEF))))))
(\GR.WITHRESOURCEMAC
[LAMBDA (X) (* rmk: "15-Jun-84 10:51")
(PROG [(NAMES (MKLIST (CAR X)))
(FORMS (\DECL.COMNT.PROCESS (CDR X]
(RETURN (CONS [CONS (QUOTE LAMBDA)
(CONS NAMES (APPEND (CAR FORMS)
(CADR FORMS)
(LIST (CONS (QUOTE PROG1)
(CONS (CONS (QUOTE PROGN)
(CDDR FORMS))
(for NAME in NAMES
collect (LIST (QUOTE
FREERESOURCE)
NAME NAME]
(for NAME in NAMES collect (LIST (QUOTE GETRESOURCE)
NAME])
)
(PUTDEF (QUOTE RESOURCES) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (DECLARE: EVAL@COMPILE
(P * (
\GR.MAKEPRETTYCOMSL . X)
)))
CONTENTS \GR.CONTENTS)
(TYPE DESCRIPTION "global resources" GETDEF
\GR.GETDEFFN PUTDEF \GR.PUTDEFFN DELDEF
\GR.DELDEFFN))))
(PUTDEF (QUOTE INITRESOURCES) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (P * (\IGR.MAKEPRETTYCOMSL .
X)))
CONTENTS \GR.CONTENTS))))
(DEFINEQ
(\GR.GETDEFFN
[LAMBDA (NAME TYPE) (* rmk: "14-Jun-84 22:39")
(CDR (ASSOC NAME GLOBAL.RESOURCES])
(\GR.PUTDEFFN
(LAMBDA (NAME TYPE DEF) (* JonL "20-Jul-84 03:31")
(if (OR (NULL NAME)
(NOT (LITATOM NAME)))
then (ERRORX (LIST 14 NAME)))
(if (AND (LISTP DEF)
(NOT (LISTGET DEF (QUOTE NEW))))
then
(* * Conversion from old format -- to be flushed soon after CAROL release. Jonl 5/14/84)
(SETQ DEF (LIST (QUOTE NEW)
DEF))
elseif (AND DEF (NOT (LISTGET (LISTP DEF)
(QUOTE NEW))))
then (ERROR "No NEW method for resource" NAME)) (* Note that the variable GLOBAL.RESOURCES has been
GLOBALVAR'd by the file COMS)
(if (NULL DEF)
then (\GR.DELDEFFN NAME TYPE)
else (PROG NIL
(MARKASCHANGED NAME (QUOTE RESOURCES)
(if (SETQ TYPE (ASSOC NAME GLOBAL.RESOURCES))
then (* The initialization has to be performed regardless of
whether or not the definition has changed.)
(EVAL (\GR.METHODEXPANDER NAME (QUOTE INIT)))
(AND (EQUAL DEF (CDR TYPE))
(RETURN))
(/RPLACD TYPE DEF)
(QUOTE CHANGED)
else (/SETTOPVAL (QUOTE GLOBAL.RESOURCES)
(CONS (CONS NAME DEF)
GLOBAL.RESOURCES))
(EVAL (\GR.METHODEXPANDER NAME (QUOTE INIT)))
(QUOTE DEFINED)))))
NAME))
(\GR.DELDEFFN
[LAMBDA (NAME TYPE) (* rmk: "15-Jun-84 11:23")
(if (NOT (AND NAME (LITATOM NAME)))
then (ERRORX (LIST 14 NAME)))
(PROG ((DEF (ASSOC NAME GLOBAL.RESOURCES)))
(if DEF
then (MARKASCHANGED NAME (QUOTE RESOURCES)
(QUOTE DELETED))
(/SETTOPVAL (QUOTE GLOBAL.RESOURCES)
(REMOVE DEF GLOBAL.RESOURCES))
(if (NULL (LISTGET (CDR DEF)
(QUOTE GET)))
then (* Help clean up mess left by the default case)
(/SETTOPVAL (PACK* (QUOTE \)
NAME
(QUOTE .GLOBALRESOURCE))
(QUOTE NOBIND)))
(RETURN T])
(\GR.CONTENTS
[LAMBDA (COM NAME TYPE) (* rmk: "14-Jun-84 22:29")
(COND
((EQ TYPE (QUOTE RESOURCES))
[SETQ COM (COND
((EQ (CAR (LISTP (CDR COM)))
(QUOTE *))
(EVAL (CADDR COM)))
(T (CDR COM]
(COND
((EQ NAME T)
(AND COM T))
((AND NAME (LITATOM NAME))
(AND [find X in COM suchthat (EQ NAME (COND
((LISTP X)
(CAR X))
(T X]
T))
(T (MAPCAR COM (FUNCTION (LAMBDA (X)
(COND
((LISTP X)
(CAR X))
(T X])
)
(DEFINEQ
(\GR.MAKEPRETTYCOMSL
[NLAMBDA L (* rmk: "14-Jun-84 22:31")
[COND
((EQ (CAR (LISTP L))
(QUOTE *))
(SETQ L (EVAL (CADR L]
(for Y NAME DEF in L
collect [COND
[(LISTP Y)
(SETQ NAME (CAR Y))
(SETQ DEF (CAR (LISTP (CDR Y]
(T (SETQ NAME Y)
(SETQ DEF (GETDEF NAME (QUOTE RESOURCES]
(OR (AND NAME (LITATOM NAME))
(ERROR "Bad filepkg command" L))
(SUBPAIR (QUOTE (NAME DEF))
(LIST NAME DEF)
(QUOTE (PUTDEF (QUOTE NAME)
(QUOTE RESOURCES)
(QUOTE DEF])
(\IGR.MAKEPRETTYCOMSL
[NLAMBDA L (* rmk: "15-Jun-84 11:46")
[COND
((EQ (CAR (LISTP L))
(QUOTE *))
(SETQ L (EVAL (CADR L]
(for NAME in L collect (\GR.METHODEXPANDER NAME (QUOTE INIT])
)
(RPAQ? GLOBAL.RESOURCES )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GLOBAL.RESOURCES)
)
(* "need only be in ABC")
(DECLARE: EVAL@COMPILE
(PUTPROPS GLOBALRESOURCE MACRO (= . WITH-RESOURCES))
(PUTPROPS GLOBALRESOURCES MACRO (= . WITH-RESOURCES))
)
(PUTDEF (QUOTE GLOBALRESOURCES) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (DECLARE: DONTCOPY
(RESOURCES . X))
(INITRESOURCES . X)))
(TYPE TYPE RESOURCES))))
(DECLARE: EVAL@COMPILE
(PUTPROPS RELEASERESOURCE MACRO (ARGS
((LAMBDA (RVALVAR)
(OR (AND (LITATOM RVALVAR)
RVALVAR
(NEQ T RVALVAR))
(ERROR "Must RELEASERESOURCE from a variable" ARGS)))
(CADR ARGS))
(SUBPAIR (QUOTE (RNAME RVALVAR . FORMS))
ARGS
(QUOTE (PROGN (FREERESOURCE RNAME RVALVAR)
(PROG1 (PROGN . FORMS)
(SETQ RVALVAR (GETRESOURCE RNAME))))))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA \IGR.MAKEPRETTYCOMSL \GR.MAKEPRETTYCOMSL MAKEUSERMACROSCOMS MAKEPROPSCOMS
MAKELISPXMACROSCOMS MAKEFILESCOMS MAKEALISTCOMS APPENDTOVAR
ADDTOVAR PUTPROPS LISTFILES COMPILEFILES CLEANUP PRETTYDEFMACROS
FILEPKGCOMPROPS)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DELFROMCOMS DELFROMCOMS DELFROMCOM DELFROMCOM1 REMOVEITEM (NOLINKFNS . T)
(SPECVARS COMSNAME))
(BLOCK: MERGEINSERT MERGEINSERT MERGEINSERT1 (NOLINKFNS . T))
(BLOCK: ADDTOFILEBLOCK ADDTOFILES? ADDTOFILE WHATIS ADDTOCOMS ADDTOCOM ADDTOCOM1 ADDNEWCOM
(NOLINKFNS . T)
(SPECVARS COMSNAME)
(ENTRIES ADDTOFILE ADDTOCOMS ADDTOFILES?))
(BLOCK: INFILECOMS? INFILECOMS? INFILECOMTAIL INFILECOMS INFILECOM INFILECOMSVAL INFILECOMSVALS
INFILEPAIRS INFILECOMSMACRO IFCPROPS IFCEXPRTYPE IFCPROPSCAN IFCDECLARE
(LOCALFREEVARS NAME LITERALS VAL TYPE ONFILETYPE ORIGFLG)
INFILECOMSPROP
(GLOBALVARS DWIMLOADFNSFLG))
(BLOCK: NIL MAKEFILE (LOCALVARS . T)
(SPECVARS FILE OPTIONS REPRINTFNS SOURCEFILE FILETYPE FILEDATES CHANGES))
(BLOCK: ADDFILE ADDFILE ADDFILE0 (NOLINKFNS . T)
(GLOBALVARS ADDSPELLFLG))
(BLOCK: FILEPKGCHANGES FILEPKGCHANGES (NOLINKFNS . T))
(BLOCK: NIL ADDTOVAR APPENDTOVAR ALISTS.WHENCHANGED CHANGECALLERS CLEANUP CLEARCLISPARRAY COMPARE
COMPAREDEFS COMPILEFILES COMPILEFILES0 CONTINUEDIT COPYDEF DEFAULTMAKENEWCOM DELFROMFILES
EDITDEF EXPRESSIONS.WHENCHANGED FILECOMS FILECOMSLST FILEFNSLST FILEPKGCOM FILEPKGCOMPROPS
FILEPKGTYPE FILES? FILES?1 GETFILEPKGTYPE HASDEF INFILECOMTAIL LOADDEF MAKEALISTCOMS
MAKEFILE1 MAKEFILES MAKEFILESCOMS MAKELISPXMACROSCOMS MAKENEWCOM MAKEPROPSCOMS
MAKEUSERMACROSCOMS MARKASCHANGED MOVETOFILE POSTEDITPROPS PREEDITFN PRETTYDEFMACROS
PROPS.WHENCHANGED PUTDEF PUTPROPS RENAME SAVEDEF SAVEPUT SEARCHPRETTYTYPELST SHOWDEF
SMASHFILECOMS TYPESOF UNMARKASCHANGED UNSAVEDEF UPDATEFILES
(GLOBALVARS #UNDOSAVES SYSFILES MARKASCHANGEDSTATS ADDSPELLFLG COMPILE.EXT EDITMACROS
EDITLOADFNSFLG LOADOPTIONS)
(LOCALVARS . T))
(BLOCK: DELDEF DELDEF DELFROMLIST (NOLINKFNS . T))
(BLOCK: GETDEF GETDEF DWIMDEF GETDEFCOM GETDEFCOM0 GETDEFERR GETDEFCURRENT GETDEFFROMFILE GETDEFSAVED
(RETFNS GETDEFCOM)
(NOLINKFNS . T)
(GLOBALVARS NOT-FOUNDTAG))
]
(PUTPROPS FILEPKG COPYRIGHT ("Xerox Corporation" T 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (10075 10287 (FILEPKGCOMPROPS 10085 . 10285)) (16685 17666 (SEARCHPRETTYTYPELST 16695 .
17327) (PRETTYDEFMACROS 17329 . 17664)) (18016 41587 (CLEANUP 18026 . 19089) (COMPILEFILES 19091 .
19352) (COMPILEFILES0 19354 . 19829) (CONTINUEDIT 19831 . 20700) (MAKEFILE 20702 . 30134) (FILECHANGES
30136 . 32060) (FILEPKG.MERGECHANGES 32062 . 32608) (FILEPKG.CHANGEDFNS 32610 . 32918) (MAKEFILE1
32920 . 34233) (MAKEFILES 34235 . 35178) (ADDFILE 35180 . 37405) (ADDFILE0 37407 . 40978) (LISTFILES
40980 . 41585)) (42072 65222 (FILEPKGCHANGES 42082 . 42925) (GETFILEPKGTYPE 42927 . 44468) (
MARKASCHANGED 44470 . 46556) (FILECOMS 46558 . 46904) (WHEREIS 46906 . 47591) (SMASHFILECOMS 47593 .
47833) (FILEFNSLST 47835 . 47979) (FILECOMSLST 47981 . 48381) (UPDATEFILES 48383 . 51537) (INFILECOMS?
51539 . 53147) (INFILECOMTAIL 53149 . 53645) (INFILECOMS 53647 . 53806) (INFILECOM 53808 . 60181) (
INFILECOMSVALS 60183 . 60351) (INFILECOMSVAL 60353 . 61015) (INFILECOMSPROP 61017 . 61545) (IFCPROPS
61547 . 62389) (IFCEXPRTYPE 62391 . 62896) (IFCPROPSCAN 62898 . 63580) (IFCDECLARE 63582 . 64170) (
INFILEPAIRS 64172 . 64428) (INFILECOMSMACRO 64430 . 65220)) (65254 84256 (FILES? 65264 . 66171) (
FILES?1 66173 . 67106) (ADDTOFILES? 67108 . 72896) (ADDTOFILE 72898 . 73664) (WHATIS 73666 . 75140) (
ADDTOCOMS 75142 . 76227) (ADDTOCOM 76229 . 80091) (ADDTOCOM1 80093 . 81000) (ADDNEWCOM 81002 . 81897)
(MAKENEWCOM 81899 . 83223) (DEFAULTMAKENEWCOM 83225 . 84254)) (84292 86418 (MERGEINSERT 84302 . 86025)
(MERGEINSERT1 86027 . 86416)) (87317 93658 (DELFROMFILES 87327 . 88025) (DELFROMCOM 88027 . 90683) (
DELFROMCOM1 90685 . 91318) (DELFROMCOMS 91320 . 92363) (REMOVEITEM 92365 . 92900) (MOVETOFILE 92902 .
93656)) (93980 100602 (SAVEPUT 93990 . 95997) (PUTPROPS 95999 . 96349) (ADDTOVAR 96351 . 98451) (
APPENDTOVAR 98453 . 100600)) (100603 105751 (UNMARKASCHANGED 100613 . 101734) (PREEDITFN 101736 .
103155) (POSTEDITPROPS 103157 . 104625) (POSTEDITALISTS 104627 . 105749)) (105880 112110 (
ALISTS.WHENCHANGED 105890 . 106403) (CLEARCLISPARRAY 106405 . 107016) (EXPRESSIONS.WHENCHANGED 107018
. 107528) (MAKEALISTCOMS 107530 . 108250) (MAKEFILESCOMS 108252 . 109311) (MAKELISPXMACROSCOMS 109313
. 110211) (MAKEPROPSCOMS 110213 . 110657) (MAKEUSERMACROSCOMS 110659 . 111664) (PROPS.WHENCHANGED
111666 . 112108)) (114474 118990 (RENAME 114484 . 115687) (CHANGECALLERS 115689 . 118988)) (118991
153987 (SHOWDEF 119001 . 119318) (COPYDEF 119320 . 120789) (GETDEF 120791 . 122787) (GETDEFCOM 122789
. 123707) (GETDEFCOM0 123709 . 124592) (GETDEFCURRENT 124594 . 129025) (GETDEFERR 129027 . 130173) (
GETDEFFROMFILE 130175 . 136027) (GETDEFSAVED 136029 . 136870) (PUTDEF 136872 . 139989) (EDITDEF 139991
. 142122) (LOADDEF 142124 . 142305) (DWIMDEF 142307 . 142906) (DELDEF 142908 . 145390) (DELFROMLIST
145392 . 145692) (HASDEF 145694 . 149105) (GETFILEDEF 149107 . 149594) (SAVEDEF 149596 . 150700) (
UNSAVEDEF 150702 . 151418) (COMPAREDEFS 151420 . 152898) (COMPARE 152900 . 153551) (TYPESOF 153553 .
153985)) (154147 160155 (FILEPKGCOM 154157 . 157089) (FILEPKGTYPE 157091 . 160153)) (164613 171128 (
FINDCALLERS 164623 . 164967) (EDITCALLERS 164969 . 168006) (EDITFROMFILE 168008 . 170568) (FINDATS
170570 . 170798) (LOOKIN 170800 . 171126)) (171129 171826 (SEPRCASE 171139 . 171824)) (172269 175528 (
IMPORTFILE 172279 . 173320) (IMPORTEVAL 173322 . 173804) (CHECKIMPORTS 173806 . 174696) (GATHEREXPORTS
174698 . 175526)) (175977 177186 (CLEARFILEPKG 175987 . 177184)) (178676 180742 (\GR.METHODEXPANDER
178686 . 180123) (\GR.WITHRESOURCEMAC 180125 . 180740)) (181242 184072 (\GR.GETDEFFN 181252 . 181401)
(\GR.PUTDEFFN 181403 . 182793) (\GR.DELDEFFN 182795 . 183511) (\GR.CONTENTS 183513 . 184070)) (184073
184976 (\GR.MAKEPRETTYCOMSL 184083 . 184697) (\IGR.MAKEPRETTYCOMSL 184699 . 184974)))))
STOP