mirror of https://github.com/lianthony/NT4.0
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
976 lines
30 KiB
976 lines
30 KiB
/*
|
|
|
|
OVERVIEW
|
|
|
|
There are several parts to the "facts" associated with a component.
|
|
Note that each fact begins with the identifying clause head
|
|
token, followed immediately by the symbolic name of the component
|
|
or product.
|
|
|
|
(devClass className parentClassName no)
|
|
|
|
'devClass' defines a component class name and the
|
|
parent class. If there is no parent class,
|
|
(i.e., the class is primitive to all others)
|
|
the token 'basic' is used. Each component
|
|
is a member of a class and is a class in
|
|
itself. In other words, new classes can
|
|
be derived from it.
|
|
|
|
A class name can be derived from more
|
|
than one parent class; in this case, bindings
|
|
can occur based upon either parent class.
|
|
|
|
The final token ("no" in this example) indicates
|
|
whether the class is a logical end-point; that is,
|
|
whether deeper searches should be made for bindings.
|
|
|
|
(devType productName productGenericType upperClass lowerClass)
|
|
|
|
'devType' defines a new component, and gives its generic
|
|
type, which must be one of 'adapter',
|
|
'driver' or 'service'. This is used to
|
|
categorize components and to provide explanatory
|
|
text in messages.
|
|
|
|
'upperClass' defines the class behavior
|
|
of the upper level of the device. 'lowerClass'
|
|
defines the behavior of the bottom of the
|
|
device.
|
|
|
|
(devIf productName
|
|
interfaceName
|
|
upperClass
|
|
"object name"
|
|
namingMethod)
|
|
|
|
'devIf' defines a secondary upper-level interface for a
|
|
component. 'productName' is the primary interface;
|
|
'interfaceName' is the name of the new interface;
|
|
'upperClass' is the class name of the upper later
|
|
of the new interface; "objectName" is the object
|
|
name to be used in binding strings. 'namingMethod'
|
|
is similar to the definition below for (devBind).
|
|
|
|
(devBind productName objectName
|
|
getsBindings
|
|
appearsInBindings
|
|
namingMethod)
|
|
|
|
'devBind' describes how this component's bindings
|
|
appear. If "getsBindings" is "yes", then
|
|
binding records are generated for it.
|
|
If "appearsInBindings" is "yes", then the
|
|
device's object name is concatenated onto
|
|
the binding string.
|
|
|
|
The string 'objectName' provides the name that
|
|
the product will create in the NT object
|
|
name space.
|
|
|
|
The token 'getsBindings' is either 'yes' or 'no'
|
|
and determines whether the device actually needs
|
|
(relies upon) generated bindings.
|
|
|
|
The token "appearsInBindings' is either 'yes'
|
|
or 'no'; if 'no' the name is elided from the
|
|
generated binding string.
|
|
|
|
The token 'namingMethod' is either 'simple',
|
|
'container', or 'streams'. If 'simple', the
|
|
names of the upper and lower products are
|
|
concatenated with an interposed underscore
|
|
(i.e., the name remains a single token); if
|
|
'container', the names are separated by a
|
|
backslash (i.e., the names are NT "container
|
|
objects"); if 'streams', the name of the upper
|
|
and lower objects are inverted in order.
|
|
|
|
|
|
|
|
(bindable fromClassName toClassName exclusive exclusive bindValue)
|
|
|
|
'bindable' specifies two class names, components of which
|
|
can be bound together. The first 'exclusive'
|
|
token indicates that the from item cannot
|
|
accept more than one binding; the second
|
|
'exclusive' indicates that the to class cannot
|
|
accept more than one binding.
|
|
|
|
The 'bindValue' variable
|
|
gives an indication of the relative worth
|
|
of this binding. It is used to discriminate
|
|
between multiple possible binding structures.
|
|
|
|
It is important to note that a 'bindable'
|
|
rule will apply to derived subclasses also.
|
|
If 'A' is a 'BASEA' and 'B' is a 'BASEB',
|
|
and there exists a rule allowing binding
|
|
of 'BASEAs' to 'BASEBs', the an 'A' can be
|
|
bound to a 'B'.
|
|
|
|
Multiple applicable binding rules are resolved
|
|
as follows. The rule with the highest 'binding
|
|
value' is used in preference to all others.
|
|
Then, the rule closest to the binder's
|
|
true class is used in preference to rules
|
|
based on parent classes. Finally, multiple
|
|
specific rules are order-dependent; the first
|
|
found is the one used.
|
|
|
|
(present productId productName "objectName" "Registry Location")
|
|
|
|
'present' specifies that a particular component is
|
|
present.
|
|
|
|
'productId' is the name of the product as taken
|
|
from its (devType) declaration. It is usually
|
|
the same as 'productName', except when multiple
|
|
products of the same type are present, in which
|
|
case NCPAFACT.CXX appends a unique digit to
|
|
'productId'.
|
|
|
|
'productName' is the name taken from the (devType)
|
|
declaration.
|
|
|
|
|
|
(block fromClassName toClassName)
|
|
|
|
prevent bindings between any components of the
|
|
named classes, regardless of separation. The
|
|
blocked binding removeal routine checks both the
|
|
"upper" class and the "lower" class of the
|
|
binder-bindee pair.
|
|
|
|
The order of the class names is significant,
|
|
however, since a block is only considered to occur
|
|
in the from->to direction.
|
|
|
|
USER EXTENSIONS
|
|
|
|
User extensions can be added through the use of the "RawRules"
|
|
value under the "NetRules" key. All information under in a
|
|
RawRules REG_MULTI_SZ are incorporated unchanged into the
|
|
consulted rule set.
|
|
|
|
Then, during the query "(makebindstrings)", the predictate
|
|
userExtensions/1 is called. IT MUST FAIL, and it should not
|
|
generate backtracking. The format is:
|
|
|
|
(userExtensions Phase)
|
|
|
|
where Phase is an atom describing the phase of operation the
|
|
algorithm is in. References to userExtensions/1 are of the form:
|
|
|
|
(not (userExtensions createbindings))
|
|
|
|
which is why all userExtensions/1 clauses MUST FAIL. The reason
|
|
for the negation is that they are not always present.
|
|
|
|
COLLAPSING TYPES
|
|
|
|
Facts of the form:
|
|
|
|
(collapsibleType RealTypeName DummyTypeName
|
|
DummyObjectName DummyRegistryKeyName)
|
|
|
|
are generated for each component type which is represented by
|
|
multiple instances. Then the individual (present) facts for
|
|
these components are retracted and replaced by a (dupType)
|
|
fact.
|
|
|
|
During the binding algorithm, only a single instance of each
|
|
unique component type is considered to exist. This causes the
|
|
bulk of the binding algorithm to be O(T**2), where T is the number
|
|
of unique types actually present.
|
|
|
|
After the binding algorithm, the (bindstring) facts for these
|
|
pseudo-types are exploded into the full complement of bindings
|
|
necessary based upon the (dupType) facts.
|
|
|
|
|
|
UNIMPLEMENTED FEATURES:
|
|
|
|
(height productName stackHeight bindHeight)
|
|
|
|
'height' specifies a component's preference in terms
|
|
of relative elevation in the protocol tower
|
|
('stackHeight') and relative height of
|
|
binding (height of target component).
|
|
|
|
IMPLEMENTATION:
|
|
|
|
Primary predicate is makebindstrings/1.
|
|
|
|
A first pass is done during which facts of the form:
|
|
|
|
(binding FromDevice ToDevice FromExclusive ToExclusive Value)
|
|
|
|
are asserted. See createbindings/1, assertbindings/1
|
|
and getbindings/1.
|
|
|
|
Then, exclusivity conflicts are pruned from the database
|
|
by pruneexclusive/1.
|
|
|
|
Then the binding strings and device atom path lists are asserted
|
|
by allbindstrings/1. The facts added to the database are of
|
|
the form:
|
|
|
|
(bindstring Owner Interface Objectname PathAtomList BindString ExportString)
|
|
|
|
These are then checked for blocked configurations. It's easier
|
|
to do this at this stage, since blocks constrain interconnections
|
|
across the entire path of a binding, not just at layer boundaries.
|
|
A block can occur based upon either the upper or lower class
|
|
of the upper or lower component.
|
|
|
|
The external interface does the following:
|
|
|
|
1) Consults this file
|
|
2) Consults the generated fact list from the Registry
|
|
3) Queries makebindstrings/1.
|
|
4) Queries the non-deterministic predicate bindstring/4
|
|
once for each device in the ensemble.
|
|
|
|
If the query engine is used more than once, it is entirely reset
|
|
between calls.
|
|
|
|
|
|
PROBLEMS TO BE RESOLVED:
|
|
|
|
0) Handle "Streams"-style bind string creation. That is,
|
|
if X->Y, generate the string as \Device\Y\X\<adapter>.
|
|
|
|
DONE: This is handled through the "streams" binding type,
|
|
which causes the binder<->bindee relationship to be inverted
|
|
in the binding string.
|
|
|
|
0) Handle logical end-points. Like an adapter, a logical
|
|
end-point (LEP) is as low in the protocol tower as a consuming
|
|
component is aware of. For example, if NBT is a LEP, the
|
|
workstation's bind string might say:
|
|
|
|
Bind = REG_MULTI_SZ \Device\Streams\Nbt
|
|
|
|
even though NBT itself has:
|
|
|
|
Bind = REG_MULTI_SZ \Device\Streams\Elnkii01 \
|
|
\Device\Streams\UB02 \
|
|
and so on.
|
|
|
|
One problem with LEPs is determining whether an end-point
|
|
other than a adapter is actually active.
|
|
|
|
DONE: This is handled through the final parameter in the
|
|
(devClass) rule. If "yes", the class is considered a
|
|
logical end point.
|
|
|
|
|
|
0) Handle class incompatibilities deeper than a one-to-one
|
|
basis. This is for RAS, where LanmanWorkstation, for
|
|
example, should not use RasHub at all.
|
|
|
|
0) Handle "read-only" bindings. Maybe this should be done
|
|
inside the NCPA?
|
|
|
|
|
|
1) Establish definitions in the rule set for devices which
|
|
do not appear in a bindable object string. For example, the
|
|
driver "elnkiiSys" in the examples should (I think) not
|
|
appear in the binding strings. DONE: This is flagged via
|
|
the "devBind" fact.
|
|
|
|
2) Establish a definition in the rule set for devices which
|
|
are not to receive binding strings. DONE: This is flagged via
|
|
the "devBind" fact.
|
|
|
|
3) Handle unique naming of multiple identical hardware
|
|
components.
|
|
|
|
4) How to handle singly-bound components. For example,
|
|
the UB monolithic stack can bind to exactly one instance
|
|
of a UB card. In doing so, it blocks all other usage
|
|
of the UB card by other components. SOLUTION: an
|
|
exclusivity flag in the 'bindable' rule. Is 'bindable'
|
|
the proper locus, or is exclusivity a component property?
|
|
This solution assumes that the "exclusive" property is
|
|
a property only of the bind target, not the bind source.
|
|
|
|
5) How to handle components which could bind to each other
|
|
or to lower level components. For example, A and B can
|
|
bind to C or each other, so the structure could be
|
|
(A->B, B->C) or (B->A, A->C) or (A->C, B->C). SOLUTION:
|
|
Two 'preference' valences associated with a component. The
|
|
first is the product's 'height', treated as a relative number
|
|
indicating the component's stance in the protocol tower. The
|
|
second is the product's 'bind height', treated as an indication
|
|
of the product level to which the component prefers to bind.
|
|
In the example below, the 'height' rule's elements are:
|
|
|
|
(height componentName height bindHeight)
|
|
|
|
Thus, to force a particular configuration, different weights
|
|
are used:
|
|
|
|
(A->B, B->C)
|
|
|
|
(height A 50 0) note: bindheight is not relevant
|
|
(height B 40 0)
|
|
(height C 30 0)
|
|
|
|
(B->A, A->C)
|
|
|
|
(height A 40 0) note: bindheight is not relevant
|
|
(height B 50 0)
|
|
(height C 30 0)
|
|
|
|
(A->C, B->C)
|
|
|
|
(height A 50 30)
|
|
(height B 40 30)
|
|
(height C 30 0)
|
|
|
|
In the last example, the possible binding (A->B) is rejected
|
|
in favor of (A->C) because C's height is closer to A's desired
|
|
bind height. The same occurs with (B->A), rejected in favor
|
|
of (B->C).
|
|
|
|
3) How to pass created object names through the hierarchy so
|
|
that a component gets NT device names recorded in the Registry.
|
|
|
|
4) How to 'value' bindings so that products can cause 'smarter'
|
|
configurations to emerge. SOLUTION: a 'value' valence in
|
|
the 'bindings' rule. Competitive bindings of lower valence are
|
|
always rejected in favor of higher ones.
|
|
|
|
*/
|
|
|
|
/* RULE predicates */
|
|
|
|
/* Determine if a device class is a sub-class of another */
|
|
/* (devDerived SubClass BaseClass) */
|
|
|
|
( (devDerived X basic)
|
|
(cut)
|
|
)
|
|
|
|
( (devDerived X X)
|
|
(cut)
|
|
)
|
|
( (devDerived X Y)
|
|
(devClass X Y _)
|
|
(cut)
|
|
)
|
|
|
|
( (devDerived X Y)
|
|
(devClass X Z _)
|
|
(cut)
|
|
(devDerived Z Y)
|
|
)
|
|
|
|
//
|
|
// Interface routines: hide the distinction between a "devType"
|
|
// (normal component) and a "devIf" (secondary interface).
|
|
//
|
|
|
|
// ifupper/2: return the classname of a device's upper interface
|
|
// (ifupper Devname Classname)
|
|
( (ifupper Ifname Ifclass)
|
|
(devType Ifname _ Ifclass _)
|
|
)
|
|
( (ifupper Ifname Ifclass)
|
|
(devIf _ Ifname Ifclass _ _)
|
|
)
|
|
|
|
// iflower/2: return the classname of a device's lower interface
|
|
// (iflower Devname Classname)
|
|
( (iflower Ifname Ifclass)
|
|
(devType Ifname Usage _ Ifclass)
|
|
(not (eq Usage adapter)) // Adapters cannot connect to anything
|
|
)
|
|
|
|
// ifpresent/5: validate the presence of an interface
|
|
// devTypes have upper and lower interface; devIfs only
|
|
// have an upper interface.
|
|
// (ifpresent Layer Device Type Owner Objectname)
|
|
( (ifpresent _ Dev Type Type Objname)
|
|
(present Dev Type Objname _)
|
|
)
|
|
( (ifpresent upper Dev Dev Owner Objname)
|
|
(devIf Owner Dev _ Objname _)
|
|
(present Owner _ _ _)
|
|
)
|
|
|
|
( (ifbind Dev Method)
|
|
(devBind Dev _ _ _ Method)
|
|
)
|
|
( (ifbind Dev Method)
|
|
(devIf _ Dev _ _ Method)
|
|
)
|
|
|
|
|
|
( (ifusage Kind Usage)
|
|
(devType Kind Usage _ _)
|
|
)
|
|
( (ifusage Kind Usage)
|
|
(devIf Owner Kind _ _ _)
|
|
(devType Owner Usage _ _)
|
|
)
|
|
|
|
/* Succeed if a common "bindable" rule is inherited by the lower
|
|
layer of X and the upper layer of Y.
|
|
*/
|
|
|
|
( (canbind X Y Xexcl Yexcl Value)
|
|
(iflower X Lower)
|
|
(ifupper Y Upper)
|
|
(printif (nl "Try: " X " binding to " Y))
|
|
(bindable Blower Bupper Xexcl Yexcl Value)
|
|
(printif (nl "Bind (L): is " Lower " derived from " Blower))
|
|
(devDerived Lower Blower)
|
|
(printif (nl "Bind (U): is " Upper " derived from " Bupper))
|
|
(devDerived Upper Bupper)
|
|
(printif ("<- Success!"))
|
|
)
|
|
|
|
/* Succeed once for each bindable pair: lower -> upper */
|
|
|
|
( (bindpair Dev1 Dev2 (Dev1 Dev2 Excl1 Excl2 Value))
|
|
(ifpresent lower Dev1 Type1 _ _)
|
|
(ifpresent upper Dev2 Type2 _ _)
|
|
(not (eq Dev1 Dev2))
|
|
(canbind Type1 Type2 Excl1 Excl2 Value)
|
|
(printif (nl))
|
|
)
|
|
|
|
/* Return a list of ordered pairs of bindable components */
|
|
|
|
( (getbindings List)
|
|
(findall L (bindpair X Y L) List)
|
|
)
|
|
|
|
|
|
/* Assert the bindings as individual facts of the form:
|
|
(binding From To ExclFrom ExclTo Value)
|
|
*/
|
|
|
|
( (retractbindings)
|
|
(retract (binding _ _ _ _ _))
|
|
(fail)
|
|
)
|
|
|
|
( (assertbindings L)
|
|
(not (retractbindings))
|
|
(getbindings L)
|
|
(bindassert L)
|
|
)
|
|
( (bindassert () )
|
|
)
|
|
/* BUGBUG: allow only one binding from/to any two components
|
|
( (bindassert ((Bindfrom Bindto Exclfrom Exclto Value)|T) )
|
|
(binding Bindfrom Bindto _ _ _)
|
|
(cut)
|
|
(bindassert T)
|
|
)
|
|
*/
|
|
( (bindassert ((Bindfrom Bindto Exclfrom Exclto Value)|T) )
|
|
(assertz (binding Bindfrom Bindto Exclfrom Exclto Value))
|
|
(bindassert T)
|
|
)
|
|
|
|
( (createbindings)
|
|
(assertbindings L)
|
|
)
|
|
|
|
//
|
|
// makebindstrings/0: THIS IS THE PRIMARY PREDICATE CALLED BY THE NCPA
|
|
//
|
|
( (makebindstrings)
|
|
/* Debug: for verbose debugger output, uncomment the next two lines */
|
|
//#if defined(SPTRACE)
|
|
// (pctl on)
|
|
// (statctl on)
|
|
//#endif
|
|
|
|
// Reduce collapsible types to a single pseudo-instance.
|
|
(collapseDuplicateTypes)
|
|
|
|
// Create all the binding information
|
|
(not (userExtensions createbindings))
|
|
(createbindings)
|
|
|
|
// Prune disallowed bindings from the database
|
|
(not (userExtensions pruneexclusive))
|
|
(prunexclusive)
|
|
|
|
// Generate the binding strings, (bindstring ...)
|
|
(not (userExtensions allbindstrings))
|
|
(allbindstrings)
|
|
|
|
// Explode pseudo-instance bindings back into real types
|
|
(explodeDuplicateTypes)
|
|
|
|
(not (userExtensions endofquery))
|
|
(tracestat)
|
|
)
|
|
|
|
//
|
|
// Collapse and Expand predicates (see Notes above).
|
|
//
|
|
|
|
// Failure-driven outer predicate
|
|
( (collapseDuplicateTypes)
|
|
(not (determineCollapsibleTypes))
|
|
)
|
|
|
|
// Backtrack through all matched pairs of (present) facts.
|
|
// Any component types which have multiple instances cause
|
|
// a (collapsibleType) fact to be asserted.
|
|
( (determineCollapsibleTypes)
|
|
|
|
// Find unique multiple instances of the same component type
|
|
// not already covered by a (collapsibleType) record.
|
|
(present ProductId Typename Objectname Registrykey)
|
|
(present ProductId2 Typename Objectname2 Registrykey2)
|
|
(not (eq ProductId ProductId2))
|
|
(not (collapsibleType Typename _ _ _))
|
|
|
|
// Create tokens for the dummy replacement (present) fact.
|
|
(string_from Typename StrTypename)
|
|
(string_concat StrTypename "Dummy" StrDummyTypename)
|
|
(atom_from StrDummyTypename DummyTypename)
|
|
(string_from Objectname StrObjname)
|
|
(string_concat StrObjname "_DummyObjName" DummyObjectName)
|
|
(string_concat "Dummy_Reg_Key_for_" StrObjname DummyRegKey)
|
|
|
|
// Assert a (collapsibleType) record for the type
|
|
(assertz (collapsibleType Typename DummyTypename DummyObjectName DummyRegKey))
|
|
|
|
// Replace all (present) facts for this type with (dupType) facts
|
|
(not (collapseDupType Typename DummyTypename))
|
|
|
|
// Assert the (present) fact for the dummy single-instance type
|
|
(assertz (present DummyTypename Typename DummyObjectName DummyRegKey))
|
|
(fail)
|
|
)
|
|
|
|
// Replace each (present) fact for a collapsible type with a (dupType) fact.
|
|
( (collapseDupType Typename PseudoTypeName)
|
|
(present ProductId Typename Objectname Registrykey)
|
|
(assertz (dupType PseudoTypeName ProductId Typename Objectname Registrykey))
|
|
(retract (present ProductId Typename Objectname Registrykey))
|
|
(fail)
|
|
)
|
|
|
|
// Failure-driven outer predicate
|
|
( (explodeDuplicateTypes)
|
|
(not (explodeEachType))
|
|
)
|
|
// For each collapsible type, explode the pseudo-instance into multple instances.
|
|
( (explodeEachType)
|
|
(collapsibleType RealTypeName DummyTypeName DummyObjectName DummyRegistryKeyName)
|
|
(explodeDup DummyTypeName DummyObjectName)
|
|
)
|
|
|
|
// For each (bindstring) fact referencing a pseudo-type, retract that fact and
|
|
// explode it into multiple instances with the real type information.
|
|
( (explodeDup Typename Textname)
|
|
(bindstring Owner Interface Objectname PathAtomList BindString ExportString)
|
|
(member Typename PathAtomList)
|
|
(retract (bindstring Owner Interface Objectname PathAtomList BindString ExportString))
|
|
(not (assertOnePer Typename Textname Owner Interface Objectname PathAtomList BindString ExportString))
|
|
(fail)
|
|
)
|
|
|
|
// Using the tokens from a (bindstring) fact, create a (bindstring) fact referencing
|
|
// the real type information.
|
|
( (assertOnePer Typename Textname Owner Interface Objectname PathAtomList BindString ExportString)
|
|
(dupType Typename ProductId RealType Objname Registrykey)
|
|
(list_subst Typename PathAtomList ProductId NewAtomList)
|
|
(string_subst Textname BindString Objname NewBindString)
|
|
(string_subst Textname ExportString Objname NewExportString)
|
|
(assertz (bindstring Owner Interface Objectname NewAtomList NewBindString NewExportString))
|
|
(fail)
|
|
)
|
|
|
|
/* Prune the bindings facts of exclusion conflicts. */
|
|
|
|
( (prunexclusive)
|
|
(not(pruneupper))
|
|
(not(prunelower))
|
|
)
|
|
( (pruneupper)
|
|
(binding From To exclusive _ Value)
|
|
(binding From To2 Excl2 _ Value2)
|
|
(not (eq To To2))
|
|
(printif (nl "Contention (U): " To "<->" To2 nl))
|
|
(pruneup From To To Value Value2)
|
|
(fail)
|
|
)
|
|
( (prunelower)
|
|
(binding From To _ exclusive Value)
|
|
(binding From2 To _ Excl2 Value2)
|
|
(not (eq From From2))
|
|
(printif (nl "Contention (L): " From "<->" From2 nl))
|
|
(prunelow From From2 To Value Value2)
|
|
(fail)
|
|
)
|
|
( (pruneup From To To2 Value Value2)
|
|
(iless Value2 Value)
|
|
(cut)
|
|
(printif (nl "Retracted: " From "->" To2 nl))
|
|
(retract (binding From To2 _ _ _))
|
|
)
|
|
( (pruneup From _ To _ _)
|
|
(printif (nl "Retracted: " From "->" To nl))
|
|
(retract (binding From To _ _ _))
|
|
)
|
|
( (prunelow _ From To Value Value2)
|
|
(iless Value2 Value)
|
|
(cut)
|
|
(printif (nl "Retracted: " From "->" To nl))
|
|
(retract (binding From To _ _ _))
|
|
)
|
|
( (prunelow From _ To _ _)
|
|
(printif (nl "Retracted: " From "->" To nl))
|
|
(retract (binding From To _ _ _))
|
|
)
|
|
|
|
/* Success-through-exhausted-failure driver predicate */
|
|
( (pruneblocked)
|
|
(printif (nl "Blocked checking begun..." nl))
|
|
(not (pruneblock))
|
|
(printif (nl "Blocked checking ended." nl))
|
|
)
|
|
|
|
/* Iterate over the bindstring facts, retracting any
|
|
which are blocked */
|
|
( (pruneblock)
|
|
(bindstring Owner Name Objname Devlist Bstr Estr)
|
|
(isblocked (Name|Devlist))
|
|
(printall (nl "Blocked: " Name " = " Bstr nl))
|
|
(retract (bindstring Owner Name Objname Devlist Bstr Estr))
|
|
(fail)
|
|
)
|
|
|
|
/* Handle the factorial list checking */
|
|
|
|
/* Termination condition: it's not blocked. */
|
|
( (isblocked (Dev))
|
|
(atom Dev)
|
|
(cut)
|
|
(fail)
|
|
)
|
|
|
|
/* Check the top pair. */
|
|
( (isblocked (Dev Nextdev|Rest))
|
|
(isblockedpair Dev Nextdev)
|
|
(cut) /* Success: this pair is illegal */
|
|
)
|
|
|
|
/* Recurse using head atom and rest of list. */
|
|
( (isblocked (Dev Nextdev|Rest))
|
|
(isblocked (Dev|Rest))
|
|
(printif (nl "Blocked pair: " Dev " and " Nextdev nl))
|
|
(cut)
|
|
)
|
|
|
|
/* Recurse, removing head atom */
|
|
( (isblocked (Dev Nextdev|Rest))
|
|
(isblocked (Nextdev|Rest))
|
|
)
|
|
|
|
/* Check a single blocked pair */
|
|
|
|
( (isblockedpair Dev1 Dev2)
|
|
(block Lowclass Upclass)
|
|
(ifpresent lower Dev1 Type1 _ _)
|
|
(ifpresent upper Dev2 Type2 _ _)
|
|
(iflower Type1 Lower)
|
|
(ifupper Type2 Upper)
|
|
(devDerived Lower Lowclass)
|
|
(devDerived Upper Upclass)
|
|
(cut)
|
|
)
|
|
|
|
/* Find all connections between a module and the adapters.
|
|
The format of the list created by "allbinds" is recursive,
|
|
defined as:
|
|
|
|
(Device ListOfBoundDevices)
|
|
|
|
Each element of "ListOfBoundDevices" has the same format
|
|
as the outer list.
|
|
|
|
"getbindstrings" returns a list, each of whose elements is
|
|
a list of two items. The first item is a list of devices
|
|
traversed to get to the adapter, the second item is a string
|
|
representing the NT device name of the entire binding.
|
|
|
|
*/
|
|
|
|
( (allbindstrings)
|
|
(not (allbindstrhelp))
|
|
)
|
|
|
|
( (allbindstrhelp)
|
|
(ifpresent _ Name _ _ _)
|
|
(assertbindstrings Name)
|
|
(fail)
|
|
)
|
|
|
|
( (assertbindstrings Name)
|
|
(not (retractbindstrs Name))
|
|
(getbinddevlists Name List)
|
|
(printif (nl "asserting binding for: " Name "..."))
|
|
(bindstrassert Name List)
|
|
(printif ("done" nl))
|
|
)
|
|
|
|
( (retractbindstrs Name)
|
|
(retract (bindstring _ Name _ _ _ _))
|
|
(fail)
|
|
)
|
|
|
|
( (getbinddevlists Name Strlist)
|
|
(allbinds Name Name (Name Bindlist))
|
|
(bindflatten () Bindlist () Strlist)
|
|
)
|
|
|
|
/* Succeed if Name is an end-point */
|
|
( (isendpoint Name)
|
|
(ifpresent upper Name _ _ _)
|
|
(ifupper Name Upperclass)
|
|
(devClass Upperclass _ yes)
|
|
)
|
|
/* Succeed if Name is a stream provider */
|
|
( (isstream Name)
|
|
(ifpresent _ Name Type _ _)
|
|
(ifbind Type streams)
|
|
)
|
|
|
|
/* Cases in "end point" handling:
|
|
* 1) An "adapter" is reached. Dead end, so stop.
|
|
* 2) An "end point" is reached. Check to see if the
|
|
* next device is marked as "streams"; if so,
|
|
* include it in the nested list and stop.
|
|
* 3) An "end point" is reached. Terminate as with
|
|
* an adapter.
|
|
*/
|
|
|
|
/* End point handling: next device is an adapter */
|
|
( (allbinds _ Name (Name))
|
|
(ifpresent _ Name Kind _ _)
|
|
(ifusage Kind adapter)
|
|
(cut)
|
|
)
|
|
|
|
/* End point handling: is next device is marked as "endpoint"? */
|
|
/* See if it connects to an underlying Stream. "Basename" */
|
|
/* refers to the device for which this query is being performed. */
|
|
/* This is important, since "endpoint" devices appear as one */
|
|
/* object to consumers but may have multiple internal bindings. */
|
|
|
|
( (allbinds Basename Name (Name|((Stream))))
|
|
(not (eq Basename Name))
|
|
(isendpoint Name)
|
|
(ifpresent _ Name _ Owner _)
|
|
(binding Owner Stream _ _ _)
|
|
(cut)
|
|
)
|
|
|
|
/* End point handling: next device is marked as "endpoint" */
|
|
/* It's a true terminator (i.e., not "streams"-based. */
|
|
|
|
( (allbinds Basename Name (Name))
|
|
(not (eq Basename Name))
|
|
(isendpoint Name)
|
|
(cut)
|
|
)
|
|
|
|
/* Not a terminator. Continue recursing with this name. */
|
|
|
|
( (allbinds Basename Name (Name Outlist))
|
|
(ifpresent _ Name _ Owner _)
|
|
(findall To (binding Owner To _ _ _) Tolist)
|
|
(allbindlist Basename Owner Tolist Outlist)
|
|
)
|
|
|
|
( (allbindlist _ _ () ()) )
|
|
( (allbindlist Basename Name (Hto|Tto) (Hout|Tout))
|
|
(allbinds Basename Hto Hout)
|
|
(allbindlist Basename Hto Tto Tout)
|
|
)
|
|
|
|
/* Convert list of devices to list of interface owners */
|
|
|
|
( (ownerlist () L L) )
|
|
( (ownerlist (Dev|T) L Lout)
|
|
(devIf Owner Dev _ _ _)
|
|
(cut)
|
|
(append L (Owner) L2)
|
|
(ownerlist T L2 Lout)
|
|
)
|
|
( (ownerlist (Dev|T) L Lout)
|
|
(append L (Dev) L2)
|
|
(ownerlist T L2 Lout)
|
|
)
|
|
|
|
( (dobindstrassert Owner Name Objname Devlist Fullbindstr Fullexportstr)
|
|
(ownerlist Devlist () Ownerlist)
|
|
(not (isblocked (Name|Ownerlist)))
|
|
(printif (nl "Asserting bindstring: " Name " = " Fullbindstr ","
|
|
nl " export = " Fullexportstr nl))
|
|
(assertz (bindstring Owner Name Objname Ownerlist Fullbindstr Fullexportstr))
|
|
(cut)
|
|
)
|
|
|
|
( (dobindstrassert _ _ _ _ _ _)
|
|
)
|
|
|
|
/* Assert all the (bindstring ..) results */
|
|
|
|
( (bindstrassert Name (Devlist|T))
|
|
(makedevstring import Devlist "" Bindstr)
|
|
(makedevstring export (Name|Devlist) "" Exportstr)
|
|
(string_concat "\Device\" Bindstr Fullbindstr)
|
|
(string_concat "\Device\" Exportstr Fullexportstr)
|
|
(ifpresent _ Name _ Owner Objname)
|
|
(dobindstrassert Owner Name Objname Devlist Fullbindstr Fullexportstr)
|
|
(bindstrassert Name T)
|
|
)
|
|
|
|
/* Create the "Bind" string corresponding to a binding */
|
|
|
|
( (makedevstring _ () Bindstr Bindstr)
|
|
(cut) /* Termination condition: empty dev list */
|
|
)
|
|
|
|
/* If naming method is "bare", just stop now */
|
|
( (makedevstring _ (Dev|Tail) Oldstr Newstr)
|
|
(ifpresent _ Dev _ _ Objectname)
|
|
(ifbind Dev bare)
|
|
(cut)
|
|
(string_concat Oldstr Objectname Newstr)
|
|
)
|
|
|
|
/* If name does not appear in bindings, suppress it */
|
|
|
|
( (makedevstring _ (Dev|Tail) Oldstr Newstr)
|
|
(ifpresent _ Dev Devtype _ _)
|
|
(devBind Devtype _ _ no _)
|
|
(cut)
|
|
(makedevstring _ Tail Oldstr Newstr)
|
|
)
|
|
/* If we're at the end of the list, just append the name */
|
|
( (makedevstring _ (Dev) Oldstr Newstr)
|
|
(atom Dev)
|
|
(cut)
|
|
(ifpresent _ Dev _ _ Objectname)
|
|
(cut)
|
|
(string_concat Oldstr Objectname Newstr)
|
|
)
|
|
|
|
/* Special handling for streams-based exports: List only */
|
|
/* \Device\Streams\Provider in the export string */
|
|
|
|
( (makedevstring export (Dev Devnext|Tail) Oldstr Newstr)
|
|
(isendpoint Dev)
|
|
(isstream Devnext)
|
|
(cut)
|
|
(makedevstring _ (Devnext Dev) Oldstr Newstr)
|
|
)
|
|
|
|
/* If we have at least two atoms, check for "streams"-style naming */
|
|
( (makedevstring _ (Dev Devnext|Tail) Oldstr Newstr)
|
|
(isstream Devnext)
|
|
(cut)
|
|
(makedevstring _ (Devnext Dev|Tail) Oldstr Newstr)
|
|
)
|
|
/* Normal case: just get the separator and concatenate */
|
|
( (makedevstring _ (Dev|Tail) Oldstr Newstr)
|
|
(ifpresent _ Dev Devtype _ Objectname)
|
|
(cut)
|
|
(ifbind Devtype Method)
|
|
(getsep Method Sep)
|
|
(cut)
|
|
(string_concat Oldstr Objectname T1)
|
|
(string_concat T1 Sep T2)
|
|
(makedevstring _ Tail T2 Newstr)
|
|
)
|
|
|
|
( (getsep simple "_")
|
|
(cut)
|
|
)
|
|
( (getsep _ "\") )
|
|
|
|
/* Flatten a nested list of bound devices */
|
|
|
|
( (bindflatten _ () List List) ) /* Termination condition */
|
|
|
|
( (bindflatten Devlist (Dev|List) Inlist Outlist)
|
|
(atom Dev) /* Start of a new list */
|
|
(cut)
|
|
(append Devlist (Dev) Devnew)
|
|
(bindflatten Devnew List Inlist Outlist)
|
|
)
|
|
( (bindflatten Devlist ((Dev)|T) Inlist Outlist)
|
|
(atom Dev)
|
|
(cut)
|
|
(append Devlist (Dev) Devnew)
|
|
(bindflatten Devlist T (Devnew|Inlist) Outlist)
|
|
)
|
|
( (bindflatten Devlist (H|T) Inlist Outlist)
|
|
(bindflatten Devlist H Inlist List1)
|
|
(bindflatten Devlist T List1 Outlist)
|
|
)
|
|
|
|
/* Create a simple (From To) list of bindings */
|
|
|
|
( (makebindlist List)
|
|
(findall (From To) (binding From To _ _ _) List)
|
|
)
|
|
|
|
/* Substitute one token in a string with another */
|
|
/* (string_subst OldToken OldString NewToken NewString) */
|
|
|
|
( (string_subst Tok Str Newtok Newstr)
|
|
(substr Tok Str)
|
|
(string_break Tok Str Left Right)
|
|
(string_concat Left Newtok Str1)
|
|
(string_concat Str1 Right Newstr)
|
|
(cut)
|
|
)
|
|
|
|
( (string_subst Tok Str _ Str)
|
|
)
|
|
|
|
/* Substitute one token in a list with another */
|
|
/* (list_subst OldToken OldList NewToken NewList) */
|
|
|
|
( (list_subst _ () _ ())
|
|
(cut)
|
|
)
|
|
( (list_subst Tok (Tok|T) Newtok (Newtok|LT))
|
|
(cut)
|
|
(list_subst Tok T Newtok LT)
|
|
)
|
|
( (list_subst Tok (H|T) Newtok (H|LT))
|
|
(list_subst Tok T Newtok LT)
|
|
)
|
|
|
|
|
|
/* (substr Substring String ): succeed if it's a substring */
|
|
|
|
( (substr Sub Str)
|
|
// Warning: the following is not good Prolog, but the
|
|
// built-in predicate string_break/4 expects
|
|
// the last two arguments to be variables.
|
|
(string_break Sub Str Left Right)
|
|
(not (eq Str Left))
|
|
)
|
|
|
|
//#include "default.spr"
|
|
|
|
/* end of NCPARULE.SPR */
|
|
|