(FILECREATED "20-SEP-83 11:59:33" {INDIGO}<LOOPS>SOURCES>LOOPSSTRUC.;6 59279
changes to: (FNS PutValue GetValue)
previous date: " 9-SEP-83 14:31:42" {INDIGO}<LOOPS>SOURCES>LOOPSSTRUC.;5)
(PRETTYCOMPRINT LOOPSSTRUCCOMS)
(RPAQQ LOOPSSTRUCCOMS [(* LOOPS --. Written by Daniel G. Bobrow and Mark Stefik 1981-1983 - See the
LOOPS Manual)
(* Copyright (c)
Xerox Corporation 1983)
(* * Basic records, operations and macros for dealing with implementation of classes and
instances)
(RECORDS OBJECT class instance Entity activeValue)
(* * Variables and constants used by LOOPS)
(CONSTANTS (NotSetValue (QUOTE ?)))
(GLOBALVARS AllObjectNames BrokenVariables CurrentEnvironment CurrentEnvironment
CurrentNameTable DefaultComment DefaultEnvironment DefaultLayer DefaultObject
FirstEnvFlg GlobalEnvironment GlobalEnvironment GlobalNameTable
ImplicitReplaceFns LASTCLASS LastDefaultValue LispClassTable LoadingKernelFlg
NETNUMBER NotSetValue OBJECT OpenEnvironments WritingLayerFlg OpenKBFiles)
(VARS * LOOPSINITVARS)
(* * Access macros)
(MACROS * ACCESSMACROS)
(* * Interface Functions)
(FNS * INTERFACEFNS)
(* * Functions which build and change structure)
(FNS * STRUCFNS)
(ADDVARS (NLAMA DEFINST DEFINSTANCES DEFCLASS DEFCLASSES @ @@ ←@ ←@@))
(* Copyright (c)
1982 by Xerox Corporation)
(* * Templates for masterscope, plus patch given by Larry Masinter to add SEND as a verb to
Masterscope)
(TEMPLATES * LOOPSSTRUCTEMPLATES)
[P (ADDTOVAR TABLE.TO.NOTICED (0 SEND))
(APPENDTOVAR MSFNDATA (SEND ASDF))
(MSSETUP (QUOTE ((SEND SENDS SENDING SENT]
(ADVISE MSVBTABLES)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* LOOPS --. Written by Daniel G. Bobrow and Mark Stefik 1981-1983 - See the LOOPS Manual)
(* Copyright (c) Xerox Corporation 1983)
(* * Basic records, operations and macros for dealing with implementation of classes and
instances)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD OBJECT (CLASS CHANGEDFLG OBJUID VARNAMES VARDESCRS))
(DATATYPE class (metaClass classChangedFlg classUnitRec ivNames ivDescrs localIVs cvNames cvDescrs
className supers subClasses otherClassDescription selectors methods
otherMethodDescription localSupers))
(DATATYPE instance (class instChangedFlg instUnitRec iNames iDescrs otherIVs))
(DATATYPE Entity (localRecord UID storedIn))
(DATATYPE activeValue (localState getFn putFn))
]
(/DECLAREDATATYPE (QUOTE class)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER)))
(/DECLAREDATATYPE (QUOTE instance)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)))
(/DECLAREDATATYPE (QUOTE Entity)
(QUOTE (POINTER POINTER POINTER)))
(/DECLAREDATATYPE (QUOTE activeValue)
(QUOTE (POINTER POINTER POINTER)))
(* * Variables and constants used by LOOPS)
(DECLARE: EVAL@COMPILE
(RPAQQ NotSetValue ?)
(CONSTANTS (NotSetValue (QUOTE ?)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS AllObjectNames BrokenVariables CurrentEnvironment CurrentEnvironment
CurrentNameTable DefaultComment DefaultEnvironment DefaultLayer DefaultObject FirstEnvFlg
GlobalEnvironment GlobalEnvironment GlobalNameTable ImplicitReplaceFns LASTCLASS
LastDefaultValue LispClassTable LoadingKernelFlg NETNUMBER NotSetValue OBJECT
OpenEnvironments WritingLayerFlg OpenKBFiles)
)
(RPAQQ LOOPSINITVARS (BASEFNS DefaultComment LOOPSFREEVARS LeafInstanceFlg WritingSummaryFlg
(TTYIN?=FN (QUOTE GetMethodArgs))
(DEditLinger NIL)
(OutInstances NIL)
(PPDefault T)
(PrintStatusWindow PROMPTWINDOW)
(FirstEnvFlg)
(WritingLayerFlg)
(LASTCLASS)
(BrokenVariables)
(ErrorOnNameConflict)
(DefaultKBName NIL)
(CurrentNameTable NIL)
(AllObjectNames NIL)
[GlobalNameTable (OR (LISTP (GETTOPVAL (QUOTE GlobalNameTable)))
(CONS (HARRAY 128]
[LispClassTable (OR (LISTP (GETTOPVAL (QUOTE LispClassTable)))
(CONS (HARRAY 16]
(VarNameIndexes NIL)
(OpenKBFiles)))
(RPAQQ BASEFNS (BlankInstance DumpInstanceFacts FillIVs FillInst GetIVDescr GetIVHere GetValue
GetValueOnly IVSource PutValue PutValueOnly))
(RPAQQ DefaultComment NIL)
(RPAQQ LOOPSFREEVARS (AFTERLOGOUTFORMS AFTERSYSOUTFORMS AddDeleteMenu AllObjectNames BOLDFONT
BrokenVariables Browser COMMENTFONT COMPILE.EXT
ClassIVsInspectTitleMenu ClassInspectTitleMenu
CurrentEnvironment CurrentNameTable DB.FRONTUI DB.NEXTUIDUMP
DB.UICOUNT DB.UIDUMPINCR DB.UIFILENAME DB.UIREC DEFAULTFONT
DEFAULTPRINTINGHOST DefaultComment DefaultKBName DefaultObject
EDITRDTBL ErrorOnNameConflict FILERDTBL FIRSTCOL FIRSTNAME
GlobalEnvironment GlobalNameTable INITIALS INITIALSLST IT
ImplicitReplaceFns InspectMenu InspectOrPropsMenu
InstanceTitleMenu LAMBDAFONT LASTCLASS LASTWORD LOGINHOST/DIR
LOOPSAFTERSYSOUTFORMS LOOPSFILES LastDefaultValue
LispClassTable NETNUMBER NotSetValue OBJECT OutInstances
PPDefault PROMPTWINDOW PRTTYFILE SYSOUTGAG SYSTEMFILES
USERNAME UnnamedInstances VarNameIndexes WritingLayerFlg
assocKBNames changedEntities changedKBs classForMethod
fileEntities kbName latticeBrowser namedEntities object
objectNames oldClassForMethod))
(RPAQQ LeafInstanceFlg T)
(RPAQQ WritingSummaryFlg NIL)
(RPAQQ TTYIN?=FN GetMethodArgs)
(RPAQQ DEditLinger NIL)
(RPAQQ OutInstances NIL)
(RPAQQ PPDefault T)
(RPAQ PrintStatusWindow PROMPTWINDOW)
(RPAQQ FirstEnvFlg NIL)
(RPAQQ WritingLayerFlg NIL)
(RPAQQ LASTCLASS NIL)
(RPAQQ BrokenVariables NIL)
(RPAQQ ErrorOnNameConflict NIL)
(RPAQQ DefaultKBName NIL)
(RPAQQ CurrentNameTable NIL)
(RPAQQ AllObjectNames NIL)
(RPAQ GlobalNameTable (OR (LISTP (GETTOPVAL (QUOTE GlobalNameTable)))
(CONS (HARRAY 128))))
(RPAQ LispClassTable (OR (LISTP (GETTOPVAL (QUOTE LispClassTable)))
(CONS (HARRAY 16))))
(RPAQQ VarNameIndexes NIL)
(RPAQQ OpenKBFiles NIL)
(* * Access macros)
(RPAQQ ACCESSMACROS ($ /PutNth @ @@ Class ClassVariables FetchCIVDescr FetchCVDescr FetchIVDescr
FetchIVDescr! FindIndex FindVarIndex GetCIVNth GetClassDescr GetNth GetValue
GetVarNth InstanceVariables MKNAME Modified Modified? NDescrs NotSetValue
ObjGetProp ObjPutProp ObjRealValue ObjRemProp ObjSetValue Object? PutIVDescr
PutNth PutValue PutVarNth Supers ←@ ←@@))
(DECLARE: EVAL@COMPILE
(PUTPROPS $ MACRO [name (LIST (QUOTE GetObjectRec)
(KWOTE (CAR name])
(PUTPROPS /PutNth MACRO ((list index entry)
(/RPLACA (FNTH list index)
entry)))
(PUTPROPS @ MACRO (arg (Parse@ arg (QUOTE IV))))
(PUTPROPS @@ MACRO (arg (Parse@ arg (QUOTE CV))))
(PUTPROPS Class MACRO [OPENLAMBDA (self)
(COND
((Object? self)
(fetch CLASS of self))
(T (GetLispClass self])
(PUTPROPS ClassVariables MACRO ((self)
(APPEND (fetch (class cvNames) of self))))
(PUTPROPS FetchCIVDescr MACRO [(self varName) (* dgb: "25-JAN-82 15:48")
(* * Find the description list for the named variable in a class, returning NIL if none is there.)
(PROG NIL (* Short circuit GetNth with embedded RETURN if no index
found)
(RETURN (GetNth (fetch VARDESCRS of self)
(OR (FindIndex varName (fetch VARNAMES
of self))
(RETURN NIL])
(PUTPROPS FetchCVDescr MACRO [(classRec varName)
(PROG [(index (FindIndex varName (fetch cvNames of classRec]
(RETURN (COND
(index (GetNth (fetch cvDescrs of classRec)
index])
(PUTPROPS FetchIVDescr MACRO [OPENLAMBDA (self varName) (* dgb: "27-JAN-82 11:07")
(* * Find the description list for the named variable, using the varIndex if given, computing it otherwise.
If list is NIL in instance, and if createDescrFlg = T then create a local description list in the instance)
(COND
((NOT (type? instance self))
(ERROR self "not instance for FetchIVDescr"))
(T (PROG (varIndex descr)
(DECLARE (LOCALVARS varIndex descr))
(SETQ varIndex (FindVarIndex varName self))
(RETURN (COND
(varIndex (GetVarNth self varIndex))
((SETQ descr
(ASSOC varName
(fetch otherIVs
of self)))
(* * non standard instance variables are stored on an ALIST in otherIVs)
(CDR descr))
(T (← self IVMissing varName NIL])
(PUTPROPS FetchIVDescr! MACRO [OPENLAMBDA (self varName)
(PROG (varIndex descr)
(* * Find the description list for the named variable. If list is NIL in instance, then create one.)
(DECLARE (LOCALVARS . T))
(SETQ varIndex (FindVarIndex varName self))
(RETURN (COND
(varIndex (SETQ descr (GetVarNth self
varIndex))
[COND
((NULL descr)
(* Create initial description list with
value=NotSetValue)
(PutVarNth self varIndex
(SETQ descr
(LIST
NotSetValue]
descr)
((SETQ descr (ASSOC varName
(fetch otherIVs
of self)))
(* non standard IVs are stored on an ALIST in otherIVs)
[COND
((NULL (CDR descr))
(RPLACD descr (LIST NotSetValue]
(CDR descr))
(T (← self IVMissing varName T])
(PUTPROPS FindIndex MACRO [LAMBDA (entry table)
(PROG ((POS 0))
LP (COND
((EQ entry (CAR table))
(RETURN POS))
((NULL (SETQ table (CDR table)))
(RETURN NIL))
(T (SETQ POS (ADD1 POS))
(GO LP])
(PUTPROPS FindVarIndex MACRO (OPENLAMBDA (name obj)
(FindIndex name (fetch VARNAMES of obj))))
(PUTPROPS GetCIVNth MACRO (OPENLAMBDA (obj n)
(GetNth (fetch VARDESCRS of obj)
n)))
(PUTPROPS GetClassDescr MACRO (OPENLAMBDA (class)
(CONS (fetch metaClass of class)
(fetch otherClassDescription of class))))
(PUTPROPS GetNth MACRO [OPENLAMBDA (table index)
(CAR (FNTH table (ADD1 index])
(PUTPROPS GetValue MACRO (arg (ComputeGetValue arg)))
(PUTPROPS GetVarNth MACRO (OPENLAMBDA (obj n)
(PROG (descrs↑)
(DECLARE (LOCALVARS . T))
LP [AND (SETQ descrs↑ (fetch VARDESCRS of obj))
(RETURN (\GETBASEPTR (\GETBASEPTR descrs↑ 0)
(LLSH n 1]
(ReadLeafObj obj)
(GO LP))))
(PUTPROPS InstanceVariables MACRO [(self)
(APPEND (fetch VARNAMES of self)
(for p in (fetch otherIVs of self) collect (CAR p])
(PUTPROPS MKNAME MACRO ((X) (* Converts from file form of name to in core form)
(MKATOM X)))
(PUTPROPS Modified MACRO ((object localState) (* MJS: " 3-SEP-81 15:47")
(replace CHANGEDFLG of object with localState)))
(PUTPROPS Modified? MACRO [LAMBDA (object) (* MJS: " 3-SEP-81 15:48")
(fetch CHANGEDFLG of object])
(PUTPROPS NDescrs MACRO ((n)
(ARRAY n (QUOTE POINTER)
NIL 0)))
(PUTPROPS NotSetValue MACRO ((arg)
(EQ NotSetValue arg)))
(PUTPROPS ObjGetProp MACRO [OPENLAMBDA (descr propName) (* Called by all fetch fns. Gets value in description
list. Does not check for activeValues.)
(COND
((LITATOM descr)
NotSetValue)
((NULL propName)
(CAR descr))
(T (for tail on (CDR descr) by (CDDR tail)
do [COND
((EQ propName (CAR tail))
(RETURN (CADR tail]
finally (RETURN NotSetValue])
(PUTPROPS ObjPutProp MACRO [LAMBDA (descr propName value)
(* * Called to put a new value on a decr list by all the Store fns. descr is a non-null list whose first element
is a value (not a property) and whose remaining elements form a property list. Adds property if no value there
already.)
(COND
((NULL propName)
(RPLACA descr value)
value)
(T (for tail on descr
bind (pn ← propName)
(val ← value)
by (CDDR tail) do (COND
((NULL (CDR tail))
(* Add property if not there already.)
(RPLACD tail (LIST pn val))
(RETURN val))
((EQ pn (CADR tail))
(* Replace value if old value found.)
(RPLACA (CDDR tail)
val)
(RETURN val])
(PUTPROPS ObjRealValue MACRO ((self varName value propName type)
(* Called by Fetches and Gets which want to notice activeValues. type is one of NIL for instance variables, CLASS
for class properties, METHOD for method properties and CV for class variables and properties.
Returns either the value found or the result of evaluating the GETFN)
(COND
[(type? activeValue value)
(PROG ((fn (fetch getFn of value))
(ls (GetLocalState value self varName propName type)))
(RETURN (COND
(fn (AVApply* fn self varName ls propName value
type))
(T ls]
(T value))))
(PUTPROPS ObjRemProp MACRO [OPENLAMBDA (descr propName)
(PROGN
(* descr is a non-null list whose first element is a value (not a property) and whose remaining elements form a
property list. Removes a property from that list. RETURNS NIL if not found, propname otherwise)
(for tail on descr by (CDDR tail)
do (COND
((NULL (CDR tail))
(RETURN NIL))
((EQ propName (CADR tail))
(RPLACD tail (CDDDR tail))
(RETURN propName])
(PUTPROPS ObjSetValue MACRO ((self varName newValue descr aValue propName type)
(* Called by anyone who wants to set a value of a variable or property of any kind. Does the checking for active
values. The argument type is NIL for InstanceVariables, and otherwise is one of CV, CLASS, METHOD)
(COND
[(type? activeValue aValue)
(PROG ((fn (fetch putFn of aValue)))
(RETURN (COND
(fn (AVApply* fn self varName newValue propName
aValue type))
(T (PutLocalState aValue newValue self varName
propName type]
(T (Modified self T)
(COND
(propName (ObjPutProp descr propName newValue))
(T (RPLACA descr newValue)))
newValue))))
(PUTPROPS Object? MACRO (OPENLAMBDA (obj)
(OR (type? instance obj)
(type? class obj))))
(PUTPROPS PutIVDescr MACRO (OPENLAMBDA (obj ivName ivDescr)
(PROG (foundIndex localDescr othIVList)
LP [COND
((SETQ foundIndex (FindIndex ivName
(fetch VARNAMES
of obj)))
(* * Put the description in the instance)
(PutVarNth obj foundIndex ivDescr))
((NUMBERP (SETQ othIVList (fetch otherIVs
of obj)))
(ReadLeafObj obj)
(GO LP))
((SETQ localDescr (ASSOC ivName othIVList))
(* Nonstandard iv, currently here)
(RPLACD localDescr ivDescr))
(T (replace otherIVs of obj
with (NCONC1 othIVList (CONS ivName ivDescr]
(RETURN ivDescr))))
(PUTPROPS PutNth MACRO ((list index entry)
(RPLACA (FNTH list (ADD1 index))
entry)))
(PUTPROPS PutValue MACRO (arg (ComputePutValue arg)))
(PUTPROPS PutVarNth MACRO (OPENLAMBDA (obj n desc)
(PROG (descrs↑)
(DECLARE (LOCALVARS . T))
LP (AND (SETQ descrs↑ (fetch VARDESCRS of obj))
(RETURN (SETA descrs↑ n desc)))
(ReadLeafObj obj)
(GO LP))))
(PUTPROPS Supers MACRO ((classRec)
(fetch supers of classRec)))
(PUTPROPS ←@ MACRO (arg (ParsePut@ arg (QUOTE IV))))
(PUTPROPS ←@@ MACRO (arg (ParsePut@ arg (QUOTE CV))))
)
(* * Interface Functions)
(RPAQQ INTERFACEFNS (ComputeGetValue ComputePutValue DumpClassFacts DumpInstanceFacts DumpPruneDescr
DumpPruneDescr1 EntityModified FastClassInitialize FillIVs
FillInClass FillInClass1 GetEntityRec GetIVDescr GetIVHere
GetInitialValue GetObjFromUID GetObjectName1 GetValue
GetValueOnly GetClassRec GetObjectName GetObjectRec NameEntity
NewEntity PutValue PutValueOnly UnNameEntity))
(DEFINEQ
(ComputeGetValue
[LAMBDA (arg) (* dgb: " 6-DEC-82 13:40")
(PROG (varExpr varName index)
(RETURN (COND
([NOT (AND (EQ [CAR (LISTP (SETQ varExpr (CADR arg]
(QUOTE QUOTE))
[NUMBERP (SETQ index (CDR (FASSOC (CADR varExpr)
VarNameIndexes]
(NULL (CDDR arg]
(QUOTE IGNOREMACRO))
(T (BQUOTE (PROG (descr (self , (CAR arg)))
(RETURN (COND
((AND (type? instance self)
(SETQ descr (GetVarNth self , index))
(NEQ (SETQ descr (CAR descr))
NotSetValue)
(NOT (type? activeValue descr)))
descr)
(T (GetIt self , (CADR arg)
,
(CADDR arg)
(QUOTE IV])
(ComputePutValue
[LAMBDA (arg) (* dgb: " 6-DEC-82 13:40")
(* Function for implementing the MACRO for PutValue)
(PROG (varExpr varName index)
(RETURN (COND
([NOT (AND (EQ [CAR (LISTP (SETQ varExpr (CADR arg]
(QUOTE QUOTE))
[NUMBERP (SETQ index (CDR (FASSOC (CADR varExpr)
VarNameIndexes]
(NULL (CDDDR arg]
(QUOTE IGNOREMACRO))
(T (BQUOTE (PROG (oldV descr (self , (CAR arg)))
(RETURN (COND
((AND (type? instance self)
(SETQ descr (GetVarNth self , index))
(NEQ (SETQ oldV (CAR descr))
NotSetValue)
(NOT (type? activeValue oldV)))
(RPLACA descr , (CADDR arg)))
(T (PutIt self , (CADR arg)
,
(CADDR arg)
,
(CADDDR arg)
(QUOTE IV])
(DumpClassFacts
[LAMBDA (class fileHandle) (* dgb: "29-APR-83 10:34")
(* * Invoked when dumping a class onto a kb. Called by (← class DumpFacts))
(PROG ((filePos (GETFILEPTR fileHandle)))
(PRINT (QUOTE C)
fileHandle)
(PRINT (fetch className of class)
fileHandle)
(PRINT (fetch metaClass of class)
fileHandle)
(PRINT (fetch supers of class)
fileHandle)
(PRINT (fetch localIVs of class)
fileHandle)
(for nm in (fetch localIVs of class) do (PRINT (FetchCIVDescr class nm)
fileHandle))
(PRINT (fetch cvNames of class)
fileHandle)
(PRINT (DumpPruneDescr (fetch cvDescrs of class))
fileHandle)
(PRINT (DumpPruneDescr1 (fetch otherClassDescription of class))
fileHandle)
(PRINT (\ListFromBlock (fetch selectors of class))
fileHandle)
(PRINT (\ListFromBlock (fetch methods of class))
fileHandle)
(PRINT (DumpPruneDescr1 (\ListFromBlock (fetch otherMethodDescription of class)))
fileHandle)
(RETURN filePos])
(DumpInstanceFacts
[LAMBDA (instanceRec fileHandle) (* DECLARATIONS: (RECORD fileInstance
(cls . idesc)))
(* dgb: " 6-DEC-82 13:41")
(* * This prints an expression on the file which specifies the contents of an instance record.
Called by (← object DumpFacts))
(PROG ((filePos (GETFILEPTR fileHandle)))
(PRIN1 (QUOTE i)
fileHandle)
(PRINT (create fileInstance
cls ←(fetch class of instanceRec)
idesc ←(NCONC
[for name exceptions descr in (fetch iNames of instanceRec) as i
from 0 when [NEQ (QUOTE Any)
(SETQ exceptions (GetValueOnly instanceRec name
(QUOTE DontSave]
collect (SETQ descr (GetVarNth instanceRec i))
(* Collect a list of properties, omitting those on the list which is the value of the property DontSave.
Value should be on that list if the value is not to be dumped.)
(CONS name (COND
((EQ NotSetValue exceptions)
descr)
((NULL (CDR descr))
(COND
((FMEMB (QUOTE Value)
exceptions)
NIL)
(T descr)))
(T (CONS (COND
((FMEMB (QUOTE Value)
exceptions)
(* value is to be omitted)
NotSetValue)
(T (CAR descr)))
(for pair on (CDR descr) by (CDDR pair)
when (NOT (FMEMB (CAR pair)
exceptions))
join (LIST (CAR pair)
(CADR pair]
(fetch otherIVs of instanceRec)))
fileHandle)
(RETURN filePos])
(DumpPruneDescr
[LAMBDA (descrList) (* dgb: "12-AUG-82 10:40")
(* Collect a list of properties for each descr, omitting those on the list exceptions. Value is the property name
for the value Called by DumpClassFacts.)
(for descr dontSaveList in descrList collect
(* Compute dontSaveList -- a list of properties not to be saved, (QUOTE Any) if none are to be saved, or
NotSetValue if all are to be saved.)
(SETQ dontSaveList (OR (LISTGET (CDR descrList)
(QUOTE DontSave))
NotSetValue))
(COND
((EQ dontSaveList (QUOTE Any))
NIL)
((EQ dontSaveList NotSetValue)
descr)
((NULL (CDR descr))
(COND
((FMEMB (QUOTE Value)
dontSaveList)
NIL)
(T descr)))
(T (CONS (COND
((FMEMB (QUOTE Value)
dontSaveList)
(* value is to be omitted)
NotSetValue)
(T (CAR descr)))
(for pair on (CDR descr)
by (CDDR pair)
when (NOT (FMEMB (CAR pair)
dontSaveList))
join (LIST (CAR pair)
(CADR pair])
(DumpPruneDescr1
[LAMBDA (descrList) (* dgb: "12-AUG-82 10:40")
(* Collect a list of properties for each descr, omitting those on the list exceptions. Value is the property name
for the value Called by DumpClassFacts. This function is used for straight property lists on otherClassDescription
and otherMethodDescription)
(for descr dontSaveList in descrList collect
(* Compute dontSaveList -- a list of properties not to be saved, (QUOTE Any) if none are to be saved, or
NotSetValue if all are to be saved.)
(SETQ dontSaveList (OR (LISTGET descrList
(QUOTE DontSave))
NotSetValue))
(COND
((EQ dontSaveList (QUOTE Any))
NIL)
((EQ dontSaveList NotSetValue)
descr)
((NULL (CDR descr))
(COND
((FMEMB (QUOTE Value)
dontSaveList)
NIL)
(T descr)))
(T (for pair on descr by (CDDR pair)
when (NOT (FMEMB (CAR pair)
dontSaveList))
join (LIST (CAR pair)
(CADR pair])
(EntityModified
[LAMBDA (entity) (* mjs: "12-MAY-82 15:08")
(* Tests to see if this entity has been changed. If objectRec is a number, then entity is not loaded, and so could
not have been changed)
(PROG ((objectRec (fetch localRecord of entity)))
(RETURN (AND objectRec (NOT (NUMBERP objectRec))
(Modified? objectRec])
(FastClassInitialize
[LAMBDA (class self) (* dgb: "18-JAN-83 17:33")
(* Run through the IVs in the class and the properties local to the class, checking for AtCreation.
When found, insert value. Assumes ivDescrs is a list of lists)
(for varName in (fetch ivNames of class) as descr in (fetch ivDescrs of class) bind value
do (COND
([NEQ NotSetValue (SETQ value (FireInit self varName (CAR descr]
(PutValueOnly self varName value)))
(for propTail propName on (CDR descr) by (CDDR propTail)
do (COND
([NEQ NotSetValue (SETQ value (FireInit self varName (CADR descr]
(PutValueOnly self varName value (CAR descr])
(FillIVs
[LAMBDA (self class descrList unmodifiedFlg) (* dgb: "28-APR-83 17:47")
(* Given an instance, a class and a list of (name . IVdescription), fill in the instance appropriately.
unmodifiedFlg=T in just those cases in which the object is being read in from a file)
(SETQ self (BlankInstance class self unmodifiedFlg)) (* In the case where self was NIL, then a new instance
would have been created.)
(for d in descrList do (PutIVDescr self (CAR d)
(CDR d)))
self])
(FillInClass
[LAMBDA (class classFileForm) (* DECLARATIONS: (RECORD classFileDescription
(mc lvn lvd cvn cvd cn sup ocd sel met omd)))
(* dgb: "29-APR-83 10:16")
(* * Fills in a Class in core from a file description. Used in ReadFacts)
(replace metaClass of class with (fetch (classFileDescription mc) of classFileForm))
(replace cvNames of class with (fetch (classFileDescription cvn) of classFileForm))
(replace cvDescrs of class with (fetch (classFileDescription cvd) of classFileForm))
(replace className of class with (fetch (classFileDescription cn) of classFileForm))
(replace otherClassDescription of class with (fetch (classFileDescription ocd) of classFileForm))
(replace selectors of class with (\BlockFromList (fetch (classFileDescription sel) of
classFileForm)))
(replace methods of class with (\BlockFromList (fetch (classFileDescription met) of classFileForm)
))
(replace otherMethodDescription of class with (\BlockFromList (fetch (classFileDescription omd)
of classFileForm)))
(replace ivNames of class with (replace localIVs of class with (fetch (classFileDescription
lvn)
of classFileForm)))
(* * Put local variables in as all the instance variables because no supers are installed yet.
When supers are installed, the rest will be inherited)
(replace ivDescrs of class with (fetch lvd of classFileForm))
(InstallSupers class (fetch sup of classFileForm])
(FillInClass1
[LAMBDA (classRec fileHandle) (* dgb: "29-APR-83 10:17")
(* New (12 Aug 82) Format for classes on files. Separate items on file for-- MetaClass supers localIVs, cvNames,
localIVdescrs, CVValues,otherClassDescription, selectors, methods and otherMethodDescription.
Does an UpdateClassIVs to make sure that class structure is right for instances read in during reading of values.)
(PROG (localNames fakeDescrs supers)
(replace className of classRec with (READ fileHandle))
(replace metaClass of classRec with (READ fileHandle))
(SETQ supers (READ fileHandle))
(replace localIVs of classRec with (SETQ localNames (READ fileHandle)))
(replace ivNames of classRec with localNames)
(* * To install a class set up the ivnames to be equal to localIVs, and have the values be the defaults.
In this case we are creating dummy default value list)
[replace ivDescrs of classRec with (SETQ fakeDescrs (for n in localNames
collect (CONS NotSetValue]
(* The following InstallSupers fills in the supers and
does an UpdateClassIV.)
(InstallSupers classRec supers)
(for fakeDescr in fakeDescrs bind realDescr
do [RPLACA fakeDescr (CAR (SETQ realDescr (READ fileHandle]
(RPLACD fakeDescr (CDR realDescr)))
(replace cvNames of classRec with (READ fileHandle))
(replace cvDescrs of classRec with (READ fileHandle))
(replace otherClassDescription of classRec with (READ fileHandle))
(replace selectors of classRec with (\BlockFromList (READ fileHandle)))
(replace methods of classRec with (\BlockFromList (READ fileHandle)))
(replace otherMethodDescription of classRec with (\BlockFromList (READ fileHandle])
(GetEntityRec
[LAMBDA (uid) (* dgb: " 3-MAR-83 16:33")
(OR (AND CurrentNameTable (GETHASH uid CurrentNameTable))
(GETHASH uid GlobalNameTable)
(ERROR uid "has no corresponding entity in CurrentNameTable"])
(GetIVDescr
[LAMBDA (self varName createDescrFlg) (* dgb: "28-APR-83 17:47")
(* Functional interface for FetchIVDescr for those who
don't need to go fast)
(COND
(createDescrFlg (FetchIVDescr! self varName))
(T (FetchIVDescr self varName])
(GetIVHere
[LAMBDA (self varName propName) (* dgb: "28-APR-83 17:47")
(* Gets the value found in the instance, without
invoking activeValues. Returns NotSetValue if not found
in instance)
(COND
((← self HasIV varName)
(ObjGetProp (FetchIVDescr self varName)
propName))
(T NotSetValue])
(GetInitialValue
[LAMBDA (self varName prop) (* dgb: "18-MAR-83 17:44")
(* Get the value that would be obtained if there were no value stored in the instance. If it is FirstFetch, then
it will actually store it away again)
(ObjRealValue self varName (FetchCIVValueOnly (ffetch class of self)
varName prop)
prop])
(GetObjFromUID
[LAMBDA (uid) (* sm: "28-JAN-83 11:44")
(* * Returns an object given its UID.)
(GetObjectRec (MKNAME uid])
(GetObjectName1
[LAMBDA (value key) (* dgb: " 5-JAN-83 16:23")
(* Find a name for object)
(DECLARE (USEDFREE object))
(COND
((AND (EQ (fetch localRecord of value)
object)
(NEQ key (fetch UID of value)))
(RETFROM (QUOTE GetObjectName)
key T])
(GetValue
[LAMBDA (self varName prop) (* dgb: "28-APR-83 17:47")
(* Used to return the value of an "instance variable" for an object. Calls general Get function for non standard
objects -
GetValue activates getFn if the value is an ActiveValue.)
(COND
[(type? instance self)
(PROG (value (descr (FetchIVDescr self varName)))
[COND
([OR (NULL descr)
(NotSetValue (SETQ value (ObjGetProp descr prop]
(* no value found in the instance or in locally in the
class if self is a class)
(SETQ value (FetchCIVValueOnly (ffetch class of self)
varName prop]
(RETURN (ObjRealValue self varName value prop]
(T (GetIt self varName prop (QUOTE IV])
(GetValueOnly
[LAMBDA (self varName propName) (* dgb: "28-APR-83 17:47")
(* * Like GetValue except that it ignores the special status of ActiveValues and just returns them as a data
structure without activating any procedures)
(COND
((type? class self)
(GetClassIV self varName propName))
((NOT (type? instance self))
(GetItOnly self varName propName (QUOTE IV)))
((NUMBERP varName) (* Here for indexed variables.)
(FetchNthValueOnly self varName propName))
(T (* usual case)
(PROG (value)
[COND
((EQ NotSetValue (SETQ value (ObjGetProp (FetchIVDescr self varName)
propName)))
(* Go up class chain)
(SETQ value (FetchCIVValueOnly (ffetch class of self)
varName propName]
(RETURN value])
(GetClassRec
[LAMBDA (className environment) (* dgb: "27-NOV-82 02:15")
(* Given an atom, returns the class which is named by
that atom. If there is no such definition, returns NIL)
(COND
((type? class className)
className)
(T (PROG ((classRec (GetObjectRec className environment)))
(COND
((AND classRec (NOT (type? class classRec)))
(HELP className " is a defined object, but is not a class.")))
(RETURN classRec])
(GetObjectName
[LAMBDA (object env) (* dgb: " 5-JAN-83 16:25")
(* Returns the name of an object if it has one other
than its UID)
(DECLARE (SPECVARS object))
(PROG NIL
[COND
((type? class object)
(RETURN (ClassName object)))
(env (MAPHASH (GetValue env (QUOTE nameTable))
(FUNCTION GetObjectName1)))
(T (MAPHASH GlobalNameTable (FUNCTION GetObjectName1))
(* Gets here if no RETFROM in GetObjectName1)
(AND CurrentNameTable (MAPHASH CurrentNameTable (FUNCTION GetObjectName1]
(* Should do a RETFROM this function in GetObjectName1
if name has been found. Else return NIL)
(RETURN NIL])
(GetObjectRec
[LAMBDA (name environment) (* dgb: "13-JAN-83 09:20")
(* * Given a name (UID or name), returns the object which is named by that atom. else returns NIL.
The value of the variable environment must be either -
an instance of Environment, or -
NIL meaning the current environment, or -
T meaning the global name table. The GlobalNameTable is used before the CurrentNameTable. This is different than
it was before Aug. 13, 1982)
(PROG (entityRec objectRec nameTable) (* Get the entity record.)
(COND
((Object? name)
(RETURN name)))
(AND (EQ environment T)
(SETQ environment GlobalEnvironment))
(OR [SETQ entityRec (COND
[environment (GETHASH name (GetValue environment (QUOTE nameTable]
(T (OR (GETHASH name GlobalNameTable)
(AND CurrentNameTable (GETHASH name CurrentNameTable]
(RETURN NIL)) (* Return NIL if no entity record found)
[COND
((NUMBERP (SETQ objectRec (fetch localRecord of entityRec)))
(* This means the facts are not yet loaded)
(COND
[(AND environment (NEQ environment CurrentEnvironment))
(RESETVAR CurrentNameTable (GetValue environment (QUOTE nameTable))
(SETQ objectRec (ReadFacts entityRec objectRec]
(T (SETQ objectRec (ReadFacts entityRec objectRec]
(RETURN objectRec])
(NameEntity
[LAMBDA (self name globalNameFlg) (* edited: "30-JUN-83 17:31")
(* * Associate a name with entity in current environment or in global environment if globalNameFlg=T.
An object can have more than one name.)
(PROG (oldEntity entity)
(COND
((OR (NULL name)
(NOT (LITATOM name)))
(ERROR name "Should be an atom to be a name")))
(COND
((NOT (OR (type? instance self)
(type? class self)))
(ERROR self "cannot be named as Entity.")))
LP (SETQ entity (GetEntityRec (UID self T))) (* UID insures that object has a UID and an EntityRec)
(SETQ oldEntity (GetObjectRec name))
(COND
((AND oldEntity (NEQ self oldEntity))
(AND ErrorOnNameConflict (HELPCHECK name
"is already used as a name for an object
in this environment. To continue type OK"))
(← oldEntity UnSetName name)))
(Modified self T) (* Mark as changed even if nothing else happened so new
name will be seen)
(COND
((OR globalNameFlg (NULL CurrentNameTable))
(MARKASCHANGED name (SELECTQ (TYPENAME self)
(instance (QUOTE INSTANCES))
(class (QUOTE classes))
(ERROR self "not an object"))
T)))
[PUTHASH name (OR entity self)
(COND
(globalNameFlg GlobalNameTable)
(T (OR CurrentNameTable GlobalNameTable]
(RETURN self])
(NewEntity
[LAMBDA (facts names kbName nameTable) (* dgb: "19-JAN-83 12:24")
(* * Creates a new entity and names it if name given)
(PROG [newEntity (UID (COND
[(LISTP names)
(MKNAME (CAR (LAST names]
(T (DB-PackUI]
[COND
((NULL names)
(SETQ names (LIST UID)))
((ATOM names)
(SETQ names (LIST names UID]
(SETQ newEntity (create Entity
localRecord ← facts
UID ← UID
storedIn ←(OR kbName DefaultKBName)))
(replace OBJUID of facts with UID)
(SETQ nameTable (OR nameTable CurrentNameTable GlobalNameTable))
(for name in names do (PUTHASH name newEntity nameTable))
(RETURN facts])
(PutValue
[LAMBDA (self varName newValue propName) (* dgb: "28-APR-83 17:47")
(* * Puts newValue as value for varName in self on propname. Activates putFn if current value is an activeValue.)
(COND
[(type? instance self)
(PROG (value (descr (FetchIVDescr! self varName)))
[COND
((EQ NotSetValue (SETQ value (ObjGetProp descr propName)))
(* Value not set locally. Get value from class.)
(SETQ value (ObjGetProp (FetchCIVDescr (Class self)
varName)
propName))
(COND
((type? activeValue value)
(COND
((FMEMB (fetch getFn of value)
ImplicitReplaceFns)
(* * Special case. One of FirstFetch AtCreation. Just puts the new value into the instance)
(RETURN (ObjPutProp descr propName newValue)))
((NEQ (QUOTE SHARED)
(fetch localState of value)) (* Here to copy an active value if it was inherited
unchanged, and is now being changed.)
(Modified self T)
(SETQ value (CopyAV value))
(ObjPutProp descr propName value]
(RETURN (ObjSetValue self varName newValue descr value propName]
(T (PutIt self varName newValue propName (QUOTE IV])
(PutValueOnly
[LAMBDA (self varName newValue propName) (* dgb: "28-APR-83 17:47")
(* * Puts newValue in an varNmae value or property. Overwrites any existing value, even if it is an activeValue.)
(COND
((type? class self) (* Error check for class)
(PutClassIV self varName newValue propName))
[(type? instance self)
(COND
((NUMBERP varName)
(StoreNthValueOnly self varName newValue propName))
(T (Modified self T)
(ObjPutProp (FetchIVDescr! self varName)
propName newValue]
(T (← (OR (GetLispClass self)
(HELP self "has no instance variables."))
PutValueOnly self varName newValue propName])
(UnNameEntity
[LAMBDA (self name environment) (* dgb: "17-SEP-82 00:49")
(* If name actually names self in environment then
delete the association between self and name)
(COND
((OR (AND (NULL name)
(SETQ name (GetObjectName self environment)))
(EQ (GetObjectRec name environment)
self))
(SETQ AllObjectNames (DREMOVE name AllObjectNames))
(Modified self T) (* Mark as changed so that name change will be recorded)
(COND
((AND environment (NEQ environment T))
(PUTHASH name NIL (← environment NameTable)))
(T (* Put in GlobalNameTable)
(PUTHASH name NIL GlobalNameTable) (* and in CurrentNameTable if it exists)
(AND CurrentNameTable (PUTHASH name NIL CurrentNameTable])
)
(* * Functions which build and change structure)
(RPAQQ STRUCFNS (BlankInstance DefineMethod FillInst FireInit IVSource ModifyInstance NameObject
NewClass NewObject NewWithValues SubstInAV TemplateCopy UpdateClassIVs
UpdateIVDescrs))
(DEFINEQ
(BlankInstance
[LAMBDA (class obj unmodifiedFlg) (* dgb: " 6-DEC-82 09:04")
(* Make this instance be a blank with structure determined from the class. If unmodifiedFlg=T then a newly read in
instance. If it is a number, then it is a leaf node)
[COND
((NULL obj) (* By default create one)
(SETQ obj (create instance]
[replace class of obj with (SETQ class (OR (AND class (GetClassRec class))
(OR (fetch CLASS of obj)
OBJECT]
(OR unmodifiedFlg (Modified obj T))
(* * Set up structure from class. This is one place where structure of instances is set up)
[PROG ((ivnms (fetch ivNames of class)))
(replace iNames of obj with ivnms)
(COND
((FIXP unmodifiedFlg) (* A leaf node created. The number is the filePosition
of the object)
(replace otherIVs of obj with unmodifiedFlg)
(replace iDescrs of obj with NIL))
(T (replace otherIVs of obj with NIL) (* Make iDescrs be a POINTER array)
(replace iDescrs of obj with (NDescrs (FLENGTH ivnms]
obj])
(DefineMethod
[LAMBDA (class selector argsOrFn expr) (* dgb: "10-JUN-83 12:02")
(* * Define a new method (or replace an old one). If expr is NIL then argsOrFn should be a function Name, else it
should be a list of arguments, and expr should be the function definition)
(COND
((NOT (LITATOM selector))
(ERROR selector "is not a LIATOM, so cannot be a selector")))
(PROG (fnName file editFlg (className (ClassName class)))
[COND
((SETQ editFlg (NOT (OR argsOrFn expr)))
(SETQ argsOrFn (LIST (QUOTE self)))
(SETQ expr (COPY (QUOTE ( (* New method template)
self]
[COND
((AND argsOrFn (LITATOM argsOrFn))
(SETQ fnName argsOrFn))
(T [COND
[(NULL expr) (* Here if argsOrFn left out)
(SETQ expr argsOrFn)
(SETQ argsOrFn (LIST (QUOTE self]
((NEQ (CAR argsOrFn)
(QUOTE self))
(SETQ argsOrFn (CONS (QUOTE self)
argsOrFn]
[COND
([AND (LISTP expr)
(NOT (LISTP (CAR expr] (* This is a single expression, not an implicit PROGN)
(SETQ expr (LIST expr]
[SETQ expr (FIXEDITDATE (CONS (QUOTE LAMBDA)
(CONS argsOrFn expr]
(SETQ fnName (PACK* className (QUOTE %.)
selector))
(DEFINE (LIST (LIST fnName expr]
(AND [SETQ file (CAR (WHEREIS className (QUOTE CLASSES]
(ADDTOFILE fnName (QUOTE FNS)
file)) (* Put it on same file as class, if it can be found)
(AddMethod class selector fnName)
(COND
(editFlg (← class EditMethod selector)))
(← class CommentMethods (LIST selector)
T)
(RETURN (SETQ LASTWORD fnName])
(FillInst
[LAMBDA (ivSource obj) (* dgb: "28-APR-83 17:47")
(for v in ivSource
do (* Insert new values and properties for each variable
given)
(PutIVDescr obj (CAR v)
(CDR v])
(FireInit
[LAMBDA (self varName expr) (* dgb: "23-NOV-82 01:33")
(* Fire off inital value active values and return value)
(COND
[(type? activeValue expr)
(PROG ((gfn (fetch getFn of expr))
(ls (fetch localState of expr)))
(RETURN (COND
[(FMEMB ls (QUOTE (INITIAL Initial)))
(COND
((LISTP gfn)
(EVAL gfn))
(T (AVApply* gfn self varName]
[(EQ gfn (QUOTE AtCreation))
(COND
((LISTP ls)
(EVAL ls))
(T (AVApply* ls self varName]
(T NotSetValue]
(T NotSetValue])
(IVSource
[LAMBDA (self) (* dgb: "19-APR-83 15:33")
(* Create a list structure form for editing for an
instance. Read in the value from a KB if instance is not
in)
(PROG ((othIVs (fetch otherIVs of self)))
(DECLARE (LOCALVARS . T))
[COND
((FIXP othIVs)
(ReadLeafObj self) (* Need to get other IVs again)
(SETQ othIVs (fetch otherIVs of self]
(RETURN (NCONC (for inm in (fetch iNames of self) as i from 0
collect (CONS inm (GetVarNth self i)))
(APPEND othIVs])
(ModifyInstance
[LAMBDA (classValList) (* dgb: " 5-JUN-83 21:01")
(* Called from DEFINST and used to modify an existing instance after editing, or creating a new instance of the
named class on reading in.)
(PROG (obj UID nameTable class newEntity (className (CAR classValList))
(names (CADR classValList)))
[OR (SETQ class (GetClassRec className))
(PROGN (printout T className " has no class defined for it" T "Defining one now:" T)
(SETQ class (← ($ Class)
New className]
[SETQ UID (MKNAME (COND
((LISTP names) (* Last one is UID)
(SETQ names (REVERSE names))
(pop names))
(T (PROG1 names (SETQ names NIL]
(SETQ obj (GetObjectRec UID))
[COND
[(NULL (CDDR classValList)) (* Just a reference to obj)
(RETURN (OR obj (NewObject class UID]
(obj (BlankInstance class obj))
(T (SETQ obj (NewObject class UID]
(AND names (NameObject obj names))
(FillInst (CDDR classValList)
obj)
(RETURN obj])
(NameObject
[LAMBDA (object names) (* dgb: "19-JAN-83 10:43")
(for name in names bind (entity ←(GetEntityRec (UID object T))) do (PUTHASH name entity
(OR CurrentNameTable
GlobalNameTable)))
object])
(NewClass
[LAMBDA (className metaClass) (* dgb: "16-AUG-82 01:05")
(* Creates a new class of the given name, and returns
the class record as the value.
Does not check for old defintion existing.)
(COND
((NULL className)
(ERROR "A Class must be given a name at creation.
" NIL T))
(T (NewEntity (create class
className ← className
metaClass ←[COND
((type? class metaClass)
metaClass)
(T (GetClassRec (OR metaClass (QUOTE Class]
classChangedFlg ← T)
className])
(NewObject
[LAMBDA (class UID) (* dgb: "19-JAN-83 12:24")
(* Create a new empty object for ModifyInstance for
DEFINST or DEFINSTANCES. Set up inames and idescrs from
class.)
(PROG (newEntity obj)
(OR UID (RETURN NIL)) (* If no UID given, this is a call from DEFINSTANCES and
it is a noop)
[COND
((SETQ obj (GetObjectRec UID)) (* Case in which there is a previously existing object
to be smashed)
(SETQ newEntity (GetEntityRec UID)))
(T (* create a brand new instance)
(SETQ newEntity (create Entity
localRecord ←(SETQ obj (BlankInstance class))
UID ← UID
storedIn ← DefaultKBName))
(replace OBJUID of obj with UID) (* Now make it have names and be associated with UID)
(PUTHASH UID newEntity (OR CurrentNameTable GlobalNameTable]
(RETURN obj])
(NewWithValues
[LAMBDA (class description) (* dgb: " 5-JUN-83 20:52")
(* * Creates a new instance, substituting values given explicitly in description Does not initialize variables in
the usual way.)
(NewEntity (FillIVs NIL class description)
NIL])
(SubstInAV
[LAMBDA (oldLS newLS av) (* dgb: "11-NOV-82 02:29")
(* Substitutes, copying, newLS for oldLS in a nested set
of active values.)
(PROG ((ls (fetch localState of av)))
(RETURN (create activeValue
getFn ←(fetch getFn of av)
putFn ←(fetch putFn of av)
localState ←(COND
((EQ ls oldLS)
newLS)
((NOT (type? activeValue ls)) (* Nested value not found. This is just a copy of av)
ls)
(T (SubstInAV oldLS newLS ls])
(TemplateCopy
[LAMBDA (oldValue alist specSelector) (* dgb: "28-APR-83 18:40")
(* Subroutine of NewTemplateIVs. Copies a value from the Instance Variable Description, making substitutions for
classes appearing in alist. If a class is encountered whose metaClass is Template, then creates new instantiation
recursively using New message.)
(SELECTQ (TYPENAME oldValue)
[activeValue (* Here if oldValue is active value.)
(PROG (newloc newgf newpf (ls (fetch localState of oldValue))
(gf (fetch getFn of oldValue))
(pf (fetch putFn of oldValue)))
(SETQ newloc (TemplateCopy ls alist specSelector))
(SETQ newgf (TemplateCopy gf alist specSelector))
(SETQ newpf (TemplateCopy pf alist specSelector))
(RETURN (COND
((AND (EQ ls newloc)
(EQ pf newpf)
(EQ gf newgf))
(* If no copying done in elements, don't copy now)
oldValue)
(T (create activeValue
localState ← newloc
getFn ← newgf
putFn ← newpf]
[LISTP (* Here if oldValue is a list.
Invoke TemplateCopy recursively on the elements of the
list. specSelector)
(COND
((EQ (CAR oldValue)
(QUOTE *))
oldValue)
(T (PROG ((A (TemplateCopy (CAR oldValue)
alist specSelector))
(D (TemplateCopy (CDR oldValue)
alist specSelector)))
(RETURN (COND
((AND (EQ A (CAR oldValue))
(EQ D (CDR oldValue)))
(* If no copying done in elements, don't copy now)
oldValue)
(T (CONS A D]
(class (COND
[(← oldValue InstOf!(QUOTE Template))
(* If class is a template, then return the substitution.
If class is not on alist, then first instantiate it
recursively.)
(OR (CDR (FASSOC oldValue alist))
(COND
(specSelector (DoMethod oldValue specSelector NIL alist))
(T (← oldValue New alist]
(T (* Non-template classes treated as constants.)
oldValue)))
oldValue])
(UpdateClassIVs
[LAMBDA (classRec) (* dgb: "29-APR-83 19:29")
(* Called from UpdateSubClassIVs to update the Instance
variable lists in this subclass and all its lower subs)
(/replace ivDescrs of classRec with (for name in (fetch localIVs of classRec)
collect (FetchCIVDescr classRec name)))
(* * Make names and descrs in class be just those defined locally, so that UpdateIVDescrs works)
(/replace ivNames of classRec with (fetch localIVs of classRec))
(* Now update the descrs from the supers, and then the subs go down to each of the subs. Don't mark as changed,
since it is only the super that has really changed.)
(/replace supers of classRec with (ComputeSupersList (fetch localSupers of classRec)))
(UpdateIVDescrs classRec])
(UpdateIVDescrs
[LAMBDA (classRec) (* dgb: "11-NOV-82 02:30")
(* * Starts with lvNames=ivNames and descrs set correspondingly. Called from UpdateIVDescrs.
Fetches all the names of IVs defined for this class directly, or indirectly through supers, and creates the
appropriate ivNames and ivDescrs)
(PROG (varNames) (* Set varNames to be the list of names as inherited
from the supers list of this object)
[for class bind names first (SETQ varNames (APPEND (fetch localIVs of classRec)))
in (Supers classRec) do (* varNames is a copy of that in classRec)
(for name in [SETQ names (COND
((LISTP class)
(* Take only the local variables.
This is a mixin)
(fetch localIVs of (CAR class)))
(T (fetch ivNames of class]
do [COND
((FMEMB name varNames)
(* remove name from later in list.
Order should be as though we had created list starting
from the top of the supers hierarchy)
(SETQ varNames (DREMOVE name varNames]
finally (SETQ varNames (APPEND names varNames]
(* Now collect the descr for each variable, bringing
down the nearest description found by going up the
supers list)
[/replace ivDescrs of classRec
with (for name in varNames collect (OR (FetchCIVDescr classRec name)
(for class in (Supers classRec)
do (RETURN (OR (FetchCIVDescr (ExtractObj
class)
name)
(GO MORE)))
MORE]
(/replace ivNames of classRec with varNames)) (* Now update subclasses)
(for sub in (fetch subClasses of classRec) do (UpdateClassIVs (ExtractObj sub])
)
(ADDTOVAR NLAMA DEFINST DEFINSTANCES DEFCLASS DEFCLASSES @ @@ ←@ ←@@)
(* Copyright (c) 1982 by Xerox Corporation)
(* * Templates for masterscope, plus patch given by Larry Masinter to add SEND as a verb to
Masterscope)
(RPAQQ LOOPSSTRUCTEMPLATES (@ @@ ← ←New ←Super (QUOTE ←)
(QUOTE ←New)
(QUOTE ←Super)))
(SETTEMPLATE (QUOTE @)
(QUOTE (EVAL .. EVAL)))
(SETTEMPLATE (QUOTE @@)
(QUOTE (CALL .. EVAL)))
(SETTEMPLATE (QUOTE ←)
(QUOTE (EVAL SEND .. EVAL)))
(SETTEMPLATE (QUOTE ←New)
(QUOTE (EVAL SEND .. EVAL)))
(SETTEMPLATE (QUOTE ←Super)
(QUOTE (EVAL SEND .. EVAL)))
(SETTEMPLATE (QUOTE (QUOTE ←))
NIL)
(SETTEMPLATE (QUOTE (QUOTE ←New))
NIL)
(SETTEMPLATE (QUOTE (QUOTE ←Super))
NIL)
(ADDTOVAR TABLE.TO.NOTICED (0 SEND))
(APPENDTOVAR MSFNDATA (SEND ASDF))
[MSSETUP (QUOTE ((SEND SENDS SENDING SENT]
(PUTPROPS MSVBTABLES READVICE [NIL (BEFORE NIL (COND ((EQ VERB (QUOTE SEND))
(RETURN (QUOTE (0])
(READVISE MSVBTABLES)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (17453 42882 (ComputeGetValue 17463 . 18234) (ComputePutValue 18236 . 19183) (
DumpClassFacts 19185 . 20430) (DumpInstanceFacts 20432 . 22218) (DumpPruneDescr 22220 . 23563) (
DumpPruneDescr1 23565 . 24753) (EntityModified 24755 . 25181) (FastClassInitialize 25183 . 25978) (
FillIVs 25980 . 26561) (FillInClass 26563 . 28426) (FillInClass1 28428 . 30526) (GetEntityRec 30528 .
30794) (GetIVDescr 30796 . 31163) (GetIVHere 31165 . 31609) (GetInitialValue 31611 . 32013) (
GetObjFromUID 32015 . 32216) (GetObjectName1 32218 . 32618) (GetValue 32620 . 33471) (GetValueOnly
33473 . 34472) (GetClassRec 34474 . 35061) (GetObjectName 35063 . 35999) (GetObjectRec 36001 . 37559)
(NameEntity 37561 . 39097) (NewEntity 39099 . 39878) (PutValue 39880 . 41187) (PutValueOnly 41189 .
41924) (UnNameEntity 41926 . 42880)) (43150 58102 (BlankInstance 43160 . 44481) (DefineMethod 44483 .
46289) (FillInst 46291 . 46618) (FireInit 46620 . 47299) (IVSource 47301 . 48056) (ModifyInstance
48058 . 49255) (NameObject 49257 . 49552) (NewClass 49554 . 50224) (NewObject 50226 . 51408) (
NewWithValues 51410 . 51744) (SubstInAV 51746 . 52399) (TemplateCopy 52401 . 54870) (UpdateClassIVs
54872 . 55878) (UpdateIVDescrs 55880 . 58100)))))
STOP