(FILECREATED "26-DEC-83 18:28:15" {INDIGO}<LOOPS>SOURCES>LOOPSPRINT.;7 32819
changes to: (FNS PrintInstance InitializeLOOPS)
previous date: "23-DEC-83 15:06:14" {INDIGO}<LOOPS>SOURCES>LOOPSPRINT.;6)
(* Copyright (c) 1983 by Xerox Corporation)
(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 INSTANCES METHODS CLASSES)
(* 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
PrettyPrintInstance 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: "26-DEC-83 15:30")
(* Fn to initialize LOOPS package.)
(* Set break characters for read macros.)
(LoopsSyntax T) (* Initialize interaction with file system)
[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])
(PrettyPrintInstance
[LAMBDA (self file) (* dgb: " 4-OCT-83 11:38")
(* PrettyPrint an self definition on file.)
(AND self (← self FileOut file))
self])
(SETALLSYNTAX
[NLAMBDA (CHAR FORM) (* dgb: "23-DEC-83 13:51")
(SETSYNTAX CHAR FORM)
(SETSYNTAX CHAR FORM T)
(SETSYNTAX CHAR FORM FILERDTBL)
(SETSYNTAX CHAR FORM EDITRDTBL)
(SETSYNTAX CHAR FORM DEDITRDTBL])
(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 PrintActiveValue PrintClass PrintDefInstances
PrintInstance PrintOut@ PrintOut@@ PrintOut←@ PrintOut←@@ PrttyClasses
PrttyInstances PushClassValuePrintOut PushValuePrintOut PutClassValuePrintOut
PutValuePrintOut SplitAtom 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: " 4-OCT-83 10:07")
(* Defining form for instances on a file)
(← [OR (GetClassRec (CAR DEFINST% FORM))
(PROGN (printout T (CAR DEFINST% FORM)
" has no class defined for it" T "Defining one now:" T)
(← ($ Class)
New
(CAR DEFINST% FORM]
FileIn
(CDR 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: " 4-OCT-83 17:16")
(* * Called to prettyPrint a class definition on a file by the FILEPKGTYPE CLASSES and by the PP: method in Class)
(PROG (class)
(COND
((NULL (SETQ class (GetClassRec className)))
(RETURN (HELPCHECK className
" is not defined as a class.
Type OK to ignore this class and go on.")))
(T (← class FileOut file)))
(RETURN className])
(PrintActiveValue
[LAMBDA (self file) (* dgb: " 5-OCT-83 11:33")
(* 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)))
(COND
((EQ pf (QUOTE StoreUnmarked)) (* Anything which is not supposed to count as changing
the object should not be stored on the file)
(SETQ ls NIL)))
(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: "26-DEC-83 15:20")
(* * 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 (GetEntityFromUID 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 "←"])
(SplitAtom
[LAMBDA (atom splitChar) (* dgb: "22-JUN-82 11:14")
(* * Used to split method names etc at splitChar. Takes an atom and a char and returns a list of two atoms.
e.g. SplitAtom (A.B %.) -> (A B) Returns NIL if splitChar is not in atom)
(PROG ((pos (STRPOS splitChar atom)))
(RETURN (COND
((NULL pos)
NIL)
(T (CONS (SUBATOM atom 1 (SUB1 pos))
(SUBATOM atom (ADD1 pos])
(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 INSTANCES) (QUOTE FILEPKGCOMS) (QUOTE ([COM MACRO (INSTANCES
(E (PrttyInstances (QUOTE INSTANCES]
(TYPE DESCRIPTION "instances" GETDEF
GetInstanceSource))))
(PUTDEF (QUOTE METHODS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (COMS * (METHCOM . X)))
CONTENTS TypeInMethods)
(TYPE DESCRIPTION "methods" GETDEF
GetInstanceSource))))
(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))))
(* 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 )
)
(PUTPROPS LOOPSPRINT COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2329 12341 (AtMacro 2339 . 5249) (AtMacroConstruct 5251 . 6329) (DataType 6331 . 6596)
(DollarMacro 6598 . 7032) (GetLispClass 7034 . 7379) (HPRINTCLASS 7381 . 7730) (HPRINTINSTANCE 7732 .
8107) (HREADCLASS 8109 . 8248) (HREADINSTANCE 8250 . 8400) (HashMacro 8402 . 10474) (InitializeLOOPS
10476 . 11118) (LoopsSyntax 11120 . 11514) (PrettyPrintInstance 11516 . 11789) (SETALLSYNTAX 11791 .
12064) (TRANS@$ 12066 . 12339)) (12857 30947 (DEFCLASS 12867 . 14081) (DEFCLASSES 14083 . 14599) (
DEFINST 14601 . 15064) (DEFINSTANCES 15066 . 16032) (DollarPrintOut 16034 . 16496) (EntityAddress
16498 . 16621) (GetClassValuePrintOut 16623 . 17610) (GetValuePrintOut 17612 . 18566) (LoopsPPMacros
18568 . 19272) (PCVPrintOut 19274 . 20141) (PInstance 20143 . 20967) (PVPrintOut 20969 . 21810) (
PrettyPrintClass 21812 . 22321) (PrintActiveValue 22323 . 23563) (PrintClass 23565 . 23839) (
PrintDefInstances 23841 . 24359) (PrintInstance 24361 . 25956) (PrintOut@ 25958 . 26341) (PrintOut@@
26343 . 26662) (PrintOut←@ 26664 . 27370) (PrintOut←@@ 27372 . 28081) (PrttyClasses 28083 . 28477) (
PrttyInstances 28479 . 29236) (PushClassValuePrintOut 29238 . 29387) (PushValuePrintOut 29389 . 29532)
(PutClassValuePrintOut 29534 . 29681) (PutValuePrintOut 29683 . 29824) (SplitAtom 29826 . 30312) (
VarPrintOut 30314 . 30945)))))
STOP