(FILECREATED "29-Feb-84 16:04:12" {INDIGO}<LOOPS>SOURCES>LOOPSDATABASE.;19 78031
changes to: (FNS KBReadBoot ReadFacts ReadLayerIndex ReadOverFacts)
previous date: "10-Feb-84 23:29:57" {INDIGO}<LOOPS>SOURCES>LOOPSDATABASE.;18)
(* Copyright (c) 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT LOOPSDATABASECOMS)
(RPAQQ LOOPSDATABASECOMS ((* Copyright (c)
1982 by Xerox Corporation)
(* Classes which manipulate the database)
(CLASSES * DATABASECLASSES)
(METHODS Environment.AssocKB Environment.Cancel Environment.ChangedKBs Environment.Cleanup
Environment.ClearObjectMemory Environment.Close Environment.ConnectOutput
Environment.Disconnect Environment.IsCurrent Environment.MakeCurrent
Environment.MakeNotCurrent Environment.MapObjectNames Environment.Open
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 KBMeta.Close KBMeta.New KBMeta.Old KBMeta.ReadBoot
KBMeta.ReadOldBootLayer KBMeta.Summarize KBState.AddEntities KBState.AddToContents
KBState.Close KBState.Connect KBState.CurrentState KBState.DescribeLayers
KBState.MyKB KBState.PrintContents KBState.ReadBoot KBState.SetContents
Layer.AddEntities Layer.Close Layer.Connect Layer.MapObjectNames Layer.PrintContents
Object.DumpFacts Class.DumpFacts Object.AssocKB Object.AssocKB?)
(* * Functions for the database classes)
(FNS * DATABASEFNS)
(* Set the value of the variable GlobalEnvironment)
(* Copyright (c)
1982 by Xerox Corporation)))
(* 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)
(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)
))]
[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)]
[DEFCLASS KB
(MetaClass KBMeta Edited: (* dgb: " 8-DEC-82 16:57")
doc (* Represents a KB file in core)
)
(Supers GlobalNamedObject KBState)
(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)
))]
[DEFCLASS KBMeta
(MetaClass MetaClass Edited: (* dgb: "26-NOV-82 11:56"))
(Supers GlobalInstanceMeta)]
[DEFCLASS KBState
(MetaClass GlobalInstanceMeta Edited: (* dgb: "27-MAY-83 07:31"))
(Supers DatedObject NamedObject)
(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)))]
[DEFCLASS Layer
(MetaClass GlobalInstanceMeta Edited: (* dgb: " 6-DEC-82 12:15"))
(Supers DatedObject)
(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)))]
[METH Environment AssocKB (akb)
(* Make akb be the assocKB of this KB)]
[METH Environment Cancel NIL
(* 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.)]
[METH Environment ChangedKBs NIL
(* Finds the names of all KBs that have any modified entities associated with them)]
[METH Environment Cleanup (KBNames noBootLayerFlg)
(* 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)]
[METH Environment ClearObjectMemory NIL
(* Write out boot layer if needed and clear nameTable.)]
[METH Environment Close (assocKBs)
(* Cleanup an environment so that all files are closed, and environment is empty, as if it were
just created)]
[METH Environment ConnectOutput (KB)
(* Make KB be the file onto which changes in this Environment will be written)]
[METH Environment Disconnect (KB)
(* Make KB be the file onto which changes in this Environment will be written)]
[METH Environment IsCurrent NIL
(* Test if current)]
[METH Environment MakeCurrent NIL
(* Set values of CurrentNameTable and CurrentEnvironment from self and make DefaultKBName be my
assocKB)]
[METH Environment MakeNotCurrent (bitchIfNotCurrent)
(* Makes no Environment Current if this is current, elses causes Error if not Current and
bitchIfNotCurrent=T)]
[METH Environment MapObjectNames (mapFn assocKBs noUIDs)
(* 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)]
[METH Environment Open NIL
(* Read in the index of all the layers referred to by contents of outputKB)]
[METH GlobalInstanceMeta New (kbName envName newVersionFlg)
(* * Create a new KnowledgeBase file, and an environment if name is given, and make environment
current)]
[METH KB AddToContents (newAddition)
(* * Adds a new item to contents of KB)]
[METH KB Close NIL
(* Close the file associated with a KB)]
[METH KB ConnectForOutput (nameTable)
(* Read in object file indices from all, possibly implicit, layers in order. This is being
opened for output.)]
[METH KB CopyFileLayer (layer)
(* Copies the FileLayer referred to by layer onto self, and adds a new Layer describing copied
fileLayer onto contents of self)]
[METH KB CopyFileLayers (layerDescription)
(* Copy all the layers in layerDescription which should be a KBState into self)]
[METH KB Disconnect NIL
(* Disconnect this KB and close its file if open)]
[METH KB FileName NIL
(*)]
[METH KB FreezeKB (name)
(* 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)]
[METH KB PrintContents (file)
(* Fn to Printout a formatted description of the contents of a knowledge base.)]
[METH KB SetContents (lst)
(* Make KB have new contents. Check types of elements)]
[METH KB ThawKB (name)
(* 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)]
[METH KB WriteBoot NIL
(* Write out boot file containing KB and all layers and KBStates it contains implicitly or
explicitly)]
[METH KB WriteEntityFile (changedEntities namedEntities assockbName)
(* * Writes the entities (objects)
out to a layer in a given kb.)]
[METH KB WriteFileLayer (kbName nameTable)
(* * 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)]
[METH KBMeta Close NIL
(* Close all the currently open KBs, and Cancel any attached writers or readers. Set
OpenKBFiles to NIL)]
[METH KBMeta New (kbName envName newVersionFlg)
(* * Create a new KnowledgeBase file, and an environment if name is given, and make environment
current)]
[METH KBMeta Old (kbName envName)
(* 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.)]
[METH KBMeta ReadBoot NIL
(* Read in index of existing KB given kbName)
(method KBReadBoot)]
[METH KBMeta ReadOldBootLayer (kbName numBack)
(* Read in index of already existing KB)]
[METH KBMeta Summarize (fromKBName toKBName assocKBNames namedObjectsOnly)
(* * 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.)]
[METH KBState AddEntities (entityList)
(* 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)]
[METH KBState AddToContents (newAddition)
(* * Adds a new item to contents of KB)]
[METH KBState Close (env)
(* close files if necessary)]
[METH KBState Connect (nameTable)
(* Read in object file indices from all, possibly implicit, layers in order. These are being
opened for input only.)]
[METH KBState CurrentState NIL
(* Create a KB state which reflects the current state of this KB)]
[METH KBState DescribeLayers (dateOrDays assocKB)
(* Return a KBState whose contents are just those layers which occur after dateOrDays and have
kb assocKB, or NIL if none)]
[METH KBState MyKB NIL
(* Return the KB object corresponding to this KBState)]
[METH KBState PrintContents (file)
(* Fn to Printout a formatted description of the contents of a knowledge base.)]
[METH KBState ReadBoot NIL
(* Read the boot file for this KB)]
[METH KBState SetContents (lst)
(* Make KB have new contents. Check types of elements)]
[METH Layer AddEntities (entityList)
(* Add self to entity list for dumping on boot layer)]
[METH Layer Close NIL
(* Do nothing. Dummy so one can recurse through contents of a KB)]
[METH Layer Connect (nameTable)
(* Open layer file and read in index)]
[METH Layer MapObjectNames (mapFn noUIDs)
(* apply mapFn to objectnames in layer, or make a list of them if mapFn=NIL)]
[METH Layer PrintContents (file)
(* Print contents of layer)]
[METH Object DumpFacts (fileHandle)
(* dgb: " 6-DEC-82 13:41")
(method DumpInstanceFacts)]
[METH Class DumpFacts (fileHandle)
(* * Invoked when dumping a class onto a kb. Called by (← class DumpFacts))
(method DumpClassFacts)]
[METH Object AssocKB (newKBName)
(* Change assocKB of this object to newKBName)]
[METH Object AssocKB? NIL
NIL]
(DEFINEQ
(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.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.ChangedKBs
[LAMBDA (self) (* dgb: "26-DEC-83 19:37")
(* Finds the names of all KBs that have any modified
entities associated with them)
(PROG ((changedKBs (CONS)))
(MAPHASH (@ uidTable)
(FUNCTION FindChangedKB))
(RETURN (CAR changedKBs])
(Environment.Cleanup
[LAMBDA (self KBNames noBootLayerFlg) (* dgb: "10-Feb-84 23:13")
(* 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 (@ uidTable)))
(T (for kb in (OR (LISTP KBNames)
(AND KBNames (LIST KBNames))
(← self ChangedKBs))
do (← (@ outputKB)
WriteFileLayer kb (@ uidTable]
(COND
(noBootLayerFlg (PrintStatus "No bootLayer written on " self))
(T (← (@ outputKB)
WriteBoot])
(Environment.ClearObjectMemory
[LAMBDA (self) (* dgb: "24-DEC-83 11:37")
(* 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 (@ uidTable)
(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))
(* 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 (@ uidTable))
(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.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.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: "24-DEC-83 11:30")
(* Set values of CurrentNameTable and CurrentEnvironment
from self and make DefaultKBName be my assocKB)
(COND
[(EQ self GlobalEnvironment)
(SETQ CurrentUIDTable (SETQ DefaultKBName (SETQ CurrentNameTable (SETQ CurrentEnvironment NIL]
(T (SETQ CurrentNameTable (@ nameTable))
(SETQ CurrentUIDTable (@ uidTable))
(SETQ CurrentEnvironment self)
(SETQ DefaultKBName (@ assocKB])
(Environment.MakeNotCurrent
[LAMBDA (self bitchIfNotCurrent) (* dgb: "28-DEC-83 07:50")
(* 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 CurrentUIDTable 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-DEC-83 23:04")
(* APPLY mapFn to the name of each object stored in the environment. If assocKBs given, select only those which
are in the list. Applies only to names which are not UIDs.)
(PROG ((nameList (CONS)))
(COND
((EQ mapFn T)
(SETQ noUIDS NIL)
(SETQ mapFn NIL)))
[MAPHASH (@ nameTable)
(FUNCTION (LAMBDA (val key)
(COND
((LITATOM key)
(COND
((AND assocKBs (NOT (FMEMB (EntityKB (GetEntityFromUID (UID val)))
assocKBs)))
(* Don't do anything in this case)
)
(mapFn (APPLY* mapFn key))
(T (TCONC nameList key]
[OR noUIDS (MAPHASH (@ uidTable)
(FUNCTION (LAMBDA (val key)
(COND
((AND assocKBs (NOT (FMEMB (EntityKB val)
assocKBs)))
(* Don't do anything in this case)
)
(mapFn (APPLY* mapFn key))
(T (TCONC nameList key]
(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])
(GlobalInstanceMeta.New
[LAMBDA (class name) (* dgb: "10-Feb-84 22:13")
(* Creates an instance of a particular class.
Called by Environmental objects to ensure that they
appear only in global name table.)
(RESETLST (RESETSAVE CurrentNameTable NIL)
(RESETSAVE CurrentUIDTable NIL)
(RESETSAVE CurrentEnvironment NIL)
(RESETSAVE DefaultKBName NIL)
(PROG ((obj (←Super
class New name)))
(UID obj)
(RETURN obj])
(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: "26-DEC-83 22:18")
(* Write out boot file containing KB and all layers and
KBStates it contains implicitly or explicitly)
(PROG (file entityList nameList)
(OR (SETQ file (KBFullName (@ name)
T))
(ERROR (@ name)
"not an open KB for WriteBoot"))
(COND
((NEQ (@ status)
(QUOTE BootNeeded)) (* No Boot Needed)
(RETURN NIL)))
(SETQ entityList (CONS))
(SETQ nameList (CONS))
(← 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 uidTable) (* dgb: "10-Feb-84 23:15")
(* * 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 uidTable (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])
(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: "26-DEC-83 15:32")
(* 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 NIL (ReadLayerIndex file kbName))
(RETURN (GetObjectRec kbName])
(KBMeta.Summarize
[LAMBDA (self fromKBName toKBName assocKBNames namedObjectsOnly)
(* dgb: "10-Feb-84 21:10")
(* * 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 NIL assocKBNames T))
(for name entity uid in names
do (SETQ uid (UID (GetObjectRec name)))
(COND
((NOT (FMEMB (SETQ entity (GetEntityFromUID uid))
(CAR fileEntities)))
(TCONC fileEntities entity)))
(TCONC namedEntities (CONS name uid)))
(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])
(KBState.AddEntities
[LAMBDA (self entityList) (* dgb: "26-DEC-83 22:12")
(* 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 (GetEntityFromUID (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])
(Layer.AddEntities
[LAMBDA (self entityList) (* dgb: "26-DEC-83 15:25")
(* Add self to entity list for dumping on boot layer)
(TCONC entityList (GetEntityFromUID (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])
(Object.AssocKB
[LAMBDA (self newKBName) (* dgb: "26-DEC-83 15:26")
(* Change assocKB of this object to newKBName)
(COND
[(NULL newKBName)
(PROG ((uid (fetch OBJUID of self)))
(RETURN (COND
((NULL uid)
NIL)
(T (EntityKB (GetEntityFromUID uid]
(T (PROG ((uid (UID self T))) (* UID insures that there is an entity record)
(Modified self T)
(replace storedIn of (GetEntityFromUID uid) with newKBName)
(RETURN newKBName])
(Object.AssocKB?
[LAMBDA (self) (* dgb: "26-DEC-83 15:26")
(PROG ((uid (fetch OBJUID of self)))
(RETURN (COND
((NULL uid)
NIL)
(T (EntityKB (GetEntityFromUID uid])
)
(* * Functions for the database classes)
(RPAQQ DATABASEFNS (CloseKBFile CreateGlobalEnvironment CutBackToBootLayer DumpClassFacts
DumpPruneDescr DumpPruneDescr1 EntityKB EntityModified
Environment.WriteBoot FillInClass FillInClass1 FindChangedKB
KBFileName KBFullName KBNameForm KBReadBoot 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: "26-DEC-83 15:32")
(* 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)
ObjNameTable)
(←@
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])
(DumpClassFacts
[LAMBDA (class fileHandle) (* dgb: "18-OCT-83 21:19")
(* * 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)
(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])
(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])
(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])
(Environment.WriteBoot
[LAMBDA (self) (* dgb: " 3-MAR-82 10:34")
(* Make outputKB write it's boot file)
(← (%@ outputKB)
WriteBoot])
(FillInClass
[LAMBDA (class classFileForm) (* DECLARATIONS: (RECORD classFileDescription
(mc lvn lvd cvn cvd cn sup ocd sel met omd)))
(* dgb: "18-OCT-83 21:11")
(* * 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 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: "18-OCT-83 21:11")
(* 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])
(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])
(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])
(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])
(KBReadBoot
[LAMBDA (kbName) (* dgb: "29-Feb-84 15:46")
(* 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)
(LoopsHelp file "is not a bootable Knowledge Base")))
(SETFILEPTR file position) (* Read boot layer into global name table.)
(RESETLST (RESETSAVE CurrentNameTable NIL)
(RESETSAVE CurrentUIDTable NIL)
(ReadLayerIndex file kbName))
(SETQ KB (GetObjectRec kbName))
(RETURN KB])
(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: "29-Feb-84 15:47")
(* * 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)))
(LoopsHelp "Strange Facts Type on File" char))
(* Puts in the back pointer from the object to the unit
record)
(replace localRecord of entityRec with objectRec)
(RETURN objectRec])
(ReadLayerIndex
[LAMBDA (file layer) (* dgb: "29-Feb-84 15:47")
(* * 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 (uid entity locRec (position (READ file))
(entityCount (READ file))
(nameCount (READ file)))
(SETFILEPTR file position)
[for I from 1 to entityCount
do (SETQ uid (READ file)) (* Read in the indices for each entity.)
(SETQ position (READ file)) (* if file contains NIL then item is deleted)
(COND
[(SETQ entity (GetEntityFromUID uid)) (* 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 if item is deleted)
(PutObjectUID uid NIL))
[(FIXP locRec) (* entity from previous layer)
(COND
((ILESSP position 0) (* incremental facts)
(LoopsHelp "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)
(LoopsHelp "Incremental Facts Storage NotImplemented Yet"))
(T (SETQ entity (create Entity
UID ← uid
localRecord ← position
storedIn ← layer))
(PutObjectUID uid entity]
(COND
((IGREATERP nameCount 0)
(for pr in (for I from 1 to nameCount collect (CONS (READ file)
(READ file)))
do (PutObjectName (CAR pr)
(GetObjFromUID (CDR pr])
(ReadLeafObj
[LAMBDA (objectRec) (* dgb: "26-DEC-83 15:27")
(* * Reads in the facts from a file over an existing object. It is invoked via GetVarNth, PutVarNth, and
ObjectIVMissing)
(PROG [char temp fileHandle (entityRec (GetEntityFromUID (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: "29-Feb-84 15:47")
(* read in the facts reusing oldFacts that have been
previously seen. oldFacts are the objectRec.
Makes sure it is appropriate datatype)
(PROG (char temp (objectRec (fetch localRecord of entity))
(filePos (GETFILEPTR file)))
(SETFILEPTR file position)
(SELECTQ (SETQ char (READC file))
[(C c)
[COND
([NOT (type? class (SETQ objectRec (fetch localRecord of entity]
(replace localRecord of entity with (SETQ objectRec (create class]
(COND
((EQ char (QUOTE c))
(* * Old format KBs. Problem with instances pointed to by classes)
(FillInClass objectRec (READ file)))
(T
(* * New format KBs Reads pieces of class structure individually)
(FillInClass1 objectRec 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))
(LoopsHelp "Strange Facts Type on File" char))
(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: "10-Feb-84 23:20")
(* * 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)
(OR (NULL place)
(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]
(TCONC changedEntities entity)
(AND lr (for name in (GetObjectNames lr) when (NOT (STRINGP name))
do (TCONC namedEntities (CONS name (UID lr])
(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: "10-Feb-84 23:23")
(* 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 (fetch UID of 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)
(* Copyright (c) 1982 by Xerox Corporation)
(PUTPROPS LOOPSDATABASE COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (13493 50209 (Environment.AssocKB 13503 . 14182) (Environment.Cancel 14184 . 14816) (
Environment.ChangedKBs 14818 . 15234) (Environment.Cleanup 15236 . 16130) (
Environment.ClearObjectMemory 16132 . 17084) (Environment.Close 17086 . 17768) (
Environment.ConnectOutput 17770 . 19503) (Environment.Disconnect 19505 . 19893) (Environment.IsCurrent
19895 . 20208) (Environment.MakeCurrent 20210 . 20810) (Environment.MakeNotCurrent 20812 . 21389) (
Environment.MapObjectNames 21391 . 22601) (Environment.Open 22603 . 23065) (GlobalInstanceMeta.New
23067 . 23670) (KB.AddToContents 23672 . 24939) (KB.Close 24941 . 25428) (KB.ConnectForOutput 25430 .
25866) (KB.CopyFileLayer 25868 . 28087) (KB.CopyFileLayers 28089 . 28483) (KB.Disconnect 28485 . 28818
) (KB.FileName 28820 . 28959) (KB.FreezeKB 28961 . 29591) (KB.PrintContents 29593 . 30196) (
KB.SetContents 30198 . 30711) (KB.ThawKB 30713 . 31376) (KB.WriteBoot 31378 . 32344) (
KB.WriteEntityFile 32346 . 33111) (KB.WriteFileLayer 33113 . 34435) (KBMeta.Close 34437 . 35083) (
KBMeta.New 35085 . 36409) (KBMeta.Old 36411 . 37035) (KBMeta.ReadOldBootLayer 37037 . 38409) (
KBMeta.Summarize 38411 . 41308) (KBState.AddEntities 41310 . 41762) (KBState.AddToContents 41764 .
42129) (KBState.Close 42131 . 42438) (KBState.Connect 42440 . 43297) (KBState.CurrentState 43299 .
44031) (KBState.DescribeLayers 44033 . 45426) (KBState.MyKB 45428 . 45789) (KBState.PrintContents
45791 . 46437) (KBState.ReadBoot 46439 . 46683) (KBState.SetContents 46685 . 46966) (Layer.AddEntities
46968 . 47255) (Layer.Close 47257 . 47522) (Layer.Connect 47524 . 47909) (Layer.MapObjectNames 47911
. 48960) (Layer.PrintContents 48962 . 49302) (Object.AssocKB 49304 . 49942) (Object.AssocKB? 49944 .
50207)) (50716 77830 (CloseKBFile 50726 . 51176) (CreateGlobalEnvironment 51178 . 52114) (
CutBackToBootLayer 52116 . 52771) (DumpClassFacts 52773 . 53891) (DumpPruneDescr 53893 . 55078) (
DumpPruneDescr1 55080 . 56199) (EntityKB 56201 . 56782) (EntityModified 56784 . 57210) (
Environment.WriteBoot 57212 . 57474) (FillInClass 57476 . 59186) (FillInClass1 59188 . 61179) (
FindChangedKB 61181 . 61515) (KBFileName 61517 . 61745) (KBFullName 61747 . 62162) (KBNameForm 62164
. 62777) (KBReadBoot 62779 . 64002) (NewNameTable 64004 . 64486) (OpenKBFile 64488 . 65091) (
PositionEntityFile 65093 . 65722) (ReadFacts 65724 . 68075) (ReadLayerIndex 68077 . 70691) (
ReadLeafObj 70693 . 71365) (ReadOverFacts 71367 . 73098) (SelectChangedEntity 73100 . 74411) (
WriteEntityFile 74413 . 76058) (WriteFacts 76060 . 76688) (WriteIndexEntry 76690 . 77375) (
WriteNameEntry 77377 . 77828)))))
STOP