(FILECREATED " 7-JUN-83 17:57:58" {INDIGO}<LOOPS>SOURCES>LOOPSDATABASE.;5 73006
changes to: (FNS Environment.CopyObjects)
previous date: "27-MAY-83 16:35:08" {INDIGO}<KBVLSI>LOOPS>SOURCES>LOOPSDATABASE.;13)
(PRETTYCOMPRINT LOOPSDATABASECOMS)
(RPAQQ LOOPSDATABASECOMS ((* Classes which manipulate the database)
(CLASSES * DATABASECLASSES)
(* * Functions for the database classes)
(FNS * DATABASEFNS)
(* Set the value of the variable GlobalEnvironment)
(P (CreateGlobalEnvironment))
(* Copyright (c)
1982 by Xerox Corporation)))
(* Classes which manipulate the database)
(RPAQQ DATABASECLASSES (Environment GlobalInstanceMeta KB KBMeta KBState Layer))
(DEFCLASSES Environment GlobalInstanceMeta KB KBMeta KBState Layer)
[DEFCLASS Environment
(MetaClass GlobalInstanceMeta Edited: (* dgb: "26-NOV-82 17:09")
doc
(* * Provides a name space for working in alternative worlds)
)
(Supers GlobalNamedObject)
(ClassVariables)
(InstanceVariables (status NotOpen doc (* One of NotOpen, Open. Open when indexes of KBs have
been read in, NotOpen after ClearobjectMemory)
)
(nameTable #((CONS (HARRAY 128))
FirstFetch NIL) DontSave (Value)
doc (* nameTable for looking up names)
)
(uidTable #((CONS (HARRAY 256))
FirstFetch NIL) DontSave (Value)
doc (* table for going from uids to entities.)
)
(outputKB NIL DontSave (Value)
doc (* a KB to which changes will be filed, and which
specifies contents)
)
(assocKB NIL doc (* Name of the KB associated with new objects created)
))
(Methods (AssocKB Environment.AssocKB args (akb)
doc (* Make akb be the assocKB of this KB)
)
(Cancel Environment.Cancel args NIL doc
(* Erase an environment without cleaning up so that environment is empty, as if it were not open, but it is still
connected to the same KB. Make it not current.)
)
(ChangedKBs Environment.ChangedKBs args NIL doc
(* Finds the names of all KBs that have any modified
entities associated with them))
(Cleanup Environment.Cleanup args (KBNames noBootLayerFlg)
doc
(* Write FileLayers for KBs named in KBNames. If KBNames=NIL then write a layer for each changed KB.
If KBNames=T then write one layer for all changes. If KBName is a single atom, then the update is written for that
single assocKB. Finish by writing new boot layer for outputKB unless noBootLayer is T)
)
(ClearObjectMemory Environment.ClearObjectMemory args NIL doc
(* Write out boot layer if needed and clear nameTable.)
)
(Close Environment.Close args (assocKBs)
doc (* Cleanup an environment so that all files are closed,
and environment is empty, as if it were just created)
)
(ConnectOutput Environment.ConnectOutput args (KB)
doc (* Make KB be the file onto which changes in this
Environment will be written)
)
(CopyObjects Environment.CopyObjects args (objList)
doc (* copies objects on objList using the object structure
of the object in Environment self with same UID, if
found)
)
(Disconnect Environment.Disconnect args (KB)
doc (* Make KB be the file onto which changes in this
Environment will be written)
)
(IsCurrent Environment.IsCurrent args NIL doc (* Test if current))
(MakeCurrent Environment.MakeCurrent args NIL doc
(* Set values of CurrentNameTable and CurrentEnvironment
from self and make DefaultKBName be my assocKB)
)
(MakeNotCurrent Environment.MakeNotCurrent args (bitchIfNotCurrent)
doc (* Makes no Environment Current if this is current,
elses causes Error if not Current and
bitchIfNotCurrent=T)
)
(MapObjectNames Environment.MapObjectNames args (mapFn assocKBs noUIDs)
doc
(* APPLY mapFn to the name of each object stored in the environment. If assocKBs given, select only those which
are in the list. If noUIDs=T then apply only to names which are not UIDs. If mapFn=NIL then just list all names
and UIDs; if mapFn=T then just the names)
)
(Open Environment.Open args NIL doc (* Read in the index of all the layers referred to by
contents of outputKB)))]
[DEFCLASS GlobalInstanceMeta
(MetaClass MetaClass Edited: (* mjs: "30-JUN-82 18:18")
doc
(* * allows creation of instances which appear only in the GlobalNameTable. used by KB, KBState, Layer,
Environment)
)
(Supers Class)
(ClassVariables)
(InstanceVariables)
(Methods (New GlobalInstanceMeta.New args (kbName envName newVersionFlg)
doc
(* * Create a new KnowledgeBase file, and an environment if name is given, and make environment current)
))]
[DEFCLASS KB
(MetaClass KBMeta Edited: (* dgb: " 8-DEC-82 16:57")
doc (* Represents a KB file in core)
)
(Supers GlobalNamedObject KBState)
(ClassVariables)
(InstanceVariables (connectedEnvs NIL DontSave (Value)
doc (* List of Envs which have read in contents of this KB)
)
(contents NIL doc (* KBs start out e←with an empty list of contents)
)
(currentWriter NIL DontSave (Value)
doc (* Environment which is currently writing on this KB)
)
(fileName #((FINDFILE (KBFileName (%@ name)))
FirstFetch NIL) DontSave (Value)
doc (* Full name of file where this KB is stored.
Computed the first time it is needed.
Never stored.)
)
(owners NIL doc (* List of owners of this KB))
(status Disconnected DontSave (Value)
doc (* One of Disconnected Connected or BootNeeded)
))
(Methods (AddToContents KB.AddToContents args (newAddition)
doc
(* * Adds a new item to contents of KB)
)
(Close KB.Close args NIL doc (* Close the file associated with a KB))
(ConnectForOutput KB.ConnectForOutput args (nameTable)
doc (* Read in object file indices from all, possibly
implicit, layers in order. This is being opened for
output.)
)
(CopyFileLayer KB.CopyFileLayer args (layer)
doc (* Copies the FileLayer referred to by layer onto self,
and adds a new Layer describing copied fileLayer onto
contents of self)
)
(CopyFileLayers KB.CopyFileLayers args (layerDescription)
doc (* Copy all the layers in layerDescription which should
be a KBState into self)
)
(Disconnect KB.Disconnect args NIL doc (* Disconnect this KB and close its file if open)
)
(FileName KB.FileName args NIL doc (*))
(FreezeKB KB.FreezeKB args (name)
doc
(* Find a KBState with %@name=name and contents=CURRENT. Replace it by a new KBState with contents = currentState
of myKB. Return new KBState or NIL if failure)
)
(PrintContents KB.PrintContents args (file)
doc (* Fn to Printout a formatted description of the
contents of a knowledge base.)
)
(SetContents KB.SetContents args (lst)
doc (* Make KB have new contents.
Check types of elements)
)
(ThawKB KB.ThawKB args (name)
doc
(* Find a KBState with (GetValue self (QUOTE name=name)) and contents not Equal CURRENT. Replace it by a new
KBState with contents = CURRENT. Return new KBState or NIL if failure)
)
(WriteBoot KB.WriteBoot args NIL doc (* Write out boot file containing KB and all layers and
KBStates it contains implicitly or explicitly)
)
(WriteEntityFile KB.WriteEntityFile args (changedEntities namedEntities assockbName)
doc
(* * Writes the entities (objects) out to a layer in a given kb.)
)
(WriteFileLayer KB.WriteFileLayer args (kbName nameTable)
doc
(* * Writes the facts on the file, appending to file. Format of layer is: -
indexFilePosition (up to 7 characters) -
entityCount (up to 7 characters) -
nameCount (up to 7 characters) -
entity records -
indexRecords (UID followed by file position,) -
nameRecords (name followed by UID) -
initialFilePosition)
))]
[DEFCLASS KBMeta
(MetaClass MetaClass Edited: (* dgb: "26-NOV-82 11:56"))
(Supers GlobalInstanceMeta)
(ClassVariables)
(InstanceVariables)
(Methods (Close KBMeta.Close args NIL doc (* Close all the currently open KBs, and Cancel any
attached writers or readers. Set OpenKBFiles to NIL)
)
(New KBMeta.New args (kbName envName newVersionFlg)
doc
(* * Create a new KnowledgeBase file, and an environment if name is given, and make environment current)
)
(Old KBMeta.Old args (kbName envName)
doc
(* Get kb for this kbName. (Causes boot layer to be read unless kb is already in the global table.) If envName is
given, creates an Environment of that name and connects the environment to the kb.)
)
(ReadBoot KBReadBoot args NIL doc (* Read in index of existing KB given kbName)
)
(ReadOldBootLayer KBMeta.ReadOldBootLayer args (kbName numBack)
doc (* Read in index of already existing KB)
)
(Summarize KBMeta.Summarize args (fromKBName toKBName assocKBNames namedObjectsOnly)
doc
(* * Incorporate all objects of fromKB with assocKB in assocKBNames (or all if assocKBNames=NIL) into new KB
toKBName. If namedObjectsOnly=T then only copies over all those entities referred to by a name or by a named
object directly or indirectly. This latter feature provides a mechanism for garbage collection.)
))]
[DEFCLASS KBState
(MetaClass GlobalInstanceMeta Edited: (* dgb: "27-MAY-83 07:31"))
(Supers DatedObject NamedObject)
(ClassVariables)
(InstanceVariables (name NIL doc (* name of file associated with this KBState.
NIL as value overrides active Value in NamedObject)
)
(contents CURRENT doc (* Either CURRENT, meaning the current state of the KB
with name or a list of layers and KBStates specifying
layerset)))
(Methods (AddEntities KBState.AddEntities args (entityList)
doc
(* Add all items on contents and self to entityList. Called by functions which write out the boot layer to make
sure that all layers are added to the list of items to be dumped)
)
(AddToContents KBState.AddToContents args (newAddition)
doc
(* * Adds a new item to contents of KB)
)
(Close KBState.Close args (env)
doc (* close files if necessary)
)
(Connect KBState.Connect args (nameTable)
doc (* Read in object file indices from all, possibly
implicit, layers in order. These are being opened for
input only.)
)
(CurrentState KBState.CurrentState args NIL doc
(* Create a KB state which reflects the current state of
this KB))
(DescribeLayers KBState.DescribeLayers args (dateOrDays assocKB)
doc (* Return a KBState whose contents are just those layers
which occur after dateOrDays and have kb assocKB, or NIL
if none)
)
(MyKB KBState.MyKB args NIL doc (* Return the KB object corresponding to this KBState)
)
(PrintContents KBState.PrintContents args (file)
doc (* Fn to Printout a formatted description of the
contents of a knowledge base.)
)
(ReadBoot KBState.ReadBoot args NIL doc (* Read the boot file for this KB))
(SetContents KBState.SetContents args (lst)
doc (* Make KB have new contents.
Check types of elements)
))]
[DEFCLASS Layer
(MetaClass GlobalInstanceMeta Edited: (* dgb: " 6-DEC-82 12:15"))
(Supers DatedObject)
(ClassVariables)
(InstanceVariables (kbName NIL doc (* name of kb where this layer was stored e.g. BRIDGE)
)
(position NIL doc (* index on file where FileLayer is found)
)
(assocKB NIL doc (* name of KB with which this Layer is associated
conceptually)))
(Methods (AddEntities Layer.AddEntities args (entityList)
doc (* Add self to entity list for dumping on boot layer)
)
(Close Layer.Close args NIL doc (* Do nothing. Dummy so one can recurse through contents
of a KB))
(Connect Layer.Connect args (nameTable)
doc (* Open layer file and read in index)
)
(MapObjectNames Layer.MapObjectNames args (mapFn noUIDs)
doc (* apply mapFn to objectnames in layer, or make a list
of them if mapFn=NIL)
)
(PrintContents Layer.PrintContents args (file)
doc (* Print contents of layer)
))]
(* * Functions for the database classes)
(RPAQQ DATABASEFNS (CloseKBFile CreateGlobalEnvironment CutBackToBootLayer DeleteEntity EntityKB
Environment.AssocKB Environment.ChangedKBs Environment.Cleanup
Environment.ClearObjectMemory Environment.Close
Environment.ConnectOutput Environment.CopyObjects
Environment.Disconnect Environment.Cancel Environment.IsCurrent
Environment.MakeCurrent Environment.MakeNotCurrent
Environment.MapObjectNames Environment.Open Environment.WriteBoot
FindChangedKB GlobalInstanceMeta.New KB.AddToContents KB.Close
KB.ConnectForOutput KB.CopyFileLayer KB.CopyFileLayers KB.Disconnect
KB.FileName KB.FreezeKB KB.PrintContents KB.SetContents KB.ThawKB
KB.WriteBoot KB.WriteEntityFile KB.WriteFileLayer KBFileName
KBFullName KBMeta.Close KBMeta.New KBMeta.Old KBMeta.ReadOldBootLayer
KBMeta.Summarize KBReadBoot KBState.AddEntities KBState.AddToContents
KBState.Close KBState.Connect KBState.CurrentState
KBState.DescribeLayers KBState.MyKB KBState.PrintContents
KBState.ReadBoot KBState.SetContents KBNameForm Layer.AddEntities
Layer.Close Layer.Connect Layer.MapObjectNames Layer.PrintContents
NewNameTable OpenKBFile PositionEntityFile ReadFacts ReadLayerIndex
ReadLeafObj ReadOverFacts SelectChangedEntity WriteEntityFile
WriteFacts WriteIndexEntry WriteNameEntry))
(DEFINEQ
(CloseKBFile
[LAMBDA (name errorIfNotOpen) (* dgb: "29-NOV-82 16:01")
(* Close a KB file)
(PROG ((fn (FASSOC name OpenKBFiles)))
[COND
[(NULL fn)
(COND
(errorIfNotOpen (ERROR name "not an open KB. Tried to close"]
(T (CLOSEF (CDR fn))
(SETQ OpenKBFiles (DREMOVE fn OpenKBFiles]
(RETURN (CDR fn])
(CreateGlobalEnvironment
[LAMBDA NIL (* dgb: "19-NOV-82 13:57")
(* This is invoked on loading the file DATABASE, by a P
statement in the COMS. Creates the Global
CurrentEnvironment and GlobalEnvironment)
(SETQ CurrentEnvironment NIL)
(SETQ GlobalEnvironment (← (%$ Environment)
New))
(PutValueOnly GlobalEnvironment (QUOTE nameTable)
GlobalNameTable)
(←%@
GlobalEnvironment name (QUOTE GlobalEnvironment))
(MakeActiveValue GlobalEnvironment (QUOTE outputKB)
NIL
(QUOTE NoUpdatePermitted))
(MakeActiveValue GlobalEnvironment (QUOTE assocKB)
NIL
(QUOTE NoUpdatePermitted))
(MakeActiveValue GlobalEnvironment (QUOTE status)
NIL
(QUOTE NoUpdatePermitted)
(QUOTE Open))
GlobalEnvironment])
(CutBackToBootLayer
[LAMBDA (kbName) (* dgb: "27-NOV-82 12:45")
(PROG (infile outfile testPos (endPos 0)
(fileName (KBFileName kbName)))
(SETQ infile (OPENFILE fileName (QUOTE INPUT)))
LP (COND
((SETQ testPos (FILEPOS "BootLayer" infile NIL NIL NIL T))
(SETQ endPos testPos)
(GO LP)))
(COND
((EQ 0 endPos)
(HELPCHECK "No boot layer in " infile)))
(SETQ outfile (OPENFILE fileName (QUOTE OUTPUT)))
(COPYBYTES infile outfile 0 endPos)
(CLOSEF infile)
(CLOSEF outfile)
(RETURN outfile])
(DeleteEntity
[LAMBDA (name nameTable) (* dgb: " 2-DEC-82 15:39")
(* Delete entry for name and all other keys pointing to
same entity)
(PROG ((entity (GETHASH name nameTable)))
(MAPHASH nameTable (FUNCTION (LAMBDA (val key)
(COND
((EQ val entity)
(PUTHASH key NIL nameTable])
(EntityKB
[LAMBDA (entity) (* dgb: " 2-DEC-82 12:43")
(* Get the KB associated with an entity record)
(PROG ((stored (fetch storedIn of entity)))
LP (RETURN (COND
((LITATOM stored)
stored)
((LISTP stored) (* for incremental facts)
(SETQ stored (CAR stored))
(GO LP))
(T (* stored is a layer. Get its KB)
(%@ stored kbName])
(Environment.AssocKB
[LAMBDA (self akb) (* dgb: "29-NOV-82 16:09")
(* Make akb be the assocKB of this KB)
(SELECTQ (TYPENAME akb)
[LITATOM (COND
((NOT (KBFullName akb))
(ERROR akb "is not a defined knowledge base"))
(T (←%@
assocKB akb]
[instance (COND
((← akb InstOf!(QUOTE KBState))
(←%@
assocKB
(%@ akb name)))
(T (ERROR akb "not a KB or KBState or name"]
(ERROR akb "not a KB or KBState or name"))
[COND
((← self IsCurrent)
(SETQ DefaultKBName (%@ assocKB]
(%@ assocKB])
(Environment.ChangedKBs
[LAMBDA (self) (* dgb: "27-NOV-82 01:41")
(* Finds the names of all KBs that have any modified
entities associated with them)
(PROG ((changedKBs (CONS)))
(MAPHASH (%@ nameTable)
(FUNCTION FindChangedKB))
(RETURN (CAR changedKBs])
(Environment.Cleanup
[LAMBDA (self KBNames noBootLayerFlg) (* dgb: "27-NOV-82 00:04")
(* Write FileLayers for KBs named in KBNames. If KBNames=NIL then write a layer for each changed KB.
If KBNames=T then write one layer for all changes. If KBName is a single atom, then the update is written for that
single assocKB. Finish by writing new boot layer for outputKB unless noBootLayer is T)
(COND
((NULL (%@ outputKB))
(ERROR self "has no outputKB")))
[COND
((EQ KBNames T)
(← (%@ outputKB)
WriteFileLayer T (%@ nameTable)))
(T (for kb in (OR (LISTP KBNames)
(AND KBNames (LIST KBNames))
(← self ChangedKBs))
do (← (%@ outputKB)
WriteFileLayer kb (%@ nameTable]
(COND
(noBootLayerFlg (PrintStatus "No bootLayer written on " self))
(T (← (%@ outputKB)
WriteBoot])
(Environment.ClearObjectMemory
[LAMBDA (self) (* dgb: "27-MAY-83 11:36")
(* Write out boot layer if needed and clear nameTable.)
(COND
((EQ (%@ status)
(QUOTE Open))
(←%@
status
(QUOTE NotOpen)) (* Only need to do anything if Environment is Open)
[MAPHASH (%@ nameTable)
(FUNCTION (LAMBDA (entityRec uidOrName) (* For each object in the nameTable, send it the mesage
Destroy)
(PROG ((localInst (fetch localRecord of entityRec)))
(COND
((AND localInst (Object? localInst)
(NOT (GETHASH (fetch UID of entityRec)
GlobalNameTable)))
(* Can be NIL if previously deleted, or a number if it has not yet been loaded, or in global name table, so don't
destroy it.)
(← localInst Destroy!]
(CLRHASH (%@ nameTable))
self])
(Environment.Close
[LAMBDA (self assocKBs) (* dgb: " 3-MAR-83 16:17")
(* Cleanup an environment so that all files are closed,
and environment is empty, as if it were just created)
(← self Cleanup assocKBs) (* first dump out any layers that are needed)
(← self ClearObjectMemory) (* now remove objects, and index to them)
(← self MakeNotCurrent)
(← self Disconnect) (* break connection between environment and outputKB)
self])
(Environment.ConnectOutput
[LAMBDA (self KB) (* dgb: "27-NOV-82 00:58")
(* Make KB be the file onto which changes in this
Environment will be written)
(PROG (errorFlg currentWriter outKB)
TryAgain
(SETQ errorFlg NIL)
[COND
((NULL KB) (* just fall thru to make there be no outputKB)
(GO OUT))
((LITATOM KB) (* Allow user to use name of KB as well as object)
(SETQ KB (GetObjectRec KB]
(COND
((NOT (FMEMB USERNAME (%@ KB owners)))
(SETQ errorFlg T)
(HELPCHECK KB "belongs to " (%@ KB owners)
"
To be added as an owner, type OK")
(PushValue KB (QUOTE owners)
USERNAME)))
[COND
((%@ KB connectedEnvs)
(SETQ errorFlg T)
(HELPCHECK KB " currently connected to " (%@ KB connectedEnvs)))
((SETQ currentWriter (%@ KB currentWriter))
(COND
((EQ (QUOTE Open)
(%@ currentWriter status))
(SETQ errorFlg T)
(HELPCHECK KB "currently outputKB for " currentWriter))
(T (WRITE "Disconnecting " KB " from " currentWriter ")")
(← currentWriter ConnectOutput]
(COND
(errorFlg (* recheck everything if User continued from error.)
(GO TryAgain)))
(←%@
KB currentWriter self)
(←%@
KB status (QUOTE Connected))
(← self AssocKB (%@ KB name))
OUT (COND
((SETQ outKB (%@ outputKB))
(← outKB Disconnect)))
(←%@
outputKB KB)
(RETURN KB])
(Environment.CopyObjects
[LAMBDA (self objList) (* dgb: " 7-JUN-83 17:15")
(* copies objects on objList into self.
If already there just ignores it)
(for obj uid newObj in objList bind (nameTable ←(%@ nameTable))
do (SETQ uid (fetch OBJUID of self))
(COND
((AND (SETQ uid (fetch OBJUID of self))
(NEQ obj (SETQ newObj (GETHASH uid nameTable)))
(COND
((type? instance obj)
(NewEntity (FillIVs NIL (Class obj)
(COPY (IVSource obj)))
(GetObjectNames obj)
(%@ assocKB)
(%@ nameTable)))
(T (ERROR self "Can't be copied into environment"])
(Environment.Disconnect
[LAMBDA (self) (* dgb: " 5-JAN-83 16:39")
(* Make this Environment have no connected outputKB)
(PROG (outKB)
(COND
((SETQ outKB (%@ outputKB))
(←%@
outputKB NIL)
(← outKB Disconnect self)
(RETURN outKB])
(Environment.Cancel
[LAMBDA (self) (* dgb: "26-NOV-82 17:05")
(* Erase an environment without cleaning up. Leaves environment not open, empty, not current, but connected to the
same KB. To restart send the environment the Open message.)
(PROG ((kb (%@ outputKB)))
(COND
(kb (← self MakeNotCurrent)
(← self ClearObjectMemory) (* now remove objects, and index to them)
(← self Disconnect) (* Disconnect and reconnect to make file status correct)
(← self ConnectOutput kb)
self])
(Environment.IsCurrent
[LAMBDA (self) (* dgb: "26-NOV-82 17:10")
(* Test if current)
(COND
(CurrentNameTable (EQ CurrentNameTable (%@ nameTable)))
(T (EQ self GlobalEnvironment])
(Environment.MakeCurrent
[LAMBDA (self) (* dgb: "26-NOV-82 16:12")
(* Set values of CurrentNameTable and CurrentEnvironment
from self and make DefaultKBName be my assocKB)
(COND
[(EQ self GlobalEnvironment)
(SETQ DefaultKBName (SETQ CurrentNameTable (SETQ CurrentEnvironment NIL]
(T (SETQ CurrentNameTable (%@ nameTable))
(SETQ CurrentEnvironment self)
(SETQ DefaultKBName (%@ assocKB])
(Environment.MakeNotCurrent
[LAMBDA (self bitchIfNotCurrent) (* sm: "17-NOV-82 16:31")
(* Makes no Environment Current if this is current,
elses causes Error if not Current and
bitchIfNotCurrent=T)
(COND
((EQ CurrentNameTable (%@ nameTable))
(SETQ CurrentEnvironment NIL)
(SETQ CurrentNameTable NIL)
(SETQ DefaultKBName NIL))
(bitchIfNotCurrent (HELPCHECK self "not current. Type OK to go on."])
(Environment.MapObjectNames
[LAMBDA (self mapFn assocKBs noUIDs) (* dgb: "28-NOV-82 23:01")
(* APPLY mapFn to the name of each object stored in the environment. If assocKBs given, select only those which
are in the list. If noUIDs=T then apply only to names which are not UIDs. If mapFn=NIL then just list all names
and UIDs; if mapFn=T then just the names)
(PROG ((nameList (CONS)))
(COND
((EQ mapFn T)
(SETQ noUIDs T)
(SETQ mapFn NIL)))
[MAPHASH (%@ nameTable)
(FUNCTION (LAMBDA (entity name)
(COND
((NULL (fetch localRecord of entity))
(* don't list deleted items)
NIL)
([NOT (OR (AND assocKBs (NOT (FMEMB (EntityKB entity)
assocKBs)))
(AND noUIDs (EQ name (fetch UID of entity]
(COND
(mapFn (APPLY* mapFn name))
(T (TCONC nameList name]
(RETURN (CAR nameList])
(Environment.Open
[LAMBDA (self) (* dgb: " 1-DEC-82 11:05")
(* Read in the index of all the layers referred to by
contents of outputKB)
(OR (%@ outputKB)
(ERROR self "has no outputKB. Can't Open"))
(← self MakeCurrent)
(←%@
status
(QUOTE Open))
(← (%@ outputKB)
ConnectForOutput)
self])
(Environment.WriteBoot
[LAMBDA (self) (* dgb: " 3-MAR-82 10:34")
(* Make outputKB write it's boot file)
(← (%@ outputKB)
WriteBoot])
(FindChangedKB
[LAMBDA (entity name) (* dgb: "30-NOV-82 10:15")
(* * Called from a loop in Environment.ChangedKBs. Uses freely changedKBs)
(PROG (place objRec)
(COND
((AND entity (EntityModified entity))
(TCONC changedKBs (EntityKB entity])
(GlobalInstanceMeta.New
[LAMBDA (class name) (* dgb: "26-NOV-82 19:04")
(* Creates an instance of a particular class. Called by Environmental objects to ensure that they appear only in
global name table. NewEntity is what creates the Entity record and UID in given nameTable)
(PROG ((self (NewEntity (BlankInstance class)
NIL NIL GlobalNameTable)))
(← class Initialize self) (* Install IV description)
(AND name (← self SetName name))
(RETURN self])
(KB.AddToContents
[LAMBDA (self newAddition) (* dgb: "29-NOV-82 16:28")
(* * Adds a new item to contents of KB)
(PROG (addOn w c)
(COND
((%@ connectedEnvs)
(ERROR (LIST self "currently connected to " (%@ connectedEnvs))
"No new aditions can be made.")))
(SELECTQ (TYPENAME newAddition)
((LITATOM ATOM)
(COND
((NULL (KBFullName newAddition))
(ERROR newAddition " is not a known Knowledge base")))
(SETQ addOn (←New
(%$ KBState)
SetName newAddition)))
(instance (SELECTQ (ClassName newAddition)
((Layer KBState)
(SETQ addOn (← newAddition CopyShallow)))
(KB (SETQ addOn (← newAddition CurrentState)))
(GO ERROR)))
(GO ERROR))
[←%@
contents
(COND
((ATOM (SETQ c (%@ contents)))
(LIST addOn))
(T (NCONC1 c addOn]
[COND
((AND (SETQ w (%@ currentWriter))
(EQ (%@ w status)
(QUOTE Open)))
(← addOn Connect (%@ w nameTable]
(←%@
status
(QUOTE BootNeeded))
(RETURN addOn)
ERROR
(ERROR newAddition "is not an atom, Layer, KB or KBState. Cannot be added to KB contents"])
(KB.Close
[LAMBDA (self env) (* dgb: " 5-JAN-83 16:46")
(* Close the file associated with a KB)
[COND
([NULL (←%@
connectedEnvs
(DREMOVE env (%@ connectedEnvs] (* If no other env is connected to this KB then close
the file)
(CloseKBFile (%@ name]
(for c in (%@ contents) do (← c Close env])
(KB.ConnectForOutput
[LAMBDA (self nameTable) (* dgb: " 1-DEC-82 11:06")
(* Read in object file indices from all, possibly
implicit, layers in order. This is being opened for
output.)
(OpenKBFile (%@ name)
(QUOTE BOTH))
(for item in (%@ contents) do (← item Connect])
(KB.CopyFileLayer
[LAMBDA (self layer) (* dgb: "29-NOV-82 16:40")
(* Copies the FileLayer referred to by layer onto self,
and adds a new Layer describing copied fileLayer onto
contents of self)
(COND
((OR (%@ connectedEnvs)
(%@ currentWriter))
(ERROR (LIST self "currently connected to" (OR (%@ connectedEnvs)
(%@ currentWriter)))
"Cannot be added to when connected to any environment")))
(PROG (toPos indexPosition entityCount nameCount posDif (fromFile (OpenKBFile (%@ layer kbName)
(QUOTE INPUT)))
(fromPos (%@ layer position))
(toFile (OpenKBFile (%@ name))
(QUOTE OUTPUT))
(newLayer (← (%$ Layer)
New)))
(INPUT fromFile)
(OUTPUT toFile)
(SETFILEPTR fromFile (%@ layer position))
(SETQ toPos (GETEOFPTR toFile))
(←%@
newLayer file toFile)
(←%@
newLayer kbName (%@ name))
(←%@
newLayer position toPos)
(←%@
newLayer assocKB (%@ name))
(SETQ posDif (IDIFFERENCE toPos fromPos)) (* Relative offset on toFile)
(PRINT (IPLUS posDif (SETQ indexPosition (READ fromFile)))
toFile) (* This is the new index position, moved by the offset)
(PRINT (SETQ entityCount (READ fromFile))
toFile)
(PRINT (SETQ nameCount (READ fromFile))
toFile)
(COPYBYTES fromFile toFile (GETFILEPTR fromFile)
indexPosition)
(RPTQ entityCount (PROGN (PRINT (READ fromFile)
toFile)
(PRINT (IPLUS (READ fromFile)
posDif)
toFile)))
(RPTQ nameCount (PROGN (PRINT (READ fromFile)
toFile)
(PRINT (READ fromFile)
toFile)))
(SPACES 8 toFile)
(PRINT toPos toFile)
(CloseKBFile (%@ layer kbName))
(CloseKBFile (%@ name))
(← self AddToContents newLayer)
(← newLayer Destroy) (* layer has been copied and is not now needed)
(RETURN self])
(KB.CopyFileLayers
[LAMBDA (self layerDescription) (* dgb: "15-MAR-82 22:21")
(* Copy all the layers in layerDescription which should
be a KBState into self)
(for layer in (%@ layerDescription contents) do (← self CopyFileLayer layer))
(← self WriteBoot])
(KB.Disconnect
[LAMBDA (self env) (* dgb: " 5-JAN-83 16:40")
(* Disconnect this KB and close its file if open)
(←%@
currentWriter NIL)
(←%@
status
(QUOTE Disconnected))
(← self Close env])
(KB.FileName
[LAMBDA (self) (* dgb: " 8-DEC-82 17:10")
(KBFullName (%@ name])
(KB.FreezeKB
[LAMBDA (self name) (* dgb: "17-MAR-82 11:01")
(* Find a KBState with %@name=name and contents=CURRENT. Replace it by a new KBState with contents = currentState
of myKB. Return new KBState or NIL if failure)
(for tail item on (%@ contents) do (COND
((AND (← (SETQ item (CAR tail))
InstOf
(QUOTE KBState))
(EQ name (%@ item name))
(EQ (QUOTE CURRENT)
(%@ item contents)))
(RPLACA tail (SETQ item (← (← item MyKB)
CurrentState)))
(RETURN item])
(KB.PrintContents
[LAMBDA (self file) (* dgb: "29-NOV-82 16:56")
(* Fn to Printout a formatted description of the
contents of a knowledge base.)
(RESETLST (RESETSAVE (DSPFONT))
(printout file "Knowledge Base " .FONT LAMBDAFONT (%@ name)
.FONT DEFAULTFONT " created " (%@ created)
T .TAB0 10 "Owners " (%@ owners)
T "Contents:" T)
(for item in (%@ contents) do (← item PrintContents))
(printout file .FONT DEFAULTFONT])
(KB.SetContents
[LAMBDA (self lst) (* dgb: "15-MAR-82 22:22")
(* Make KB have new contents.
Check types of elements)
[for item in lst do (COND
([NOT (OR (← item InstOf (QUOTE Layer))
(← item InstOf (QUOTE KBState]
(ERROR item "cannot be part of KB contents"]
(←%@
contents lst)
(←%@
status
(QUOTE BootNeeded))
self])
(KB.ThawKB
[LAMBDA (self name) (* dgb: "17-MAR-82 11:06")
(* Find a KBState with (GetValue self (QUOTE name=name)) and contents not Equal CURRENT. Replace it by a new
KBState with contents = CURRENT. Return new KBState or NIL if failure)
(for tail item on (%@ contents) do (COND
((AND (← (SETQ item (CAR tail))
InstOf
(QUOTE KBState))
(EQ name (%@ item name))
(NEQ (QUOTE CURRENT)
(%@ item contents)))
(RPLACA tail (SETQ item (←New
(%$ KBState)
SetName name)))
(RETURN item])
(KB.WriteBoot
[LAMBDA (self) (* dgb: "30-NOV-82 10:14")
(* Write out boot file containing KB and all layers and
KBStates it contains implicitly or explicitly)
(PROG (file (entityList (LIST NIL))
(nameList (LIST NIL)))
(OR (SETQ file (KBFullName (%@ name)
T))
(ERROR (%@ name)
"not an open KB for WriteBoot"))
(COND
((NEQ (%@ status)
(QUOTE BootNeeded)) (* No Boot Needed)
(RETURN NIL)))
(← self AddEntities entityList)
(TCONC nameList (CONS (%@ name)
(UID self)))
[←%@
status
(COND
((OR (%@ currentWriter)
(%@ connectedEnvs))
(QUOTE Connected))
(T (QUOTE DisConnected]
(RETURN (WriteEntityFile file entityList nameList T])
(KB.WriteEntityFile
[LAMBDA (self changedEntities namedEntities assockbName) (* dgb: " 6-DEC-82 13:17")
(* * Writes the entities out to a layer in a given kb.)
(PROG [layer (file (OR (KBFullName (%@ name)
T)
(ERROR (%@ name)
"not an open file for WriteChangedEntities"]
(SETQ layer (← (%$ Layer)
New))
(←%@
layer position (GETEOFPTR file)) (* Layer is always written at end of file)
(←%@
layer kbName (%@ name))
(←%@
layer assocKB assockbName)
(AddValue self (QUOTE contents)
layer)
(←%@
status
(QUOTE BootNeeded))
(RETURN (WriteEntityFile file changedEntities namedEntities])
(KB.WriteFileLayer
[LAMBDA (self kbName nameTable) (* dgb: "27-NOV-82 01:23")
(* * Writes the facts on the file, appending to file. Format of layer is: -
indexFilePosition (up to 7 characters) -
entityCount (up to 7 characters) -
nameCount (up to 7 characters) -
entity records -
indexRecords (UID followed by file position,) -
nameRecords (name followed by UID) -
initialFilePosition)
(COND
((EQ (%@ status)
(QUOTE Disconnected))
(ERROR "Trying to write onto a KB which is not connected to " self)))
(PROG (file (changedEntities (LIST NIL))
(namedEntities (LIST NIL)))
(DECLARE (SPECVARS changedEntities namedEntities kbName self))
(MAPHASH nameTable (FUNCTION SelectChangedEntity))
(* * SelectChangedEntity has set the variables changedEntities and namedEntities. Uses kbName freely.)
(COND
((NULL (CAR changedEntities)) (* If no changed entities, then nothing is to be written
on the file)
(RETURN NIL)))
[SETQ file (← self WriteEntityFile changedEntities namedEntities
(COND
((OR (EQ kbName T)
(NULL kbName))
(%@ name))
(T kbName]
(RETURN file])
(KBFileName
[LAMBDA (name) (* dgb: "13-MAY-82 09:35")
(* Create a name ending in .KB)
(PACK* name ".KB"])
(KBFullName
[LAMBDA (name openOnly) (* dgb: "29-NOV-82 15:41")
(* Finds the full name of a kb given its first name.
Returns only open files if openOnly=T.
NIL if not found)
(OR (CDR (FASSOC name OpenKBFiles))
(AND (NULL openOnly)
(FINDFILE (KBFileName name])
(KBMeta.Close
[LAMBDA (self) (* dgb: "30-NOV-82 16:38")
(* Close all the currently open KBs, and Cancel any
attached writers or readers. Set OpenKBFiles to NIL)
(for kbp env kb file kbname in OpenKBFiles when (OPENP (SETQ file (CADR kbp)))
collect [SETQ kb (GetObjectRec (SETQ kbname (CAR kbp]
(SETQ env (%@ kb currentWriter))
(COND
(env (← env Cancel)))
(COND
((OPENP file)
(CLOSEF file)))
kbname
finally (SETQ OpenKBFiles NIL])
(KBMeta.New
[LAMBDA (self kbName envName newVersionFlg) (* dgb: "30-NOV-82 17:07")
(* * Create a new KnowledgeBase file, and an environment if name is given, and make environment current)
(PROG (env fileName kb) (* Make sure kbName has no lower case letters or
extensions)
(SETQ kbName (KBNameForm kbName))
(COND
((AND (SETQ fileName (KBFullName kbName))
(NOT newVersionFlg))
(HELPCHECK fileName " already exists.
TYPE OK to make new version of KB")))
(SETQ kb (←Super
self New kbName))
(SETQ fileName (OPENFILE (KBFileName kbName)
(QUOTE OUTPUT)
(QUOTE NEW)))
(PRINTDATE fileName)
(PrintStatus "Creating new KB " fileName)
(CLOSEF fileName)
(←%@
kb owners (LIST USERNAME))
(COND
(envName (* If there is an old not open environmnt of this name,
use it)
(OR (AND (SETQ env (GetObjectRec envName))
(← env InstOf (QUOTE Environment))
(NEQ (%@ env status)
(QUOTE Open)))
(SETQ env (← (%$ Environment)
New envName)))
(← env ConnectOutput kb)))
(RETURN kb])
(KBMeta.Old
[LAMBDA (self kbName envName) (* dlsb: "10-SEP-82 15:29")
(* Get kb for this kbName. (Causes boot layer to be read unless kb is already in the global table.) If envName is
given, creates an Environment of that name and connects the environment to the kb.)
(PROG (kb env)
(SETQ kbName (KBNameForm kbName))
(SETQ kb (OR (GetObjectRec kbName)
(KBReadBoot kbName)))
(COND
(envName (SETQ env (←New
(%$ Environment)
SetName envName))
(← env ConnectOutput kb)))
(RETURN kb])
(KBMeta.ReadOldBootLayer
[LAMBDA (self kbName numBack) (* dgb: " 1-DEC-82 16:24")
(* Read in index of already existing KB)
(PROG [position layer (numLeft (OR (NUMBERP numBack)
(ERROR numBack
"is not a number. Use a number to tell how many Bootlayers to skip. ")))
(file (KBFullName (KBFileName kbName)
(QUOTE INPUT]
(COND
((NULL file)
(ERROR kbName "not found.")))
(INPUT file)
(SETFILEPTR file 0)
(PRINT (READ file)
T)
(SETFILEPTR file (GETEOFPTR file))
FindBootLayer (* Needs a check for running out of file)
(SETFILEPTR file (IDIFFERENCE (GETFILEPTR file)
10))
(COND
((NEQ (QUOTE BootLayer)
(SETQ position (READ file)))
(SETFILEPTR file position)
(GO FindBootLayer)))
(SETFILEPTR file (IDIFFERENCE (GETFILEPTR file)
20))
(SETFILEPTR file (READ file))
(COND
((IGREATERP (SETQ numLeft (SUB1 numLeft))
-1)
(GO FindBootLayer))) (* Position of boot layer on file)
(RESETVAR CurrentNameTable GlobalNameTable (ReadLayerIndex file kbName))
(RETURN (GetObjectRec kbName])
(KBMeta.Summarize
[LAMBDA (self fromKBName toKBName assocKBNames namedObjectsOnly)
(* dgb: "19-JAN-83 12:17")
(* * Incorporate all objects of fromKB with assocKB in assocKBNames (or all if assocKBNames=NIL) into new KB
toKBName. If namedObjectsOnly=T then only copies over all those entities referred to by a name or by a named
object directly or indirectly. This latter feature provides a mechanism for garbage collection.)
(PROG (toKB toKBContents fromKBState env names (fileEntities (CONS))
(namedEntities (CONS)))
[COND
((OR (NULL toKBName)
(EQ toKBName fromKBName)) (* Bad toKBName)
(SETQ toKBName (HELPCHECK
"toKBName must be given and be different than fromKBName.
To continue, RETURN the new toKBName"]
[COND
((AND assocKBNames (LITATOM assocKBNames)) (* Makes sure that assocKBNames is always a list, or
NIL)
(SETQ assocKBNames (LIST assocKBNames]
(SETQ fromKBState (←New
(%$ KBState)
SetName fromKBName))
(SETQ env (← (%$ Environment)
New
(GENSYM))) (* Dummy Environment into which we read the Database)
(SETQ toKB (← (%$ KB)
New toKBName NIL T))
(←%@
toKB contents (LIST fromKBState))
(← env ConnectOutput toKB) (* Now open env which set CurrentNameTable to its
nameTable)
(← env Open) (* Find names of appropriate object.
When writing these out, they will carry along referred
to objects.)
(SETQ names (← env MapObjectNames T assocKBNames T))
[for name obj in names
do (SETQ obj (GetObjectRec name))
(TCONC fileEntities (GETHASH name CurrentNameTable))
(TCONC namedEntities (CONS name (UID obj]
(RESETVAR WritingSummaryFlg T (← toKB WriteEntityFile fileEntities namedEntities
(%@ toKB name)))
(* Remove KBState that constructed this from contents.
There is now a layer summarizing it in contents.
Close its file.)
(← (← fromKBState MyKB)
Close)
(SETQ toKBContents (DREMOVE fromKBState (%@ toKB contents)))
[for c in (%@(GetObjectRec fromKBName)
contents)
do (* add to contents of new KB pointers to other KBs found
in old one)
(COND
((NOT (← c InstOf (QUOTE Layer)))
(NCONC1 toKBContents (← c CopyShallow]
(← toKB WriteBoot)
(← env Close)
(← env Destroy)
(RETURN toKB])
(KBReadBoot
[LAMBDA (kbName) (* dgb: " 1-DEC-82 16:22")
(* Read in index of existing KB given kbName)
(PROG [position layer KB (file (OpenKBFile kbName (QUOTE INPUT]
(COND
((NULL file)
(ERROR kbName "not found."))) (* Print Header containing file name and creation date
to TTY.)
(SETFILEPTR file 0)
(PRINT (READ file)
T) (* Get address of boot layer)
(SETFILEPTR file (IDIFFERENCE (GETEOFPTR file)
20))
(SETQ position (READ file))
(COND
((NEQ (QUOTE BootLayer)
(READ file)) (* Redundancy check to make sure it is a boot layer)
(HELP file "is not a bootable Knowledge Base")))
(SETFILEPTR file position) (* Read boot layer into global name table.)
(RESETVAR CurrentNameTable GlobalNameTable (ReadLayerIndex file kbName))
(SETQ KB (GetObjectRec kbName))
(RETURN KB])
(KBState.AddEntities
[LAMBDA (self entityList) (* dgb: "19-JAN-83 12:19")
(* Add all items on contents and self to entityList. Called by functions which write out the boot layer to make
sure that all layers are added to the list of items to be dumped)
(TCONC entityList (GetEntityRec (UID self T)))
(for item in (%@ contents) do (← item AddEntities entityList])
(KBState.AddToContents
[LAMBDA (self addition) (* dgb: "15-AUG-82 23:54")
(* KBState contents cannot be changed.
Only new ones can be created)
(HELPCHECK "no additions allowed to KBState contents" self "
Type OK to ignore and go on."])
(KBState.Close
[LAMBDA (self env) (* dgb: " 5-JAN-83 16:48")
(* close files if necessary)
(← (← self MyKB)
Close)
(for c in (LISTP (%@ contents)) do (← c Close env])
(KBState.Connect
[LAMBDA (self) (* dgb: " 1-DEC-82 16:48")
(* Read in object file indices from all, possibly
implicit, layers in order. These are being opened for
input only.)
(COND
((EQ (%@ contents)
(QUOTE CURRENT)) (* True for KBStates only. contents=CURRENT means to get
the current version of the KB, possibly reading the boot
layer within MyKB)
(← (← self MyKB)
Connect))
(T (* for each item -
a layer or KBState- in contents, connect item to
nameTable)
(for item in (%@ contents) do (← item Connect])
(KBState.CurrentState
[LAMBDA (self) (* dgb: "17-MAR-82 09:41")
(* Create a KB state which reflects the current state of
this KB)
(PROG (kbs (name (%@ name))
(c (%@ contents)))
[COND
((EQ c (QUOTE CURRENT)) (* Get the current state from the KB with the same name
as this KBState)
(RETURN (← (← self MyKB)
CurrentState]
(SETQ kbs (←New
(%$ KBState)
SetName name))
(←%@
kbs contents (for item in (%@ contents) collect (← item CopyShallow)))
(RETURN kbs])
(KBState.DescribeLayers
[LAMBDA (self dateOrDays assocKB) (* dgb: " 7-JUN-83 17:14")
(* Return a KBState whose contents are just those layers
which occur after dateOrDays and have kb assocKB, or NIL
if none)
(PROG (startDate newKBState (describedLayers (CONS)))
(COND
[(OR (NUMBERP dateOrDays)
(SETQ dateOrDays 1)) (* Number of days ago. Default is 1)
(SETQ startDate (IDIFFERENCE (IDATE (SUBSTRING (DATE)
1 9))
(ITIMES dateOrDays (CONSTANT (IDIFFERENCE (IDATE
" 2-MAY-42 00:00:00")
(IDATE
" 1-MAY-42 00:00:00"]
(T (ERROR dateOrDays "not in correct date format")))
[for item in (%@ contents) when (← item InstOf (QUOTE Layer))
do (COND
([AND (IGREATERP (IDATE (%@ item created))
startDate)
(OR (NOT assocKB)
(EQ assocKB (%@ item assocKB]
(TCONC describedLayers (← item CopyShallow]
(COND
((SETQ describedLayers (CAR describedLayers)) (* There were some layers)
(SETQ newKBState (← (%$ KBState)
New))
(←%@
newKBState name (%@ name))
(←%@
newKBState contents describedLayers)
(RETURN newKBState))
(T (RETURN NIL])
(KBState.MyKB
[LAMBDA (self) (* dgb: " 7-JUN-82 18:29")
(* Return the KB object corresponding to this KBState)
(OR (GetObjectRec (%@ name))
(KBReadBoot (%@ name))
(ERROR (%@ name)
"is not the name of a known knowledgeBase"])
(KBState.PrintContents
[LAMBDA (self file) (* dgb: "29-NOV-82 17:21")
(* Fn to Printout a formatted description of the
contents of a KBState.)
(RESETLST (RESETSAVE (DSPFONT))
(printout file "KBState " .FONT LAMBDAFONT (%@ name)
.FONT DEFAULTFONT " created" (%@ created)
T "Contents:")
(COND
((LITATOM (%@ contents))
(PRINT (%@ contents)
file))
(T (TERPRI file)
(for item in (%@ contents) do (← item PrintContents))
(printout file .FONT DEFAULTFONT])
(KBState.ReadBoot
[LAMBDA (self) (* dgb: " 8-MAR-82 16:54")
(* Read the boot file for this KB)
(KBReadBoot (%@ name])
(KBState.SetContents
[LAMBDA (self lst) (* dgb: " 3-MAR-82 10:51")
(* Error if change attempted to KBState)
(ERROR "no changes allowed to KBState contents" self])
(KBNameForm
[LAMBDA (kbName) (* dgb: "30-JUL-82 12:21")
(* Convert KB name to upper case and strips off any directories or extensions. Issue warning if kbName is not
already in normal form. This fn insures that the names of knowledge bases correspond in an obvious way to the
directory names returned by file servers and operating systems.)
(PROG (uName)
(SETQ uName (U-CASE (NAMEFIELD kbName)))
(COND
((NEQ uName kbName)
(WRITE "(Using " uName " for " kbName ")")))
(RETURN uName])
(Layer.AddEntities
[LAMBDA (self entityList) (* dgb: "19-JAN-83 12:19")
(* Add self to entity list for dumping on boot layer)
(TCONC entityList (GetEntityRec (UID self T])
(Layer.Close
[LAMBDA (self) (* dgb: " 5-JAN-83 16:36")
(* Do nothing. Dummy so one can recurse through contents
of a KB)
NIL])
(Layer.Connect
[LAMBDA (self) (* dgb: " 6-DEC-82 11:19")
(* Open layer file and read in index.)
(PROG (file)
LP (SETQ file (OpenKBFile (%@ kbName)
(QUOTE INPUT)))
(SETFILEPTR file (%@ position))
(ReadLayerIndex file self])
(Layer.MapObjectNames
[LAMBDA (self mapFn noUIDs) (* dgb: "29-NOV-82 17:33")
(* apply mapFn to objectnames in layer, or make a list
of them if mapFn=NIL)
(PROG [name indexPosition entityCount nameCount (nameList (CONS))
(file (OpenKBFile (%@ kbName]
(SETFILEPTR file (%@ position))
(SETQ indexPosition (READ file))
(SETQ entityCount (READ file))
(SETQ nameCount (READ file))
(SETFILEPTR file indexPosition)
[RPTQ entityCount (SETQ name (MKNAME (READ file)))
(READ file) (* pass index entry)
(OR noUIDs (COND
(mapFn (APPLY* mapFn name))
(T (TCONC nameList name]
[RPTQ nameCount (SETQ name (MKNAME (READ file))
(READ file) (* pass UID in file)
(COND
(mapFn (APPLY* mapFn name))
(T (TCONC nameList name]
(RETURN (CAR nameList])
(Layer.PrintContents
[LAMBDA (self file) (* dgb: "29-NOV-82 16:55")
(* Print contents of layer)
(printout file "Layer on " (%@ kbName)
" created "
(%@ created)
" by "
(%@ creator)
T])
(NewNameTable
[LAMBDA (self) (* dgb: "25-FEB-82 11:36")
(* create a hash array to act as a name table)
(PROG [(oldNameTable (GetValueOnly self (QUOTE nameTable]
(RETURN (COND
((AND (LISTP oldNameTable)
(HARRAYP (CAR oldNameTable)))
(CLRHASH oldNameTable))
(T (PutValueOnly self (QUOTE nameTable)
(CONS (HARRAY 127])
(OpenKBFile
[LAMBDA (name access) (* dgb: "29-NOV-82 17:15")
(* Open a KB for access. Add it to the list of
OpenKBFiles)
(OR access (SETQ access (QUOTE INPUT)))
(PROG ((fn (KBFullName name)))
[COND
((NULL fn)
(ERROR name " is not a defined KB"))
[(OPENP fn)
(COND
((NOT (OPENP fn access))
(CLOSEF fn)
(OPENFILE fn access]
(T (OPENFILE fn access)
(push OpenKBFiles (CONS name fn]
(RETURN fn])
(PositionEntityFile
[LAMBDA (entityRec filePos) (* dgb: "30-NOV-82 16:23")
(* Position the file pointer on the layer file so that
the next item read is the entity facts.)
(PROG (file (position (OR filePos (fetch localRecord of entityRec)))
(layer (fetch storedIn of entityRec))) (* storedIn must be a layer if this object is to be read
in)
(SETFILEPTR (SETQ file (OpenKBFile (EntityKB entityRec)))
position)
(RETURN file])
(ReadFacts
[LAMBDA (entityRec position) (* dgb: "19-JAN-83 17:17")
(* * This function will read in the facts from a file, either creating a new record if needed, or using the old
one present. It is invoked via GetObjectRec. The nameTable is passed as an argument to handle the case where
environmental objects are being read into the globalNameTable. Other objects may be read during the process of
reading this object. The variable CurrentNameTable is set to direct their placement.)
(PROG (char objectRec temp fileHandle (uid (fetch UID of entityRec)))
[COND
((EQ position 0)
(RETURN (ReadIncrementalFacts entityRec]
(SETQ fileHandle (PositionEntityFile entityRec position))
(SELECTQ (SETQ char (READC fileHandle))
[(c C)
(replace localRecord of entityRec with (SETQ objectRec
(create class
classUnitRec ← uid)))
(COND
((EQ char (QUOTE c))
(* * Old format KBs. Problem with instances pointed to by classes)
(FillInClass objectRec (READ fileHandle)))
(T
(* * New format KBs Reads pieces of class structure individually)
(FillInClass1 objectRec fileHandle]
[i (SETQ objectRec (create instance
instUnitRec ← uid))
(COND
(LeafInstanceFlg (READC fileHandle)
(* Read leftParen and then class)
(SETQ temp (READ fileHandle))
(* localRecord is position on file of descr)
(FillIVs objectRec temp NIL (fetch localRecord of entityRec))
)
(T (FillIVs objectRec (CAR (SETQ temp (READ fileHandle)))
(CDR temp)
T]
(e (* use function named on file to read in object)
(SETQ objectRec (APPLY* (READ fileHandle)
fileHandle)))
(HELP "Strange Facts Type on File" NIL))
(* Puts in the back pointer from the object to the unit
record)
(replace localRecord of entityRec with objectRec)
(RETURN objectRec])
(ReadLayerIndex
[LAMBDA (file layer) (* edited: "24-FEB-83 15:36")
(* * Reads the layer index into core. The layer index pairs UIDs with file addresses of object descriptions.
ReadLayerIndex assumes that the file is open, and positioned in the correct place for the table.
It reads the layer index into CurrentNameTable. First entry on filelayer is the position of the index table.
Second entry is the indexCount)
(PROG (name entity locRec (position (READ file))
(entityCount (READ file))
(nameCount (READ file)))
(SETFILEPTR file position)
(OR CurrentNameTable (ERROR "Trying to read Layer with no name table"))
[for I from 1 to entityCount
do (SETQ name (MKNAME (READ file))) (* Read in the indices for each entity.)
(SETQ position (READ file)) (* if file contains NIL then item is deleted)
(COND
[(SETQ entity (OR (GETHASH name GlobalNameTable)
(GETHASH name CurrentNameTable)))
(* UID has been seen before)
(SETQ locRec (fetch localRecord of entity))
(COND
((NULL position) (* deleted item)
(COND
((type? instance locRec) (* Delete previously read in object)
(← locRec Destroy))) (* put NIL in CurrentNameTable if item is deleted)
(DeleteEntity name CurrentNameTable)
(DeleteEntity name GlobalNameTable))
[(FIXP locRec) (* entity from previous layer)
(COND
((ILESSP position 0) (* incremental facts)
(HELP "Incremental Facts Storage NotImplemented Yet"))
(T (replace localRecord of entity with position)
(replace storedIn of entity with layer]
(T (* Rare case: item has been read in before;
we reuse old structure.)
(replace storedIn of entity with layer)
(ReadOverFacts entity file position]
(T
(* * Usual case -- UID never seen before)
(COND
((NULL position) (* Deleted Object, just ignore)
NIL)
((ILESSP position 0) (* incremental load)
(HELP "Incremental Facts Storage NotImplemented Yet"))
(T (SETQ entity (create Entity
UID ← name
localRecord ← position
storedIn ← layer))
(PUTHASH name entity (OR CurrentNameTable GlobalNameTable]
(for I from 1 to nameCount
do (* Now assoc names with objects.)
(PUTHASH (MKNAME (READ file))
(GETHASH (MKNAME (READ file))
CurrentNameTable)
CurrentNameTable])
(ReadLeafObj
[LAMBDA (objectRec) (* dgb: "19-JAN-83 12:21")
(* * Reads in the facts from a file over an existing object. It is invoked via GetVarNth, PutVarNth, and
ObjectIVMissing)
(PROG [char temp fileHandle (entityRec (GetEntityRec (UID objectRec T]
(SETQ fileHandle (PositionEntityFile entityRec (fetch otherIVs of objectRec)))
(COND
((NEQ (QUOTE i)
(SETQ char (READC fileHandle)))
(ERROR char "Not an instance leaf")))
(FillIVs objectRec (CAR (SETQ temp (READ fileHandle)))
(CDR temp)
T)
(RETURN objectRec])
(ReadOverFacts
[LAMBDA (entity file position) (* dgb: "19-JAN-83 12:24")
(* read in the facts reusing oldFacts that have been
previously seen. oldFacts are the objectRec.
Makes sure it is appropriate datatype)
(PROG (temp (objectRec (fetch localRecord of entity))
(filePos (GETFILEPTR file)))
(SETFILEPTR file position)
(SELECTQ (READC file)
(c [COND
([NOT (type? class (SETQ objectRec (fetch localRecord of entity]
(replace localRecord of entity with (SETQ objectRec (create class]
(FillInClass objectRec (READ file)))
(i [COND
([NOT (type? instance (SETQ objectRec (fetch localRecord of entity]
(replace localRecord of entity with (SETQ objectRec (create instance]
(FillIVs objectRec (CAR (SETQ temp (READ file)))
(CDR temp)
T))
(HELP "Strange Facts Type on File" NIL))
(replace OBJUID of objectRec with (fetch UID of entity))
(* Puts in the uid in the object record)
(SETFILEPTR file filePos) (* Restore old file position so ReadLayerIndex can
continue)
(RETURN objectRec])
(SelectChangedEntity
[LAMBDA (entity name) (* dgb: "29-NOV-82 01:04")
(* * Called from a loop in WriteLayer. Used to collect on TCONC lists changedEntities and namedEntities entities
and names which should be written on the layer file)
(DECLARE (USEDFREE changedEntities namedEntities kbName self))
(* An entity needs to be dumped if it is newly deleted, or has been modified and it is of the right KB, or we are
dumping all KBs kbName=T)
(PROG ((place (fetch storedIn of entity))
(lr (fetch localRecord of entity)))
(* * place is the name of a KB for new Objects. place is a Layer for old Objects.)
(COND
([COND
((NULL lr) (* Deleted entity. Dump it if not a new Object)
(NOT (LITATOM place)))
((EntityModified entity) (* Dump modified object if in correct KB)
(OR (EQ kbName T)
(COND
((LITATOM place)
(EQ kbName place))
(T (EQ kbName (%@ place assocKB]
(COND
((EQ name (fetch UID of entity)) (* name is a UID)
(TCONC changedEntities entity))
(T (* This is a name. The function UID returns file form
for the uid (a string))
(TCONC namedEntities (CONS name (UID entity])
(WriteEntityFile
[LAMBDA (openFile FileEntities namedEntities bootFileFlg)
(* dgb: "28-NOV-82 23:54")
(* FileEntities and namedEntities are TCONC lists (list . tail) of the items to be dumped.
It is assumed that file is open, and that it is in the correct position to write on. Closing the file must be done
by the caller.)
(DECLARE (SPECVARS FileEntities))
(PROG [initialFilePosition indexPosition (file (OR (OPENP openFile (QUOTE OUTPUT))
(ERROR openFile "not open for output"]
(SETQ initialFilePosition (SETFILEPTR file (GETEOFPTR file)))
(SPACES 30 file) (* Making room for indexPosition, entityCount and
nameCount at beginning of layer)
(RESETVAR WritingLayerFlg T (for entity in (CAR FileEntities) do (WriteFacts entity file)))
(SETQ indexPosition (GETFILEPTR file))
(for entity in (CAR FileEntities) do (WriteIndexEntry entity file))
(for namedEntity in (CAR namedEntities) do (WriteNameEntry namedEntity file))
(SPACES 8 file)
(PRINT initialFilePosition file) (* Redundant backpointer to beginning of layer in file)
(COND
(bootFileFlg (PRINT (QUOTE BootLayer)
file)))
(SETFILEPTR file initialFilePosition)
(PRINT indexPosition file)
(PRINT (LENGTH (CAR FileEntities))
file)
(PRINT (LENGTH (CAR namedEntities))
file)
(RETURN file])
(WriteFacts
[LAMBDA (entity file) (* dgb: " 1-DEC-82 16:09")
(PROG ((lr (fetch localRecord of entity))) (* don't dump any facts for deleted entity
(lr = NIL))
(RETURN (COND
(lr [COND
((NUMBERP lr) (* In case of Summarizing, this object has not yet been
read in)
(SETQ lr (ReadFacts entity lr] (* This stores the filePosition tempoarily in the
modified flag)
(Modified (fetch localRecord of entity)
(← lr DumpFacts file])
(WriteIndexEntry
[LAMBDA (entity file) (* dgb: " 2-DEC-82 13:09")
(* Writes the index entry on the file for the facts associated with an entity. The file address of the facts is
stored in the modifed flag of the entity by WriteFacts)
(PROG ((rec (fetch localRecord of entity)))
(PRIN2 (UID entity)
file)
(SPACES 1 file)
(COND
(rec (PRINT (Modified? rec)
file)
(Modified rec NIL))
(T (* deleted entity)
(replace storedIn of entity with NIL)
(PRINT NIL file])
(WriteNameEntry
[LAMBDA (namedEntity file) (* dgb: " 9-NOV-81 12:34")
(* This is called by Layer.Write to dump out name
entries. A namedEntity is a dotted pair of
(name . UID) gathered up by SelectChangedEntity)
(PRIN1 (CAR namedEntity)
file)
(SPACES 1 file)
(PRINT (CDR namedEntity)
file])
)
(* Set the value of the variable GlobalEnvironment)
(CreateGlobalEnvironment)
(* Copyright (c) 1982 by Xerox Corporation)
(DECLARE: DONTCOPY
(FILEMAP (NIL (16480 72846 (CloseKBFile 16490 . 16940) (CreateGlobalEnvironment 16942 . 17883) (
CutBackToBootLayer 17885 . 18540) (DeleteEntity 18542 . 18976) (EntityKB 18978 . 19559) (
Environment.AssocKB 19561 . 20240) (Environment.ChangedKBs 20242 . 20660) (Environment.Cleanup 20662
. 21564) (Environment.ClearObjectMemory 21566 . 22578) (Environment.Close 22580 . 23262) (
Environment.ConnectOutput 23264 . 24997) (Environment.CopyObjects 24999 . 25764) (
Environment.Disconnect 25766 . 26154) (Environment.Cancel 26156 . 26788) (Environment.IsCurrent 26790
. 27103) (Environment.MakeCurrent 27105 . 27647) (Environment.MakeNotCurrent 27649 . 28198) (
Environment.MapObjectNames 28200 . 29236) (Environment.Open 29238 . 29700) (Environment.WriteBoot
29702 . 29964) (FindChangedKB 29966 . 30300) (GlobalInstanceMeta.New 30302 . 30894) (KB.AddToContents
30896 . 32163) (KB.Close 32165 . 32652) (KB.ConnectForOutput 32654 . 33090) (KB.CopyFileLayer 33092 .
35311) (KB.CopyFileLayers 35313 . 35707) (KB.Disconnect 35709 . 36042) (KB.FileName 36044 . 36183) (
KB.FreezeKB 36185 . 36815) (KB.PrintContents 36817 . 37420) (KB.SetContents 37422 . 37935) (KB.ThawKB
37937 . 38600) (KB.WriteBoot 38602 . 39535) (KB.WriteEntityFile 39537 . 40302) (KB.WriteFileLayer
40304 . 41629) (KBFileName 41631 . 41859) (KBFullName 41861 . 42276) (KBMeta.Close 42278 . 42924) (
KBMeta.New 42926 . 44250) (KBMeta.Old 44252 . 44876) (KBMeta.ReadOldBootLayer 44878 . 46262) (
KBMeta.Summarize 46264 . 49141) (KBReadBoot 49143 . 50317) (KBState.AddEntities 50319 . 50768) (
KBState.AddToContents 50770 . 51135) (KBState.Close 51137 . 51444) (KBState.Connect 51446 . 52303) (
KBState.CurrentState 52305 . 53037) (KBState.DescribeLayers 53039 . 54432) (KBState.MyKB 54434 . 54795
) (KBState.PrintContents 54797 . 55443) (KBState.ReadBoot 55445 . 55689) (KBState.SetContents 55691 .
55972) (KBNameForm 55974 . 56587) (Layer.AddEntities 56589 . 56872) (Layer.Close 56874 . 57139) (
Layer.Connect 57141 . 57526) (Layer.MapObjectNames 57528 . 58577) (Layer.PrintContents 58579 . 58919)
(NewNameTable 58921 . 59403) (OpenKBFile 59405 . 60008) (PositionEntityFile 60010 . 60639) (ReadFacts
60641 . 62978) (ReadLayerIndex 62980 . 65909) (ReadLeafObj 65911 . 66579) (ReadOverFacts 66581 . 68011
) (SelectChangedEntity 68013 . 69444) (WriteEntityFile 69446 . 71091) (WriteFacts 71093 . 71721) (
WriteIndexEntry 71723 . 72391) (WriteNameEntry 72393 . 72844)))))
STOP