(FILECREATED " 7-JUN-83 12:13:13" {INDIGO}<LOOPS>SOURCES>LOOPSPRINT.;1 32391
previous date: " 4-JUN-83 17:27:21" {INDIGO}<KBVLSI>LOOPS>SOURCES>LOOPSPRINT.;13)
(PRETTYCOMPRINT LOOPSPRINTCOMS)
(RPAQQ LOOPSPRINTCOMS [(* Copyright (c)
1983 by Xerox Corporation)
(* Set up Printing of classes and instances)
(P (DEFPRINT (QUOTE activeValue)
(QUOTE PrintActiveValue))
(DEFPRINT (QUOTE class)
(QUOTE PrintClass))
(DEFPRINT (QUOTE instance)
(QUOTE PrintInstance)))
(* * Functions for handling READ macros)
(FNS * INFNS)
(* * Prettyprinting functions)
(FNS * PPFNS)
(* This defines what is to happen when the command (CLASSES * CLASSNAMES)
appears in a coms list.)
(FILEPKGCOMS CLASSES INSTANCES)
(* The following defines class, classes, and CLASS as synonyms for CLASSES
with respect to the file package type. Set up macros so that references to
classes and instances seen by HPRINT don't recur into their structure.)
(ADDVARS (FILEPKGTYPES (class . CLASSES)
(classes . CLASSES)
(CLASS . CLASSES)
(INSTANCE INSTANCES)
(instance INSTANCES))
(HPRINTMACROS (class . HPRINTCLASS)
(instance . HPRINTINSTANCE)))
(* Set Up Loops Read Macros for ,@, and $)
(P (SETALLSYNTAX %# (MACRO FIRST HashMacro)))
(ADVICE * LOOPSPRINTADVICE)
(ADDVARS (DWIMUSERFORMS (TRANS@$)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DEFINSTANCES DEFINST DEFCLASSES DEFCLASS)
(NLAML SETALLSYNTAX)
(LAMA])
(* Copyright (c) 1983 by Xerox Corporation)
(* Set up Printing of classes and instances)
(DEFPRINT (QUOTE activeValue)
(QUOTE PrintActiveValue))
(DEFPRINT (QUOTE class)
(QUOTE PrintClass))
(DEFPRINT (QUOTE instance)
(QUOTE PrintInstance))
(* * Functions for handling READ macros)
(RPAQQ INFNS (AtMacro AtMacroConstruct DataType DollarMacro GetLispClass HPRINTCLASS HPRINTINSTANCE
HREADCLASS HREADINSTANCE HashMacro InitializeLOOPS LoopsSyntax SETALLSYNTAX
TRANS@$))
(DEFINEQ
(AtMacro
[LAMBDA (fileHandle readTable) (* dgb: "17-SEP-82 02:28")
(* Causes the following transformations by a read-in macro. -
%@FOO -> (GetValue self (QUOTE FOO)) or (%@ FOO) -
%@%@FOO -> (GetClassValue self (QUOTE FOO)) or (%@%@ FOO) -
%@FOO←exp -> (PutValue self exp) or (←%@ FOO exp) -
%@FOO←+exp -> (PushValue self exp) -
%@%@FOO← exp -> (PutClassValue self exp) -
%@%@FOO←+ exp -> (PushClassValue self exp) -
%@ (X foo) -> (GetValue X (QUOTE foo)) or (%@ X foo) -
%@ (X foo prop) -> (GetValue X (QUOTE foo) (QUOTE prop)) or (%@ X foo prop) -
%@%@ (x foo) -> (GetClassValue x (QUOTE foo)) or (%@%@ X foo prop) -
%@%@ (x foo prop) -> (GetClassValue x (QUOTE foo) (QUOTE prop)) -
or (%@%@ X foo prop) -
... and similarly for the puts using ←%@ and ←%@%@ with the newValue always last)
(* Also performs transformations for getting and putting
properties of class variables and instance variables.)
(PROG (classVarFlg varName propName storeFlg newValueForm temp (objName (QUOTE self)))
(COND
((EQ (QUOTE %@)
(PEEKC fileHandle)) (* If next character is an "@" then this is a reference
to a class variable)
(SETQ classVarFlg T)
(READC fileHandle)))
(COND
((EQ (PEEKC fileHandle readTable)
(QUOTE %())
(SETQ temp (READ fileHandle readTable))
(SETQ objName (CAR temp))
(SETQ varName (CADR temp))
(SETQ propName (CADDR temp)))
[(NEQ (QUOTE OTHER)
(GETSYNTAX (PEEKC fileHandle)
readTable)) (* Quit if character after the At looks like LISP
usage.)
(RETURN (COND
(classVarFlg (QUOTE %@%@))
(T (QUOTE %@]
(T (* Here unless varName already ready with propName.)
(* Temporarily make LeftArrow a BREAK character before
reading expression.)
(RESETSAVE (SETSYNTAX (QUOTE ←)
(QUOTE BREAKCHAR)
readTable)
(LIST (QUOTE SETBRK)
(GETBRK readTable)))
(SETQ varName (RATOM fileHandle readTable))
(SETSYNTAX (QUOTE ←)
(QUOTE OTHER)
readTable)))
[COND
((EQ (QUOTE ←)
(PEEKC fileHandle readTable))
(READC fileHandle readTable)
(COND
((EQ (PEEKC fileHandle readTable)
(QUOTE +)) (* This means to push value on front)
(READC fileHandle)
(SETQ storeFlg 1))
(T (SETQ storeFlg T)))
(SETQ newValueForm (READ fileHandle readTable]
(RETURN (AtMacroConstruct objName varName propName newValueForm classVarFlg storeFlg])
(AtMacroConstruct
[LAMBDA (objName varName propName newValue classVarFlg storeFlg)
(* dgb: "17-SEP-82 02:37")
(* Constructs the form needed for atMacro.
See translation table in AtMacro)
(COND
[(NULL storeFlg)
(NCONC [LIST (COND
(classVarFlg (QUOTE %@%@))
(T (QUOTE %@]
(COND
((OR propName (NEQ (QUOTE self)
objName))
(LIST objName)))
(LIST varName)
(COND
(propName (LIST propName]
[(EQ storeFlg 1)
(NCONC (LIST (COND
(classVarFlg (QUOTE PushClassValue))
(T (QUOTE PushValue)))
objName
(KWOTE varName))
(LIST newValue)
(COND
(propName (LIST (KWOTE propName]
(T (NCONC [LIST (COND
(classVarFlg (QUOTE ←%@%@))
(T (QUOTE ←%@]
(COND
((OR propName (NEQ (QUOTE self)
objName))
(LIST objName)))
(LIST varName)
(COND
(propName (LIST propName)))
(LIST newValue])
(DataType
[LAMBDA (self varName localSt propName activeVal type) (* dgb: "13-DEC-82 16:24")
(* Dummy to cause dumping of noncircular datatype in
instances)
localSt])
(DollarMacro
[LAMBDA (fileHandle readTable) (* dgb: "23-NOV-81 14:42")
(* Causes %$FOO to be translated at READ time into (GetObjectRec (QUOTE FOO)). The localState of this expression
is the objectRec itself)
(COND
[(EQ (GETSYNTAX (PEEKC fileHandle readTable))
(QUOTE OTHER))
(LIST (QUOTE %$)
(MKNAME (READ fileHandle readTable]
(T (QUOTE %$])
(GetLispClass
[LAMBDA (obj) (* dgb: "30-NOV-81 21:24")
(* * Gets the class corresponding to the Lisp object as specified in LispClassTable)
(COND
((AND (LISTP obj)
(type? class (CAR obj)))
(CAR obj))
(T (GETHASH (TYPENAME obj)
LispClassTable])
(HPRINTCLASS
[LAMBDA (EXPR FILE) (* dgb: "18-MAR-83 16:35")
(* Used by HPRINT to print out an expression which will
be read back in as a class)
(PRIN1 (QUOTE (HREADCLASS))
FILE)
(PRIN2 (ClassName EXPR])
(HPRINTINSTANCE
[LAMBDA (EXPR FILE) (* dgb: "18-MAR-83 16:36")
(* Used by HPRINT to print out an expression referring
to an instance, provided instance is dumped eleewhere)
(PRIN1 (QUOTE (HREADINSTANCE))
FILE)
(PRIN2 (UID EXPR])
(HREADCLASS
[LAMBDA (FILE) (* dgb: "13-DEC-82 15:13")
(GetObjectRec (HREAD FILE])
(HREADINSTANCE
[LAMBDA (FILE) (* dgb: "13-DEC-82 17:41")
(GetObjectRec (MKNAME (HREAD FILE])
(HashMacro
[LAMBDA (fileHandle readTable) (* dgb: "19-JAN-83 12:03")
(PROG (val name filePosition)
(RETURN (SELECTQ (SETQ val (PEEKC fileHandle))
(%$ (* %#%$FOO causes the unit named FOO to be read in right
now, and a pointer to it inserted in the list being
read)
(READC fileHandle)
(SETQ name (READ fileHandle readTable))
(OR (EQ T fileHandle)
(SETQ filePosition (GETFILEPTR fileHandle)))
(* Don't worry about the file position if reading from
the terminal)
(SETQ val (GetObjectRec (MKNAME name)))
[COND
((AND (NULL val)
(STRINGP name))
(SETQ val (NewObject OBJECT (MKNAME name]
(OR (EQ T fileHandle)
(SETFILEPTR fileHandle filePosition))
val)
[& (* reads in an unnamed instance of type class, or
fetches old value. may change values)
(READC fileHandle)
(SETQ val (READ fileHandle readTable))
(COND
[[FIXP (CDR (LISTP (CADR val]
(RETURN (VAG (CADR val]
(T (RETURN (ModifyInstance val]
[- (READC fileHandle) (* a datatype dumped)
(RETURN (create activeValue
getFn ←(QUOTE DataType)
localState ←(HREAD fileHandle]
(SELECTQ (GETSYNTAX val readTable)
(LEFTPAREN (SETQ val (READ fileHandle readTable))
(* %# (val getFn putFn) is how ordinary active values
are printed out, and are to be read back in)
(create activeValue
localState ←(CAR val)
getFn ←(CADR val)
putFn ←(CADDR val)))
((LEFTBRACKET RIGHTPAREN RIGHTBRACKET STRINGDELIM BREAKCHAR
SEPRCHAR)
(QUOTE %#))
(PACK* (QUOTE %#)
(RATOM fileHandle readTable])
(InitializeLOOPS
[LAMBDA NIL (* dgb: "13-DEC-82 17:36")
(* Fn to initialize LOOPS package.)
(* Set break characters for read macros.)
(LoopsSyntax T) (* Initialize interaction with file system)
[COND
((NLISTP (GETTOPVAL (QUOTE GlobalNameTable))) (* This is the table used for storing associations
between class names and their records when there is no
long term environment)
(SETQ GlobalNameTable (CONS (HARRAY 128]
[COND
((NLISTP (GETTOPVAL (QUOTE LispClassTable)))
(SETQ LispClassTable (CONS (HARRAY 16]
(SETQ DefaultKBName NIL)
(SETQ CurrentNameTable NIL)
(SETQ AllObjectNames NIL)
(DB-InitUI])
(LoopsSyntax
[LAMBDA (offFlg) (* dgb: " 3-JUN-83 10:23")
(COND
(offFlg (SETALLSYNTAX @ OTHER)
(SETALLSYNTAX $ OTHER))
(T (* Set break characters for read macros.)
(SETALLSYNTAX @(MACRO FIRST AtMacro))
(SETALLSYNTAX $ (MACRO FIRST DollarMacro])
(SETALLSYNTAX
[NLAMBDA (CHAR FORM) (* dgb: "30-NOV-81 10:26")
(SETSYNTAX CHAR FORM)
(SETSYNTAX CHAR FORM T)
(SETSYNTAX CHAR FORM FILERDTBL)
(SETSYNTAX CHAR FORM EDITRDTBL])
(TRANS@$
[LAMBDA NIL (* dgb: " 4-JUN-83 17:05")
(* Fix atoms which start with @ and $ to be list form)
(AND (LITATOM FAULTX)
(Fix@$ FAULTX TAIL])
)
(* * Prettyprinting functions)
(RPAQQ PPFNS (DEFCLASS DEFCLASSES DEFINST DEFINSTANCES DollarPrintOut EntityAddress
GetClassValuePrintOut GetValuePrintOut LoopsPPMacros PCVPrintOut PInstance
PVPrintOut PrettyPrintClass PrettyPrintInstance PrintActiveValue PrintClass
PrintDefInstances PrintInstance PrintOut@ PrintOut@@ PrintOut←@ PrintOut←@@
PrttyClasses PrttyInstances PushClassValuePrintOut PushValuePrintOut
PutClassValuePrintOut PutValuePrintOut VarPrintOut))
(DEFINEQ
(DEFCLASS
[NLAMBDA FORM (* dgb: " 7-OCT-82 16:50")
(* * Used by file package to define a class. DEFCLASS is CAR of defining form)
(PROG ((className (CAR FORM))
(source (CDR FORM)))
(COND
((OR (NULL source)
(NULL className)) (* Ignore empty class definitions)
(RETURN NIL))
((NOT (LITATOM className))
(HELPCHECK className " cannot be a class name.
Type OK to ignore.")
(RETURN NIL)))
(COND
((NULL (GetClassRec className)) (* Usually an error. class record should have previously
been created.)
(HELPCHECK "No exisiting class of with name: " className
"
Type OK to define one and go on")
(NewClass className)))
(COND
[(CheckClassSource source className) (* Dont't install the class if there are errors.)
(COND
((STKPOS (QUOTE EditClassSource)) (* Bounce back to editor)
(ERROR className " not defined -- bad form " T))
(T (WRITE className "not installed because of error in source"]
(T (InstallClassSource className source])
(DEFCLASSES
[NLAMBDA CLASSES (* dgb: "21-JUN-82 13:09")
(* * Used by the file package. When a form (DEFCLASSES c1 c2 --) is read in, class records for c1, c2, -- are
created. This allows the real class definitions to be read in in any order.)
(MAPC CLASSES (FUNCTION (LAMBDA (className)
(OR (GetClassRec className)
(NewEntity (create class
className ← className
classChangedFlg ← T)
className])
(DEFINST
[NLAMBDA DEFINST% FORM (* dgb: "19-MAR-82 16:36")
(* Defining form for instances)
(ModifyInstance DEFINST% FORM])
(DEFINSTANCES
[NLAMBDA Instances (* dgb: "19-NOV-82 16:57")
(* Read In the list of named instances, creating a new object with the named UID. Make sure it has other names as
given in the list. This insures that other later references point to this same instance.)
(MAPC Instances (FUNCTION (LAMBDA (classNameInstNames)
(PROG (instNames className UID obj)
[COND
[(NLISTP (SETQ className (CDR classNameInstNames)))
(* Old format input. UID passed as NIL to NewObject)
(SETQ instNames (LIST (CAR classNameInstNames]
(T (SETQ className (CAR classNameInstNames))
(SETQ instNames (REVERSE (CDR classNameInstNames)))
(SETQ UID (MKNAME (pop instNames]
(COND
((NULL className)
(RETURN)))
(NameObject (NewObject (GetObjectRec className)
UID)
instNames])
(DollarPrintOut
[LAMBDA (X) (* dgb: "19-NOV-81 23:27")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom GetClassRec.
It causes this form to be printed out as "$name" in just those cases where the form is (GetObjectRec
(QUOTE name)))
(COND
((AND (LISTP (CDR X))
(NULL (CDDR X)))
(PRIN1 "$")
(PRIN1 (CADR X))
NIL)
(T X])
(EntityAddress
[LAMBDA (E) (* dgb: "11-NOV-82 02:29")
(LOC E])
(GetClassValuePrintOut
[LAMBDA (X) (* DECLARATIONS: (RECORD GCV
(GV obj var prop)))
(* mjs: " 2-AUG-82 17:28")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom GetClassValue.
It causes this form to be printed out as "@@varName" in just those cases where the form is
(GetClassValue self (QUOTE varName)) and as "@@(exp varName prop)" in those cases where the form is
(GetClassValue exp (QUOTE varName) (QUOTE prop)) where prop is optional)
(PROG ((obj (fetch obj of X))
(var (fetch var of X))
(prop (fetch prop of X)))
(COND
([OR (NEQ (CAR var)
(QUOTE QUOTE))
(AND prop (NEQ (CAR prop)
(QUOTE QUOTE]
(RETURN X)))
(VarPrintOut "@@" obj (CADR var)
(CADR prop))
(RETURN NIL])
(GetValuePrintOut
[LAMBDA (X) (* DECLARATIONS: (RECORD GV (GetValue obj var prop)))
(* dgb: "27-JAN-82 17:21")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom GetValue. It causes this form to
be printed out as "@varName" in just those cases where the form is (GetValue self (QUOTE varName.)) and as
"@(exp varName prop)" in those cases where the form is (GetValue exp (QUOTE varName) (QUOTE prop)) where prop is
optional)
(PROG ((obj (fetch obj of X))
(var (fetch var of X))
(prop (fetch prop of X)))
(COND
([OR (NEQ (CAR var)
(QUOTE QUOTE))
(AND prop (NEQ (CAR prop)
(QUOTE QUOTE]
(RETURN X)))
(VarPrintOut "@" obj (CADR var)
(CADR prop))
(RETURN NIL])
(LoopsPPMacros
[LAMBDA (onFlg) (* dgb: "11-FEB-83 01:15")
(* Turns on the prettypprint macros in
PRETTYPRINTMACROS)
(COND
(onFlg (ADDTOVAR PRETTYPRINTMACROS (PushValue . PushValuePrintOut)
(PushClassValue . PushClassValuePrintOut)
(%@ . PrintOut%@)
(%@%@ . PrintOut%@%@)
(←%@ . PrintOut←%@)
(←%@%@ . PrintOut←%@%@)
(%$ . DollarPrintOut)))
(T (for x in (QUOTE (PushValue PushClassValue %@ %@%@ ←%@ ←%@%@ %$)) do (SETQ PRETTYPRINTMACROS
(DELASSOC x
PRETTYPRINTMACROS])
(PCVPrintOut
[LAMBDA (X infix) (* DECLARATIONS: (RECORD PCV
(PV obj var newV prop)))
(* mjs: " 2-AUG-82 17:21")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom PutClassValue.
Prints out forms as in GetClassValue forllowed by ← or ←+ and new expression)
(PROG ((obj (fetch obj of X))
(var (fetch var of X))
(newV (fetch newV of X))
(prop (fetch prop of X)))
(COND
([OR (NEQ (CAR var)
(QUOTE QUOTE))
(AND prop (NEQ (CAR prop)
(QUOTE QUOTE]
(RETURN X)))
(VarPrintOut "@@" obj (CADR var)
(CADR prop))
(PRIN1 infix)
(PRINTDEF newV)
(RETURN NIL])
(PInstance
[LAMBDA (inst file) (* dgb: "19-JAN-83 10:56")
(* * Called to print an instance when doing the INSTANCES file pkg command.)
(PROG [(name (GetObjectName inst))
[uid (COND
((type? instance inst)
(UID inst T))
(T (ERROR inst "does not have a uid"]
(source (CDR (GetInstanceSource inst]
(RETURN (COND
((OR name (FMEMB uid UnnamedInstances)
(NULL file)) (* All object should simply be referred to by uid,
except if they are unnamed instances, and printing is
going to a real file.)
(CONS "#$" (MKSTRING uid)))
(T (SETQ UnnamedInstances (CONS uid UnnamedInstances))
(printout file "#&" .PPV source T T)
T])
(PVPrintOut
[LAMBDA (X infix) (* DECLARATIONS: (RECORD PV (PutValue obj var newV prop)
)) (* dgb: "21-JAN-82 10:07")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom PutValue. Prints out forms as in
GetValue followed by ← or ←+ and new expression)
(PROG ((obj (fetch obj of X))
(var (fetch var of X))
(newV (fetch newV of X))
(prop (fetch prop of X)))
(COND
([OR (NEQ (CAR var)
(QUOTE QUOTE))
(AND prop (NEQ (CAR prop)
(QUOTE QUOTE]
(RETURN X)))
(VarPrintOut "@" obj (CADR var)
(CADR prop))
(PRIN1 infix)
(PRINTDEF newV)
(RETURN NIL])
(PrettyPrintClass
[LAMBDA (className file) (* dgb: " 7-OCT-82 17:04")
(* * Called to prettyPrint a class definition on a file by the FILEPKGTYPE CLASSES and by the PP: method in Class)
(RESETVAR FIRSTCOL 16 (PROG ((source (GetClassSource className)))
(COND
((NULL source)
(HELPCHECK className
" is not defined as a class.
Type OK to ignore this class and go on.")
(RETURN NIL)))
(printout file "[DEFCLASS " .FONT LAMBDAFONT (CADR source)
.FONT DEFAULTFONT 3 .PPFTL (CDDR source)
"]" T T)))
className])
(PrettyPrintInstance
[LAMBDA (instance file) (* dgb: "27-OCT-82 15:22")
(* PrettyPrint an instance definition on file.)
(PROG (names (source (GetInstanceSource instance)))
(COND
((NULL instance) (* Do nothing for not defined instance)
(RETURN)))
(SETQ names (CADDR source))
[SETQ source (CONS (QUOTE DEFINST)
(CONS (CADR source)
(CONS (COND
((EQ (OR file (OUTPUT))
T)
(CAR names))
(T names))
(CDDDR source]
(printout (OR file (AND (EQ (OUTPUT)
T)
PPDefault))
.PPF source T T))
instance])
(PrintActiveValue
[LAMBDA (self file) (* dgb: "13-DEC-82 16:38")
(* This is called by the LISP PRINT function when it
sees an instance of the data type activeValue)
(PROG ((ls (fetch localState of self))
(gf (fetch getFn of self))
(pf (fetch putFn of self)))
(RETURN (COND
((NULL file)
(* This is the case in which this function is being called to do internal printing for NCHARS, etc. We are faking
it out, perhaps wisely)
(LIST "#(" ")"))
((EQ gf (QUOTE DataType))
(PRIN1 "#-" file)
(HPRINT ls file T T)
T)
(T (* This is the usual case in which PrintActiveValue is
called. It prints "#(" then the prettyprinted list of
its parts)
(printout file "#(" .PPVTL (LIST ls gf pf)
")"])
(PrintClass
[LAMBDA (classRec file) (* dgb: "17-MAR-82 11:39")
(* * This is called by the LISP PRINT function when it sees an instance of the data type class)
(CONS "#$" (fetch className of classRec])
(PrintDefInstances
[LAMBDA (instances file) (* dgb: " 5-OCT-82 10:50")
(* * Does the INSTANCES command for the LISP file pkg.)
(TERPRI file)
(PRIN1 "[DEFINSTANCES " file)
(for inst instRec in instances do (SETQ instRec (GetObjectRec inst))
(PRIN2 (CONS (ClassName instRec)
(GetObjectNames instRec))
file)
(SPACES 1 file))
(PRIN1 "]" file)
(TERPRI file)
(TERPRI file)
instances])
(PrintInstance
[LAMBDA (instanceRec file) (* dgb: " 3-MAR-83 09:57")
(* * This is called by the LISP PRINT function when it sees an instance of the data type instance)
(DECLARE (SPECVARS FileEntities OutInstances WritingSummaryFlg WritingLayerFlg))
(PROG (entity uid uidString)
[COND
((OR (EQ file T)
(DISPLAYSTREAMP file)) (* for local human consumption)
(← instanceRec PrintOn file)
(RETURN instanceRec))
((OR file OutInstances WritingSummaryFlg WritingLayerFlg)
(* Force items being saved to have a uid)
(SETQ uid (UID instanceRec T))
(SETQ uidString (MKSTRING uid]
(RETURN (COND
(OutInstances (* This case when dumping instances to a file with
INSTANCES)
(OR (FMEMB uid (CAR OutInstances))
(TCONC OutInstances uid))
(CONS "#&" (LIST (ClassName instanceRec)
uidString)))
(WritingSummaryFlg (* Here if writing a summary layer)
(OR (FMEMB (SETQ entity (GetEntityRec uid))
(CAR FileEntities))
(TCONC FileEntities entity))
(CONS "#$" uidString))
(WritingLayerFlg (* Here if currently writing out on layerFile)
(CONS "#$" uidString))
(T (* Internal printing)
(CONS "#&" (LIST (ClassName instanceRec)
uidString])
(PrintOut%@
[LAMBDA (X) (* dgb: "20-SEP-82 15:35")
(COND
((NLISTP (CDR X)) (* Prettyprint macro form)
X)
(T [COND
((NULL (CDDR X))
(VarPrintOut "@" (QUOTE self)
(CADR X)))
(T (VarPrintOut "@" (CADR X)
(CADDR X)
(CADDDR X]
NIL])
(PrintOut%@%@
[LAMBDA (X) (* dgb: "20-SEP-82 15:36")
(COND
((NLISTP (CDR X))
X)
(T [COND
((NULL (CDDR X))
(VarPrintOut "@@" (QUOTE self)
(CADR X)))
(T (VarPrintOut "@@" (CADR X)
(CADDR X)
(CADDDR X]
NIL])
(PrintOut←%@
[LAMBDA (X) (* dgb: "20-SEP-82 15:40")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom ←%@. Prints out forms as in %@
followed by ← and new expression)
(COND
((NLISTP (CDR X)) (* Prettyprint macro form)
X)
(T (PROG [(newV (CAR (LAST X]
(SELECTQ (LENGTH (SETQ X (CDR X)))
(2 (VarPrintOut "@" (QUOTE self)
(CAR X)))
(3 (VarPrintOut "@" (CAR X)
(CADR X)))
(VarPrintOut "@" (CAR X)
(CADR X)
(CADDR X)))
(PRIN1 "←")
(PRINTDEF newV)
(RETURN NIL])
(PrintOut←%@%@
[LAMBDA (X) (* dgb: "20-SEP-82 15:45")
(* * This is called by PRETTYPRINT when it sees a form X starting with the atom ←%@%@. Prints out forms as in %@%@
followed by ← and new expression)
(COND
((NLISTP (CDR X)) (* Prettyprint Macro)
X)
(T (PROG [(newV (CAR (LAST X]
(SELECTQ (LENGTH (SETQ X (CDR X)))
(2 (VarPrintOut "@@" (QUOTE self)
(CAR X)))
(3 (VarPrintOut "@@" (CAR X)
(CADR X)))
(VarPrintOut "@@" (CAR X)
(CADR X)
(CADDR X)))
(PRIN1 "←")
(PRINTDEF newV)
(RETURN NIL])
(PrttyClasses
[LAMBDA (classes) (* dgb: "22-MAR-82 15:02")
(* * Used by CLASSES command to print out rereadable versions of class definitions on files)
(PRINT (CONS (QUOTE DEFCLASSES)
classes)
PRTTYFILE)
(TERPRI PRTTYFILE)
(for className in classes do (PrettyPrintClass className PRTTYFILE])
(PrttyInstances
[LAMBDA (instances) (* dgb: "19-JAN-83 11:24")
(* * Prettyprint a list of named instances to a file. OutInstances is bound here, although usually a free variable
when printing an instance)
(PROG [(OutInstances (LCONC NIL (for name obj in instances collect (UID obj T)
when (SETQ obj (OR (GetObjectRec name)
(NULL (HELPCHECK name
" not defined as an instance.
Type OK to ignore and go on."]
(DECLARE (SPECVARS OutInstances))
(for nm in (CAR OutInstances) bind obj
do (PrettyPrintInstance (GetObjectRec nm)
PRTTYFILE)
(TERPRI PRTTYFILE)
(TERPRI PRTTYFILE])
(PushClassValuePrintOut
[LAMBDA (X) (* dgb: "30-NOV-81 11:05")
(PCVPrintOut X "←+"])
(PushValuePrintOut
[LAMBDA (X) (* dgb: "30-NOV-81 11:05")
(PVPrintOut X "←+"])
(PutClassValuePrintOut
[LAMBDA (X) (* dgb: "11-DEC-81 23:01")
(PCVPrintOut X "←"])
(PutValuePrintOut
[LAMBDA (X) (* mjs: " 4-JAN-82 10:52")
(PVPrintOut X "←"])
(VarPrintOut
[LAMBDA (prefix obj var prop) (* dgb: "31-MAR-82 16:45")
(* Prints out form for variable)
(SPACES 1) (* This space is to protect against butting up against
another atom, and making the prefix read macro lose)
(COND
((AND (NULL prop)
(EQ obj (QUOTE self)))
(PRIN1 (CONCAT prefix var)))
(T (PRIN1 (CONCAT prefix "("))
(PRINTDEF obj)
(SPACES 1)
(PRIN1 var)
(COND
(prop (SPACES 1)
(PRIN1 prop)))
(PRIN1 ")"])
)
(* This defines what is to happen when the command (CLASSES * CLASSNAMES) appears in a coms
list.)
(PUTDEF (QUOTE CLASSES) (QUOTE FILEPKGCOMS) (QUOTE
([COM MACRO
(CLASSES (P (DEFCLASSES . CLASSES))
(E (MAPC (QUOTE CLASSES)
(FUNCTION PrettyPrintClass]
(TYPE DESCRIPTION "class definitions" GETDEF
GetClassSource DELDEF RemoveClassDef))))
(PUTDEF (QUOTE INSTANCES) (QUOTE FILEPKGCOMS) (QUOTE ([COM MACRO (INSTANCES
(E (PrttyInstances (QUOTE INSTANCES]
(TYPE DESCRIPTION "instances" GETDEF
GetInstanceSource))))
(* The following defines class, classes, and CLASS as synonyms for CLASSES with respect to the
file package type. Set up macros so that references to classes and instances seen by HPRINT
don't recur into their structure.)
(ADDTOVAR FILEPKGTYPES (class . CLASSES)
(classes . CLASSES)
(CLASS . CLASSES)
(INSTANCE INSTANCES)
(instance INSTANCES))
(ADDTOVAR HPRINTMACROS (class . HPRINTCLASS)
(instance . HPRINTINSTANCE))
(* Set Up Loops Read Macros for ,@, and $)
(SETALLSYNTAX %# (MACRO FIRST HashMacro))
(RPAQQ LOOPSPRINTADVICE (HPINITRDTBL))
(PUTPROPS HPINITRDTBL READVICE (NIL (AFTER NIL (SETSYNTAX 35 (QUOTE (MACRO FIRST HashMacro))
HPRINTRDTBL))))
(ADDTOVAR DWIMUSERFORMS (TRANS@$))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFINSTANCES DEFINST DEFCLASSES DEFCLASS)
(ADDTOVAR NLAML SETALLSYNTAX)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (2208 12188 (AtMacro 2218 . 5128) (AtMacroConstruct 5130 . 6208) (DataType 6210 . 6475)
(DollarMacro 6477 . 6911) (GetLispClass 6913 . 7258) (HPRINTCLASS 7260 . 7609) (HPRINTINSTANCE 7611 .
7986) (HREADCLASS 7988 . 8127) (HREADINSTANCE 8129 . 8279) (HashMacro 8281 . 10353) (InitializeLOOPS
10355 . 11277) (LoopsSyntax 11279 . 11673) (SETALLSYNTAX 11675 . 11911) (TRANS@$ 11913 . 12186)) (
12714 30777 (DEFCLASS 12724 . 13938) (DEFCLASSES 13940 . 14456) (DEFINST 14458 . 14695) (DEFINSTANCES
14697 . 15663) (DollarPrintOut 15665 . 16127) (EntityAddress 16129 . 16252) (GetClassValuePrintOut
16254 . 17241) (GetValuePrintOut 17243 . 18197) (LoopsPPMacros 18199 . 18903) (PCVPrintOut 18905 .
19772) (PInstance 19774 . 20598) (PVPrintOut 20600 . 21441) (PrettyPrintClass 21443 . 22083) (
PrettyPrintInstance 22085 . 22857) (PrintActiveValue 22859 . 23885) (PrintClass 23887 . 24161) (
PrintDefInstances 24163 . 24681) (PrintInstance 24683 . 26274) (PrintOut@ 26276 . 26659) (PrintOut@@
26661 . 26980) (PrintOut←@ 26982 . 27688) (PrintOut←@@ 27690 . 28399) (PrttyClasses 28401 . 28795) (
PrttyInstances 28797 . 29554) (PushClassValuePrintOut 29556 . 29705) (PushValuePrintOut 29707 . 29850)
(PutClassValuePrintOut 29852 . 29999) (PutValuePrintOut 30001 . 30142) (VarPrintOut 30144 . 30775))))
)
STOP