Page Numbers: Yes First Page: 1
Heading:

October 4, 1977 4:29 PM[IFS]<KRL>code>matcher.bravo

Status: first pass

Common functions for the KRL-1 matcher

This file contains the low level utility functions used by the Align functions. They should be of use for the access compiler as well.:

# # # # # # # # # # # # # # #

Record declarations

(RECORD Result (bindings actions . resultValue))

This is the structure for returning results at each level in the goal tree. Each of these records represents a coordinated set of bindings and actions -- i.e. there is only one binding for any one variable, and the actions are to use those bindings.

bindings: A list of Binding records with distinct variables (no two alike).

actions: A list of Action records

resultValue: ANY -- The returnValue field is used for deciding what to return as the value of Align, if this is a result for a top level goal. It can be set by the user to override defaults.

# # # # # # # # # # # # # # #

(RECORD Binding (bindingVariable bindingValue . virtualFlg))

This is the structure for representing a value bound to a variable.

bindingVariable: A LITATOM

bindingValue: An arbitrary thing bound to the variable

vitrtualFlg: T or NIL. T means that the value is a list which was generated internally, rather than found explicitly (e.g. by a BindElement with count = ALL). In checking for binding compatibility, if two bindings with the same variable name have this flag set, a set equality check is used which ignores order.

# # # # # # # # # # # # # # #

(RECORD Action (actionForm actionSpec actionBinding . actionParent))

This is the structure for representing an action to be done when a match is complete.

actionForm: An ActionForm record. The actual argument to the Do which created this action.

actionSpec: An ActionForm record. Parallels the actionForm, but with the arguments evaluated (including substituting an internal type name for the actionType)

actionBinding: An anchor path (list of handles as described in Goal). The action is to be taken to the CAR of the path. The path is needed to decide what triggering to do of demons.

actionParent: An Action record or NIL. In expanding an action specified by the user, the system builds new actions which carry out subparts of the job. They are linked in a tree (only upward links), in order to avoid redundant triggering.

# # # # # # # # # # # # # # #

(RECORD ActionForm (actionType actionArg actionTest actionCount)
(RECORD ActionForm (actionType . actionArgs))

This structure is the template for the specifications of actions for Do (see section 7.1 in the specs).

actionType: An atom. For ActionForms typed by the user, it will be one of Describe, OverWrite, Substitute, SubstituteDescriptor, AddDescriptor, AddElement, AddBefore, AddAfter, SubstituteElement. For internally created ones (e.g. the ones which appear as the actionSpec of an Action), it will be the name of an action type class (see classes.bravo for a list of the ones currently implemented).

actionArg: A handle or Lisp pointer. This is the argument specifying the change to be made -- the new thing, or thing to be substituted, etc. See section 7.1 for details.

actionTest: See 7.1.

actionCount: See 7.1.

# # # # # # # # # # # # # # #

(RECORD BindingForm (bindingType variableSpec valueType bindingTest bindingCount))

This structure is the template for the specifications of bindings for Do (see section 7.1 in the specs).

bindingType: An atom. One of Bind, BindElement.

variableSpec: An atom (to be used without evaluation) or something which evaluates to an atom. See section 7.1 for details.

valueType: An atom (to be used without evaluation) or something which evaluates to an atom. See 7.1.

bindingTest: See 7.1.

bindingCount: See 7.1.

# # # # # # # # # # # # # # #

(RECORD Count (totalNum complete initialNum . finalNum)
(Count (totalNum complete . sequence))

This structure is used to specify the nature of an enumeration, so that descriptors can be checked to see if they could satisfy it.

totalNum: An integer. The minimum number of elements which could be in a satisfactory enumeration

complete: T or NIL, specifying whether the enumeration must be complete. If T, it means that the enumeration must contatin exactly totalNum elements.

initialNum: The number of elements at the front of a sequence which must be explicitly given (i.e. not ellipsis) in order to be able to determine a match with the pattern which set up this count.

finalNum: The number of elements at the end of a sequence which must be explicitly given (i.e. not ellipsis) in order to be able to determine a match with the pattern which set up this count.

sequence: If this is NIL (which implies that initialNum and finalNum aren’t given) the enumeration is for a set, rather than sequence.

# # # # # # # # # # # # # # #

[CompatibleBindings ((result1 Result)(result2 Result)(RETURNS BOOL))
(DPROG ((binding2 NIL Binding))
(RETURN
(for binding in result1:bindings
always (OR (NOT (binding2 ← (FASSOC binding:bindingVariable
result2:bindings)))
(if binding:virtualFlg
then (SameSet binding2:bindingValue binding:bindingValue)
else (KrlEqual binding2:bindingValue binding:bindingValue)))]

# # # # # # # # # # # # # # #

[ComparePost ((post1 Descriptor)(post2 Descriptor) (RETURNS BOOL))
(DPROG ((type1 (TypeD post1) LITATOM))
(RETURN
(if (EQ type1 (TypeD post2))
then (SELECTQ type1
(LispPointer (EQUAL (LispContentsOf post1)(LispContentsOf post2)))
(KrlPointer (EQH (GetDirectPointer post1 (ConstantHandle))
(GetDirectPointer post2 (ConstantHandle))))
(Coreference (EQH (FetchMem post1 coref (ConstantHandle))
(FetchMem post1 coref (ConstantHandle)))
(KHelp "not a post descriptor" post1)]

# # # # # # # # # # # # # #

[CouldSatisfyCount ((descr Descriptor)
(countSpec (ONEOF CountSpec FIXP LITATOM))
(sequence BOOL)
(RETURNS (ONEOF POSSIBLE IMPOSSIBLE NIL)))
(* IMPOSSIBLE means that the descriptor is known not to match any enumeration with the specified count. POSSIBLE means that the descriptor is an enumeration descriptor which satisfies the count, NIL means that it is not an enumeration descriptor)
(DPROG((patInitial NIL (ONEOF NIL FIXP)
(* this will be NIL if it is a set, or after the first ellipsis has been found))
(datTotal 0 FIXP)
(datFinal 0 FIXP)
(patTotal 0 FIXP)
(patFinal 0 FIXP)
(complete NIL BOOL))
(if (LISTP countSpec)
then (patTotal ← countSpec:totalNum)
(if (sequence ← (countSpec:sequence))
then (patInitial ← countSpec:initialNum)
(patFinal ← countSpec:finalNum))
(complete ← countSpec:complete)
elseif (EQ countSpec ’ALL)
elseif (EQ countSpec ’COMPLETE)
then (complete ← T)
elseif (NOT (FIXP countSpec))
then (KHelp "illegal count spec" countSpec)
elseif (GREATERP countSpec 0)
then (patInitial ← countSpec)
else (patFinal ← (MINUS countSpec)))
(SELECTQ (TypeD descr)
(Set (if countSpec:sequence then (RETURN ’IMPOSSIBLE)))
(Sequence (OR countSpec:sequence (RETURN ’IMPOSSIBLE)))
(RETURN NIL))

(RETURN
(for anchor fromField elements ofHandle descr
do (if (EQ (KrlType anchor) ’Ellipsis)
then (if (OR complete
(AND patInitial (GREATERP patInitial datTotal)))
then (RETURN ’IMPOSSIBLE)
else (patInitial ← NIL)
(datFinal ← 0))
else (datTotal ← (ADD1 datTotal))
(datFinal ← (ADD1 datFinal)))
finally (if (OR (GREATERP patTotal datTotal)
(AND patFinal
(GREATERP patFinal datFinal)))
then (RETURN ’IMPOSSIBLE)
else (RETURN ’POSSIBLE)]

# # # # # # # # # # # # # # #

[DoProcedures ((link Link) (type LITATOM) (function FUNCTION)
(RETURNS Irrelevant))
(DPROG ((structure link:structure Anchor)
(context link:fullContext:context Context))
(if (NOT context:instance)
then (* this is a coreference link)
(DoTraps type structure link:fullContext:world function))
elseif (NOT (FetchMem structure Named))
then (KHelp "link with instance to non-slot" link)
else (DoTriggers type
structure
context:prototype
context:instance
link:fullContext:world
function]

# # # # # # # # # # # # # # #

[DoTraps ((type TrapType (USEDIN signal))
(ANCHOR Anchor (USEDIN traps))
(WORLD (ONEOF Anchor NIL) (USEDIN traps))
(function FUNCTION)
(RETURNS Irrelevant))
(DPROG((meta (GetMetaDescription ANCHOR) (ONEOF Anchor NIL))
(trap NIL LISTP)
(result NIL ANY))
(RETURN
(if meta
then (for descr fromField descrs ofHandle meta
when (AND (EQ (TypeD descr) ’InterpretedMapD)
(EQ (TypeI descr) ’Trap)
(trap ← (GetInterpretedArg descr))
(EQ trap:1 type))
do (if (MSignalC UsingTrap
(OK (result ← (APPLY* function trap:2)))
NIL)
then (RETURN result))
finally (RETURN NIL]

# # # # # # # # # # # # # # #

[DoTriggers ((type TriggerType)
(slot SlotAnchor)
(prototype SlotAnchor)
(INSTANCE Anchor (USEDIN triggers))
(WORLD (ONEOF Anchor NIL) (USEDIN triggers))
(function FUNCTION)
(RETURNS ANY (* first non-NIL value returned by function)))
(DPROG((SLOT slot SlotAnchor)
(PROTOTYPE prototype SlotAnchor (USEDIN triggers))
(triggers (GetTriggers slot type) LST)
(value NIL ANY))
(for trigger in triggers
do (if (MSignalC UsingTrigger
(OK (value ← (APPLY* function trigger))) NIL)
then (RETFROM DoTriggers value)))
(for entry in (GetFurtherSpecs slot)
when (triggers ← (GetTriggers entry:FSPSlot type))
do (PROTOTYPE ← entry:FSPPrototype)
(MapDescriptors instance
(FUNCTION
(LAMBDA (descr)
(if (AND (EQ (TypeD descr) ’MapDescriptor)
(EQH PROTOTYPE
(FetchMem descr focusSlot (ConstantHandle)))
then (for trigger in triggers
do (if (MSignalC UsingTrigger
(OK(value ← (APPLY* function trigger)))
NIL)then (RETFROM ’DoTriggers value))
finally (RETURN T)
(* to stop MapDescriptors for this FSP))
else NIL))))
finally (RETURN NIL]

# # # # # # # # # # # # # # #

[EmptyMapD ((oldMapD MapDescriptor)(place (ONEOF DHandle NIL))
(RETURNS MapDescriptor))
(DPROG((desc (KrlCreate MapDescriptor
(if place then (SpaceName place (ConstantHandle))
else scratchSpace)))
(StoreMem desc focusSlot (FetchMem oldMapD focusSlot (ConstantHandle)))
(StoreMem desc prototype (FetchMem oldMapD prototype (ConstantHandle)))
(RETURN desc)]

# # # # # # # # # # # # # # #

[FocusTreeRelation ((mapD1 MapDescriptor) (mapD2 MapDescriptor)
(RETURNS (MEMQ ABOVE BELOW SAME CONFLICT NONE)))
(TreeRelation (FetchMem mapD1 FocusSlot (ConstantHandle))
(FetchMem mapD2 FocusSlot (ConstantHandle))]

# # # # # # # # # # # # # # #

[GetCategories ((handle DHandle)(RETURNS (LISTP OF SlotAnchor)))
(DPROG ((anchor NIL Anchor)
(categories NIL (LISTP of SlotAnchor) (* this returns a list of slot anchors, each of which has categories declared for it. These anchors will later be used in TreeCompares with other slot anchors))
(RETURN
(for descr descriptorOf handle
when (AND (EQ (TypeD descr) ’MapDescriptor)
(HasCategories
(anchor ← (FetchMem descr focusSlot (ConstantHandle)))))
do (OR (KMemb anchor categories)
(PUSH categories (CopyHandle anchor)))
finally (RETURN categories))]

# # # # # # # # # # # # # # #

[GetContingentDescription
((descriptor Descriptor
(SATISFIES (AND (EQ (KrlType descriptor) ’InterpretedMapD)
(EQ (TypeI descriptor) ’During))))
(RETURNS Anchor))
(* this gets the description field from a contingency. There is a more efficient way if things are canonical, so it should probably be rewritten.)
(for template fromHandle templateAnchors ofHandle descriptor
as instance fromHandle instanceAnchors ofHandle descriptor
when (EQH template \$Contingency.contingentDesc)
do (RETURN (CopyHandle instance))
finally (KHelp "wrong form for contingent description")]

# # # # # # # # # # # # # # #

[GetContingentWorld ((descriptor Descriptor
(SATISFIES (AND (EQ (KrlType descriptor) ’InterpretedMapD)
(EQ (TypeI descriptor) ’During))))
(contextWorld Anchor)
(RETURNS Anchor))
(* this gets the world field from a contingency. There is a more efficient way if things are canonical, so it should probably be rewritten.)
(* this needs to be fixed to use contextWorld)
(for template fromHandle templateAnchors ofHandle descriptor
as instance fromHandle instanceAnchors ofHandle descriptor
when (EQH template \$Contingency.worldDesc)
do (RETURN (CopyHandle instance))
finally (KHelp "wrong form for During")]

# # # # # # # # # # # # # # #

[GetFurtherSpecs ((slot SlotAnchor)(RETURNS LST))
(* Danny this needs fixing)
(HGetHash slot FSPARRAY]

# # # # # # # # # # # # # # #

[GetInstance ((inst (ONEOF Anchor MapDescriptor))(RETURNS Anchor))
(SELECTQ (KrlType inst)
(Anchor inst)
(MapDescriptor
(DPROG ((prototype (FetchMem inst prototype (ConstantHandle)) SlotAnchor))
(RETURN (for template fromField templateAnchors ofHandle inst
as instance fromField templateAnchors ofHandle inst
when (EQH template prototype)
do (RETURN inst)
(* I believe this doesn’t need copying, since a new one is created
each time the iteration is done)
finally (RETURN (HELP "should we CONS up an anchor with the inverted map descriptor??"]

# # # # # # # # # # # # # # #

[GetPost ((descriptor Descriptor (USEDIN signals))
(bindingType (MEMQ Post Hook Pointer Primary Descriptor NIL)
(USEDIN signals)
(RETURNS Arbitrary (* This function assumes descriptor is known to be a post descriptor. It checks its type against the bindingType if given, and returns the appropriate post item (e.g. a lisp pointer for Lisp type). If bindingType is NIL, then the post descriptor itself is returned, or NIL if it is not a post descriptor.)))
(OR bindingType (bindingType ← ’Descriptor))
(SELECTQ (TypeD descriptor)
(Coreference
(if (IsPrimaryCoreference descriptor)
then (SELECTQ bindingType
(Descriptor descriptor)
((Primary Post) (FetchMem descriptor coref))
((Pointer Hook) (MSignal WrongTypeForBinding))
(KHelp "illegal binding type" bindingType))
elseif bindingType then (KHelp "descriptor isn’t post descriptor" descr)))
(LispPointer
(SELECTQ bindingType
(Descriptor descriptor)
((Post Pointer) (LispContentsOf descriptor))
((Hook Primary) (MSignal WrongTypeForBinding))
(KHelp "illegal binding type" bindingType))
(KrlPointer
(SELECTQ bindingType
((Post Descriptor) descriptor)
(Hook (GetDirectPointer (FetchMem descriptor handle)))
((Pointer Primary) (MSignal WrongTypeForBinding))
(KHelp "illegal binding type" bindingType))
(if bindingType
then (KHelp "descriptor isn’t post descriptor" descriptor)
else NIL]

# # # # # # # # # # # # # # #

[CheckSimpleNot ((descriptor Descriptor)
(type LITATOM)
(patDesc Descriptor)
(goal Goal)
(RETURNS Irrelevant))
(DPROG((desc NIL Descriptor)(desiredType (TypeD patDesc) LITATOM))
(AND (EQ (OR type (TypeD descriptor)) ’InterpretedMapD)
(EQ (TypeI descriptor) ’Not)
(desc ← (HasSingleDescriptor descriptor))
(EQ (TypeD desc) desiredType)
(OR (SELECTQ desiredType
(MapDescriptor
(AND (HasNoSlots desc)(SameFocusSlot desc patDesc))
(Coreference (SameCoreference desc patDesc))
(LispPointer
(EQUAL (LispContentsOf desc)(LispContentesOf patDesc)))
(KrlPointer
(EQH (GetDirectPointer desc)(GetDirectPointer patDesc)))
T)
(GoalDone goal ’FAILED]

# # # # # # # # # # # # # # #

[GetSystemCategory ((descriptor Descriptor)(RETURNS SlotAnchor))
(* This function returns a self-slot-anchor which is a prototype for the object being pointed to by the descriptor, which must be a LispPointer or KrlPointer. It is based on the assumption that the units LispObject and KrlObject are defined, and have category definitions which will make them conflict with other objects (i.e. all domain objects). Eventually it could be extended to make use of the LISP and KRL type mechanisms, so that units such as Integer, List, Anchor, MapDescriptor, etc. could be defined, and a LispPointer to an Integer would return it as the category, which would then conflict with List, etc.)

(SELECTQ (TypeD descriptor)
(LispPointer \$LispObject.self)
(KrlPointer \$KrlObject.self)
(KHelp "System category not applicable for non-pointer descriptor" descriptor]

# # # # # # # # # # # # # # #

[GetTraps ((type TrapType)(anchor Anchor)(RETURNS LST))
(DPROG((meta (GetMetaDescription anchor) (ONEOF Anchor NIL)))
(if meta then (HELP "this needs defining. Are there specs?"))]

# # # # # # # # # # # # # # #

[GetTriggers ((type TriggerType)(slot SlotAnchor)(RETURNS LST))
(CDR(FASSOC type (HGetHash slot TRIGGERARRAY)]

# # # # # # # # # # # # # # #

[IntersectResults ((resultList (LISTP OF (LISTP OF Result)))
(RETURNS (LISTP OF Result)))
(if (NULL resultList) then NIL
elseif (NULL resultList::1) then resultList:1)
else (for result in resultList:1
join (for entry in (IntersectResults resultList::1)
when (CompatibleBindings result entry)
collect (MergeResult result entry)))]

# # # # # # # # # # # # # # #

[IsPostDescriptor ((descriptor Descriptor)(RETURNS (ONEOF Descriptor NIL)))
(SELECTQ (TypeD descr)
((KrlPointer LispPointer) descr)
(Coreference (AND (IsPrimaryCoreference descr) descr))
NIL))]

# # # # # # # # # # # # # # #

[KrlEqual ((obj1 ANY)(obj2 ANY)(RETURNS BOOL))
(* Henry should probably write an efficient version of this -- it also might be given a less suggestive name)
(AND (EQ (KrlType obj1)(KrlType obj2))
(SELECTQ (KrlType obj1)
((Anchor MapDescriptor InterpretedMapDescriptor
Set Sequence Reflexive) (EQH obj1 obj2))
(Coreference (SameCoreference obj1 obj2))
(KrlPointer (EQH (GetDirectPointer obj1)(GetDirectPointer obj2)))
(LispPointer (EQUAL (LispContentsOf obj1)(LispContentsOf obj2))
(LISTP (AND (KrlEqual obj1:1 obj2:1)(KrlEqual obj1::1 obj2::1))
(EQUAL obj1 obj2]

# # # # # # # # # # # # # # #

[MergeResult ((result1 Result) (result2 Result) (RETURNS Result))
(* assumes check has been made for compatible bindings)
(DPROG((bindings NIL (LISTP OF Binding))(actions NIL (LISTP OF Action)))

(bindings ← result1:bindings)
(for binding in result2:bindings
when (NOT(FASSOC binding:1 bindings))
do (PUSH bindings binding))

(RETURN(CREATE result
bindings ← bindings
actions ← <! result1:actions ! result2:actions>)]

# # # # # # # # # # # # # # #

[MSignal (NLAMBDA X
(* I need a macro which does this more efficiently but don’t want to look it up now)
(PROG ((signalValue (Signal X:1 matchTable)))
(RETURN
(EVAL
<’SELECTQ ’signalValue
! X::1
!’(((SKIP OK))
((STOP ABORT) (AlignCompleted ’ABORT))
(HELP "Unrecognized signal value")))>]

# # # # # # # # # # # # # # #

[MSignalC (MACRO X
(* I need a macro which does this more efficiently but don’t want to look it up now)
(* This assumes complete catcher -- last term is for default)
(PROG ((signalValue (Signal X:1 matchTable)))
(RETURN(EVAL <’SELECTQ ’signalValue ! X::1>]

# # # # # # # # # # # # # # #

[SameResult ((result1 Result) (result2 Result) (RETURNS BOOL))
(AND (EQ (LENGTH result1:bindings)(LENGTH result2:bindings))
(EQ (LENGTH result1:actions)(LENGTH result2:actions))
(for binding in result1:bindings
always (FASSOC binding:variable result2:bindings))
(CompatibleBindings result1 result2)
(for action in result1:actions
always (for act2 in result2:actions
thereis (KrlEqual action act2)))
T]

# # # # # # # # # # # # # # #

[SameSet ((list1 LST) (list2 LST) (RETURNS BOOL))
(AND (EQ (LENGTH list1)(LENGTH list2))
(for item in list1
always (for item2 in list2 thereis (KrlEqual item item2))]

# # # # # # # # # # # # # # #

[SameWorld ((world1 Anchor) (world2 Anchor) (RETURNS BOOL))
(* this is a temporary definition which users can modify - it only works if they descriptions
are identical (including all the same descriptors in the same order))
(KrlEqual world1 world2]

# # # # # # # # # # # # # # #

[ValueOf (variable bindingList)
(PROG(value)
(* uses the variable bindings freely if bindingList not given)
(OR (value ← (FASSOC variable (OR bindingList bindings)))
(KHelp NoValueForBinding))
(RETURN value]