(FILECREATED "29-Feb-84 15:53:40" {INDIGO}<LOOPS>SOURCES>LOOPSSTRUC.;24 43618
changes to: (FNS GetClassRec PutValueOnly BlankInstance)
previous date: "10-Feb-84 23:28:08" {INDIGO}<LOOPS>SOURCES>LOOPSSTRUC.;23)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(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 ?)))
(ADDVARS (GLOBALVARS AllObjectNames BrokenVariables CurrentEnvironment CurrentNameTable
DefaultComment DefaultEnvironment DefaultKBName DefaultLayer
DefaultObject FirstEnvFlg GlobalEnvironment ImplicitReplaceFns LASTCLASS
LastDefaultValue LispClassTable LoadingKernelFlg NETNUMBER NotSetValue
OBJECT OpenEnvironments WritingLayerFlg OpenKBFiles ObjNameTable
UidTable))
(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 ?)))
)
(ADDTOVAR GLOBALVARS AllObjectNames BrokenVariables CurrentEnvironment CurrentNameTable
DefaultComment DefaultEnvironment DefaultKBName DefaultLayer
DefaultObject FirstEnvFlg GlobalEnvironment ImplicitReplaceFns
LASTCLASS LastDefaultValue LispClassTable LoadingKernelFlg
NETNUMBER NotSetValue OBJECT OpenEnvironments WritingLayerFlg
OpenKBFiles ObjNameTable UidTable)
(RPAQQ LOOPSINITVARS (BASEFNS (DefaultComment)
(LeafInstanceFlg)
(WritingSummaryFlg)
(TTYIN?=FN (QUOTE GetMethodArgs))
(DEditLinger NIL)
(OutInstances NIL)
(PPDefault T)
(PrintStatusWindow PROMPTWINDOW)
(FirstEnvFlg)
(WritingLayerFlg)
(LASTCLASS)
(BrokenVariables)
(ErrorOnNameConflict)
(DefaultKBName NIL)
(CurrentEnvironment)
(CurrentNameTable NIL)
(CurrentUIDTable)
(AllObjectNames NIL)
[ObjNameTable (OR (LISTP (GETTOPVAL (QUOTE ObjNameTable)))
(CONS (HARRAY 128]
[UidTable (OR (LISTP (GETTOPVAL (QUOTE UidTable)))
(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 LeafInstanceFlg NIL)
(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 CurrentEnvironment NIL)
(RPAQQ CurrentNameTable NIL)
(RPAQQ CurrentUIDTable NIL)
(RPAQQ AllObjectNames NIL)
(RPAQ ObjNameTable (OR (LISTP (GETTOPVAL (QUOTE ObjNameTable)))
(CONS (HARRAY 128))))
(RPAQ UidTable (OR (LISTP (GETTOPVAL (QUOTE UidTable)))
(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 (AllGlobalNames ComputeGetValue ComputePutValue CreateEntity DeleteObjectName
DeleteObjectUID FastClassInitialize FillIVs GetEntityFromUID
GetIVDescr GetIVHere GetInitialValue GetObjFromUID GetObjFromUid
GetValueOnly GetClassRec GetObjectName GetObjectRec NameEntity
NewEntity PutObjectName PutObjectUID PutValueOnly))
(DEFINEQ
(AllGlobalNames
[LAMBDA NIL (* dgb: "26-DEC-83 18:24")
(PROG ((GlobalNames (CONS)))
[MAPHASH ObjNameTable (FUNCTION (LAMBDA (value key)
(AND key (LITATOM key)
(TCONC GlobalNames key]
(RETURN (CAR GlobalNames])
(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])
(CreateEntity
[LAMBDA (obj uid) (* dgb: "28-DEC-83 09:42")
(* Creates an entity for the object, putting in uid in
entity and obj. Only caller for DB-PackUI)
(OR (Object? obj)
(HELPCHECK obj "not object for CreateEntity"))
(SETQ uid (OR uid (DB-PackUI)))
(PROG ((entity (create Entity
localRecord ← obj
UID ← uid
storedIn ← DefaultKBName)))
(replace OBJUID of obj with uid)
(PutObjectUID uid entity)
(RETURN uid])
(DeleteObjectName
[LAMBDA (obj name) (* dgb: "28-DEC-83 05:58")
(* In CurrentNameTable, Delete name as name of object,
or all names for object if name is NIL)
(PROG (allNames nameTable)
[COND
((AND CurrentNameTable (SETQ allNames (GETHASH obj CurrentNameTable)))
(* names found in CurrentNameTable)
(SETQ nameTable CurrentNameTable))
(T (SETQ nameTable ObjNameTable)
(SETQ allNames (GETHASH obj ObjNameTable]
(OR allNames (RETURN NIL))
(COND
((NULL name)
(PUTHASH obj NIL nameTable)
(for n in (OR (LISTP allNames)
(LIST allNames))
do (PUTHASH n NIL nameTable)
(UNMARKASCHANGED n (QUOTE INSTANCES))) (* Return nonNIL so marking of change will take place)
(RETURN allNames))
((EQ name allNames)
(PUTHASH obj NIL nameTable)
(PUTHASH name NIL nameTable)
(UNMARKASCHANGED name (QUOTE INSTANCES))
(RETURN name))
((OR (LITATOM allNames)
(NOT (FMEMB name allNames)))
(ERROR name "Not a name for object"))
(T (PUTHASH obj (REMOVE name allNames)
nameTable)
(UNMARKASCHANGED name (QUOTE INSTANCES))
(RETURN name])
(DeleteObjectUID
[LAMBDA (obj) (* dgb: "10-Feb-84 23:22")
(* Deletes object UID and removes entity from uid table)
(PROG (entity uiTable (uid (fetch OBJUID of obj)))
[COND
((NULL uid) (* No uid nothing to be done)
(RETURN NIL))
(T (SETQ uid (MKNAME uid]
[COND
((AND CurrentUIDTable (SETQ entity (GETHASH uid CurrentUIDTable)))
(* Entry in CurrentUIDTable)
(SETQ uiTable CurrentUIDTable))
(T (SETQ uiTable UidTable)
(SETQ entity (GETHASH uid uiTable]
(OR entity (RETURN NIL))
(replace OBJUID of obj with NIL)
(replace localRecord of entity with NIL)
(replace storedIn of entity with NIL)
(* * Dont delete Entity if there is a current environment. This way deleted entries will be removed from
databases)
(OR CurrentEnvironment (PUTHASH uid NIL uiTable))
(RETURN obj])
(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])
(GetEntityFromUID
[LAMBDA (uid) (* dgb: "26-DEC-83 12:56")
(* Given uid, get the entity record)
(OR (AND CurrentUIDTable (GETHASH (MKNAME uid)
CurrentUIDTable))
(GETHASH (MKNAME uid)
UidTable])
(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) (* dgb: "26-DEC-83 18:35")
(PROG (objectRec (entity (GetEntityFromUID uid)))
[COND
((NULL entity)
(RETURN NIL))
((Object? entity)
(RETURN entity))
((NUMBERP (SETQ objectRec (fetch localRecord of entity)))
(* This means the facts are not yet loaded)
(SETQ objectRec (ReadFacts entity objectRec]
(RETURN objectRec])
(GetObjFromUid
[LAMBDA (uid) (* dgb: " 4-OCT-83 10:21")
(* given uid, find object -- temp now to cahnge when
there is a separate uid table.)
(GetObjectRec uid])
(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) (* dgb: "29-Feb-84 15:35")
(* 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)))
(COND
((AND classRec (NOT (type? class classRec)))
(LoopsHelp className " is a defined object, but is not a class.")))
(RETURN classRec])
(GetObjectName
[LAMBDA (object) (* dgb: "28-DEC-83 10:03")
(* Returns the name of an object if it has one other
than its UID)
(COND
((type? class object)
(ClassName object))
(T (PROG [(names (OR (AND CurrentNameTable (GETHASH object CurrentNameTable))
(GETHASH object ObjNameTable]
(RETURN (COND
((LISTP names) (* If it has more than one, then return first)
(CAR names))
(T names])
(GetObjectRec
[LAMBDA (name) (* dgb: "26-DEC-83 18:22")
(* * Given a name (UID or name), returns the object which is named by that atom. else returns NIL.)
(COND
((Object? name)
name)
((STRINGP name) (* This is a UID)
(GetObjFromUID name))
(T (OR (AND CurrentNameTable (GETHASH name CurrentNameTable))
(GETHASH name ObjNameTable)
(GetObjFromUID name])
(NameEntity
[LAMBDA (self name) (* dgb: "26-DEC-83 22:23")
(* * Associate a name with entity in current environment An object can have more than one name.
RETURN NIL if already has name)
(PROG (oldObj entity)
(COND
((NULL name)
(ERROR "Can't name object with NIL" self))
((NOT (LITATOM name))
(ERROR name "Should be an atom to be a name"))
((EQ self (SETQ oldObj (GetObjectRec name))) (* already has name)
(RETURN NIL))
((AND oldObj (NEQ self oldObj))
(AND ErrorOnNameConflict (HELPCHECK name
"is already used as a name for an object
in this environment. To continue type OK"))
(← oldObj UnSetName name)))
(PutObjectName name self)
(RETURN self])
(NewEntity
[LAMBDA (facts names) (* dgb: "26-DEC-83 15:00")
(* * Creates a new entity and names it if name given)
[COND
((NULL names) (* No UID given so just create the entity)
(CreateEntity facts))
((LITATOM names) (* Only a single name given)
(CreateEntity facts)
(PutObjectName names facts))
(T (PROG ((allNames (REVERSE names))) (* Now uid is first on allNames)
(CreateEntity facts (pop allNames))
(for name in allNames do (PutObjectName name facts]
facts])
(PutObjectName
[LAMBDA (name obj) (* dgb: "28-DEC-83 08:19")
(* Puts a new name for object in nameTable)
(PROG (newNames oldNames (nameTable (OR CurrentNameTable ObjNameTable)))
(* First make sure object has a UID if it is to be
named)
(UID obj)
(SETQ oldNames (GETHASH obj nameTable))
[SETQ newNames (COND
((NULL oldNames)
name)
((LITATOM oldNames)
(COND
((EQ name oldNames) (* already has name)
(RETURN NIL)))
(LIST name oldNames))
((FMEMB name oldNames) (* already has name)
(RETURN NIL))
(T (CONS name oldNames]
(PUTHASH name obj nameTable)
(PUTHASH obj newNames nameTable])
(PutObjectUID
[LAMBDA (uid entity) (* dgb: "26-DEC-83 11:48")
(* Puts a new uid for object in current uidTable)
(PUTHASH (MKNAME uid)
entity
(OR CurrentUIDTable UidTable])
(PutValueOnly
[LAMBDA (self varName newValue propName) (* dgb: "29-Feb-84 15:35")
(* * 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)
(LoopsHelp self "has no instance variables."))
PutValueOnly self varName newValue propName])
)
(* * Functions which build and change structure)
(RPAQQ STRUCFNS (BlankInstance FillInst FireInit IVSource ModifyInstance NameObject NewClass
NewObject UpdateClassIVs UpdateIVDescrs))
(DEFINEQ
(BlankInstance
[LAMBDA (class obj unmodifiedFlg) (* dgb: "29-Feb-84 15:36")
(* 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 (OR (GetClassRec class)
(LoopsHelp class
"Specified but has no class to create object")))
(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])
(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 dropDontSavesFlg) (* edited: "13-NOV-83 17:14")
(* 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 [COND
[(NULL dropDontSavesFlg)
(for inm in (fetch iNames of self) as i from 0
collect (CONS inm (GetVarNth self i]
(T (for name exceptions descr in (fetch iNames of self) as i from 0
when [NEQ (QUOTE Any)
(SETQ exceptions (GetValueOnly self name (QUOTE DontSave]
collect (SETQ descr (GetVarNth self 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]
(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: "28-DEC-83 08:55")
[COND
((NLISTP names)
NIL)
(T (for name in names when (NOT (STRINGP name)) do (PutObjectName name object]
object])
(NewClass
[LAMBDA (className metaClass) (* dgb: "26-DEC-83 14:44")
(* Creates a new class of the given name, and returns
the class record as the value.
Does not check for old defintion existing.)
(PROG (cls)
(COND
((NULL className)
(ERROR "A Class must be given a name at creation.
" NIL T))
(T (NewEntity [SETQ cls (create class
className ← className
metaClass ←(COND
((type? class metaClass)
metaClass)
(T (GetClassRec (OR metaClass (QUOTE Class]
className)
(ChangedClass className)
(RETURN cls])
(NewObject
[LAMBDA (class UID) (* dgb: "26-DEC-83 15:18")
(* Create a new empty object for ModifyInstance for
DEFINST or DEFINSTANCES. Set up inames and idescrs from
class.)
(COND
(UID (PROG ((obj (GetObjFromUID UID)))
[COND
(obj (RETURN (BlankInstance class obj]
(SETQ obj (BlankInstance class))
(CreateEntity obj UID)
(RETURN obj])
(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 )
)
(PUTPROPS LOOPSSTRUC COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (16601 31837 (AllGlobalNames 16611 . 16917) (ComputeGetValue 16919 . 17690) (
ComputePutValue 17692 . 18639) (CreateEntity 18641 . 19267) (DeleteObjectName 19269 . 20659) (
DeleteObjectUID 20661 . 21848) (FastClassInitialize 21850 . 22645) (FillIVs 22647 . 23228) (
GetEntityFromUID 23230 . 23561) (GetIVDescr 23563 . 23930) (GetIVHere 23932 . 24376) (GetInitialValue
24378 . 24780) (GetObjFromUID 24782 . 25316) (GetObjFromUid 25318 . 25623) (GetValueOnly 25625 . 26624
) (GetClassRec 26626 . 27206) (GetObjectName 27208 . 27797) (GetObjectRec 27799 . 28308) (NameEntity
28310 . 29143) (NewEntity 29145 . 29859) (PutObjectName 29861 . 30791) (PutObjectUID 30793 . 31093) (
PutValueOnly 31095 . 31835)) (32044 42377 (BlankInstance 32054 . 33468) (FillInst 33470 . 33797) (
FireInit 33799 . 34478) (IVSource 34480 . 36376) (ModifyInstance 36378 . 37575) (NameObject 37577 .
37840) (NewClass 37842 . 38591) (NewObject 38593 . 39145) (UpdateClassIVs 39147 . 40153) (
UpdateIVDescrs 40155 . 42375)))))
STOP