diff options
Diffstat (limited to 'src/interp/interop.boot')
| -rw-r--r-- | src/interp/interop.boot | 669 |
1 files changed, 0 insertions, 669 deletions
diff --git a/src/interp/interop.boot b/src/interp/interop.boot deleted file mode 100644 index c9c0f67d..00000000 --- a/src/interp/interop.boot +++ /dev/null @@ -1,669 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, Gabriel Dos Reis. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical Algorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import c_-util -import hashcode -namespace BOOT - --- note domainObjects are now (dispatchVector hashCode . domainVector) --- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr), --- pre oldAxiomCategory is (dispatchVector . (cat form)) --- oldAxiomCategory objects are (dispatchVector . ( (cat form) hash defaultpack parentlist)) - -hashCode? x == integer? x - -$domainTypeTokens == ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory, - 'oldAxiomCategory, 0] - --- The name game. --- The compiler produces names that are of the form: --- a) cons(0, <string>) --- b) cons(1, type-name, arg-names...) --- c) cons(2, arg-names...) --- d) cons(3, value) --- NB: (c) is for tuple-ish constructors, --- and (d) is for dependent types. - -DNameStringID == 0 -DNameApplyID == 1 -DNameTupleID == 2 -DNameOtherID == 3 - -DNameToSExpr1 dname == - null dname => error "unexpected domain name" - first dname = DNameStringID => - makeSymbol(CompStrToString rest dname) - name0 := DNameToSExpr1 second dname - args := rest rest dname - name0 is '_-_> => - froms := first args - froms := [DNameToSExpr x for x in rest froms] - ret := second args -- a tuple - ret := DNameToSExpr second ret -- contents - ['Mapping,:[ret,:froms]] - name0 is 'Union or name0 is 'Record => - sxs := [DNameToSExpr x for x in rest first args] - [name0,:sxs] - name0 is 'Enumeration => - [name0,:[DNameFixEnum x for x in rest first args]] - [name0,:[DNameToSExpr x for x in args]] - -DNameToSExpr dname == - first dname = DNameOtherID => - rest dname - sx := DNameToSExpr1 dname - cons? sx => sx - [sx] - -DNameFixEnum arg == CompStrToString rest arg - -SExprToDName(sexpr, cosigVal) == - -- is it a non-type valued object? - not cosigVal => [DNameOtherID, :sexpr] - if first sexpr is '_: then sexpr := third sexpr - first sexpr is 'Mapping => - args := [ SExprToDName(sx,true) for sx in rest sexpr] - [DNameApplyID, - [DNameStringID,: StringToCompStr '"->"], - [DNameTupleID, : rest args], - [DNameTupleID, first args]] - name0 := [DNameStringID, : StringToCompStr symbolName first sexpr] - first sexpr is 'Union or first sexpr is 'Record => - [DNameApplyID, name0, - [DNameTupleID,: [ SExprToDName(sx,true) for sx in rest sexpr]]] - newCosig := rest getDualSignatureFromDB first sexpr - [DNameApplyID, name0, - :[SExprToDName(x,f) for x in rest sexpr for f in newCosig]] - --- local garbage because Compiler strings are null terminated -StringToCompStr(str) == - strconc(str, charString abstractChar 0) - -CompStrToString(str) == - subString(str, 0, #str - 1) --- local garbage ends - -runOldAxiomFunctor(:allArgs) == - [:args,env] := allArgs - getConstructorKindFromDB env is "category" => - [$oldAxiomPreCategoryDispatch,: [env, :args]] - dom:=apply(env, args) - makeOldAxiomDispatchDomain dom - -makeLazyOldAxiomDispatchDomain domform == - attribute? domform => - [$attributeDispatch, domform, hashString(symbolName domform)] - getConstructorKindFromDB opOf domform is "category" => - [$oldAxiomPreCategoryDispatch,: domform] - dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] - append!(dd,dd) -- installs back pointer to head of domain. - dd - -makeOldAxiomDispatchDomain dom == - cons? dom => dom - [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom] - -closeOldAxiomFunctor(name) == - [function runOldAxiomFunctor,:symbolFunction name] - -lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) == - dom := instantiate domenv - SPADCALL(rest dom, self, op, sig, box, skipdefaults, first dom.3) - -lazyOldAxiomDomainHashCode(domenv, env) == first domenv - -lazyOldAxiomDomainDevaluate(domenv, env) == - dom := instantiate domenv - SPADCALL(rest dom, first dom.1) - -lazyOldAxiomAddChild(domenv, kid, env) == - [$lazyOldAxiomDomainDispatch,:domenv] - -$lazyOldAxiomDomainDispatch := - VECTOR('lazyOldAxiomDomain, - [function lazyOldAxiomDomainDevaluate], - [nil], - [function lazyOldAxiomDomainLookupExport], - [function lazyOldAxiomDomainHashCode], - [function lazyOldAxiomAddChild]) - --- old Axiom pre category objects are just (dispatch . catform) --- where catform is ('categoryname,: evaluated args) --- old Axiom category objects are (dispatch . [catform, hashcode, defaulting package, parent vector, dom]) -oldAxiomPreCategoryBuild(catform, dom, env) == - pack := oldAxiomCategoryDefaultPackage(catform, dom) - [$oldAxiomCategoryDispatch, - :[catform, hashTypeForm(catform,0), pack, oldAxiomPreCategoryParents(catform,dom), dom]] -oldAxiomPreCategoryHashCode(catform, env) == hashTypeForm(catform,0) -oldAxiomCategoryDefaultPackage(catform, dom) == - hasDefaultPackage opOf catform - -oldAxiomPreCategoryDevaluate([op,:args], env) == - SExprToDName([op,:devaluateList args], true) - -$oldAxiomPreCategoryDispatch := - VECTOR('oldAxiomPreCategory, - [function oldAxiomPreCategoryDevaluate], - [nil], - [nil], - [function oldAxiomPreCategoryHashCode], - [function oldAxiomPreCategoryBuild], - [nil]) - -oldAxiomCategoryDevaluate([[op,:args],:.], env) == - SExprToDName([op,:devaluateList args], true) - -oldAxiomPreCategoryParents(catform,dom) == - vars := ["$",:rest getConstructorFormFromDB opOf catform] - vals := [dom,:rest catform] - -- parents := getConstructorParentsFromDB opOf catform - parents := parentsOf opOf catform - PROGV(vars, vals, - vector - [eval quoteCatOp cat for [cat,:pred] in parents | eval pred]) - -quoteCatOp cat == - cat isnt [.,:.] => MKQ cat - ['LIST, MKQ first cat,: rest cat] - - -oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) == - [catform,hash, pack,:.] := catenv - opIsHasCat op => if scalarEq?(sig, hash) then [self] else nil - null(pack) => nil - if not vector? pack then - pack:=apply(pack, [self, :rest catform]) - catenv.rest.rest.first := pack - fun := basicLookup(op, sig, pack, self) => [fun] - nil - -oldAxiomCategoryParentCount([.,.,.,parents,.], env) == # parents -oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) == - catform := parvec.(n-1) - VECTORP KAR catform => catform - newcat := oldAxiomPreCategoryBuild(catform,dom,nil) - parvec.(n-1) := newcat - newcat - -oldAxiomCategoryBuild([catform,:.], dom, env) == - oldAxiomPreCategoryBuild(catform,dom, env) -oldAxiomCategoryHashCode([.,hash,:.], env) == hash - -$oldAxiomCategoryDispatch := - VECTOR('oldAxiomCategory, - [function oldAxiomCategoryDevaluate], - [nil], - [function oldAxiomCategoryLookupExport], - [function oldAxiomCategoryHashCode], - [function oldAxiomCategoryBuild], -- builder ?? - [function oldAxiomCategoryParentCount], - [function oldAxiomCategoryNthParent]) -- 1 indexed - -attributeDevaluate(attrObj, env) == - [name, hash] := attrObj - StringToCompStr symbolName name - -attributeLookupExport(attrObj, self, op, sig, box, env) == - [name, hash] := attrObj - opIsHasCat op => if scalarEq?(hash, sig) then [self] else nil - -attributeHashCode(attrObj, env) == - [name, hash] := attrObj - hash - -attributeCategoryBuild(attrObj, dom, env) == - [name, hash] := attrObj - [$attributeDispatch, name, hash] - -attributeCategoryParentCount(attrObj, env) == 0 - -attributeNthParent(attrObj, env) == nil - -$attributeDispatch := - VECTOR('attribute, - [function attributeDevaluate], - [nil], - [function attributeLookupExport], - [function attributeHashCode], - [function attributeCategoryBuild], -- builder ?? - [function attributeCategoryParentCount], - [function attributeNthParent]) -- 1 indexed - - ---======================================================================= --- Generate Category Level Alist ---======================================================================= -orderCatAnc x == - reverse! ASSOCLEFT SORTBY(function rest,rest depthAssoc x) - -depthAssocList u == - u := removeSymbol(u,'DomainSubstitutionMacro) --hack by RDJ 8/90 - removeDuplicates ("append"/[depthAssoc(y) for y in u]) - -depthAssoc x == - y := tableValue($depthAssocCache,x) => y - x is ['Join,:u] or (u := getCatAncestors x) => - v := depthAssocList u - tableValue($depthAssocCache,x) := [[x,:n],:v] - where n() == 1 + "MAX"/[rest y for y in v] - tableValue($depthAssocCache,x) := [[x,:0]] - -getCatAncestors x == [CAAR y for y in parentsOf opOf x] - -listOfEntries form == - form isnt [.,:.] => form - form is [op,:l] => - op is 'Join => "append"/[listOfEntries x for x in l] - op is 'CATEGORY => listOfCategoryEntries rest l - op is 'PROGN => listOfCategoryEntries l - op is 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] - op in '(ATTRIBUTE SIGNATURE) => nil - [form] - categoryFormatError() - -listOfCategoryEntries l == - null l => nil - l is [[op,:u],:v] => - firstItemList:= - op is 'ATTRIBUTE and first u is [f,:.] and constructor? f => - [first u] - op in '(ATTRIBUTE SIGNATURE) => nil - op is 'IF and u is [pred,conseq,alternate] => - listOfCategoryEntriesIf(pred,conseq,alternate) - categoryFormatError() - [:firstItemList,:listOfCategoryEntries v] - l is ['PROGN,:l] => listOfCategoryEntries l - l is '(NIL) => nil - sayBrightly '"unexpected category format encountered:" - pp l - -listOfCategoryEntriesIf(pred,conseq,alternate) == - alternate in '(%noBranch NIL) => - conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) - [fn for x in listOfEntries conseq] where fn() == - x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] - ['IF,pred,x] - notPred := makePrefixForm(pred,'NOT) - conseq is ['IF,p,c,a] => - listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) - [gn for x in listOfEntries conseq] where gn() == - x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] - ['IF,notPred,x] - -orderedDefaults(conform,domform) == - $depthAssocCache : local := hashTable 'EQ - conList := [x for x in orderCatAnc (op := opOf conform) | hasDefaultPackage op] - acc := nil - ancestors := ancestorsOf(conform,domform) - for x in conList repeat - for y in ancestors | x = CAAR y repeat acc := [y,:acc] - reverse! acc - -instantiate domenv == - -- following is a patch for a bug in runtime.as - -- has a lazy dispatch vector with an instantiated domenv - VECTORP rest domenv => [$oldAxiomDomainDispatch ,: domenv] - callForm := second domenv - oldDom := CDDR domenv - [functor,:args] := callForm --- if null(fn := property(functor,'instantiate)) then --- ofn := symbolFunction functor --- loadFunctor functor --- fn := symbolFunction functor --- symbolFunction(functor) := ofn --- proprty(functor, 'instantiate) := fn --- domvec := apply(fn, args) - domvec := apply(functor, args) - oldDom.first := $oldAxiomDomainDispatch - oldDom.rest := [second oldDom,: domvec] - oldDom - -hashTypeForm([fn,: args], percentHash) == - hashType([fn,:devaluateList args], percentHash) - -$hashOp1 == hashString '"1" -$hashOp0 == hashString '"0" -$hashOpApply == hashString '"apply" -$hashOpSet == hashString '"set!" -$hashSeg == hashString '".." -$hashPercent == hashString '"%" - -oldAxiomDomainLookupExport _ - (domenv, self, op, sig, box, skipdefaults, env) == - domainVec := rest domenv - if hashCode? op then - scalarEq?(op, $hashOp1) => op := 'One - scalarEq?(op, $hashOp0) => op := 'Zero - scalarEq?(op, $hashOpApply) => op := 'elt - scalarEq?(op, $hashOpSet) => op := 'setelt - scalarEq?(op, $hashSeg) => op := 'SEGMENT - constant := nil - if hashCode? sig and self and scalarEq?(sig, getDomainHash self) then - sig := '($) - constant := true - val := - skipdefaults => - oldCompLookupNoDefaults(op, sig, domainVec, self) - oldCompLookup(op, sig, domainVec, self) - null val => val - if constant then val := SPADCALL val - box.first := val - box - -oldAxiomDomainHashCode(domenv, env) == first domenv - -oldAxiomDomainHasCategory(domenv, cat, env) == - HasAttribute(domvec := rest domenv, cat) or - HasCategory(domvec, devaluate cat) - -oldAxiomDomainDevaluate(domenv, env) == - SExprToDName(rest domenv.0, 'T) - -oldAxiomAddChild(domenv, child, env) == [$oldAxiomDomainDispatch,:domenv] - -$oldAxiomDomainDispatch := - VECTOR('oldAxiomDomain, - [function oldAxiomDomainDevaluate], - [nil], - [function oldAxiomDomainLookupExport], - [function oldAxiomDomainHashCode], - [function oldAxiomAddChild]) - -basicLookupCheckDefaults(op,sig,domain,dollar) == - box := [nil] - not vector?(dispatch := first dollar) => error "bad domain format" - lookupFun := dispatch.3 - dispatch.0 = 0 => -- new compiler domain object - hashPercent := - vector? dollar => hashType(dollar.0,0) - hashType(dollar,0) - - hashSig := - hashCode? sig => sig - hashType( ['Mapping,:sig], hashPercent) - - if symbol? op then op := hashString symbolName op - first SPADCALL(rest dollar, dollar, op, hashSig, box, not $lookupDefaults, lookupFun) - first SPADCALL(rest dollar, dollar, op, sig, box, not $lookupDefaults, lookupFun) - -$hasCatOpHash == hashString '"%%" -opIsHasCat op == - hashCode? op => scalarEq?(op, $hasCatOpHash) - op = "%%" - --- has cat questions lookup up twice if false --- replace with following ? --- not(opIsHasCat op) and --- (u := lookupInDomainVector(op,sig,domvec,domvec)) => u - -oldCompLookup(op, sig, domvec, dollar) == - $lookupDefaults: local := false - u := lookupInDomainVector(op,sig,domvec,dollar) => u - $lookupDefaults := true - lookupInDomainVector(op,sig,domvec,dollar) - -oldCompLookupNoDefaults(op, sig, domvec, dollar) == - $lookupDefaults: local := false - lookupInDomainVector(op,sig,domvec,dollar) - -hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == - opIsHasCat op => - HasCategory(domain, sig) - if hashCode? op and scalarEq?(op, $hashOp1) then op := 'One - if hashCode? op and scalarEq?(op, $hashOp0) then op := 'Zero - hashPercent := - vector? dollar => hashType(dollar.0,0) - hashType(dollar,0) - if hashCode? sig and scalarEq?(sig, hashPercent) then - sig := hashType('(Mapping $), hashPercent) - dollar = nil => systemError() - $lookupDefaults => - hashNewLookupInCategories(op,sig,domain,dollar) --lookup first in my cats - or newLookupInAddChain(op,sig,domain,dollar) - --fast path when called from newGoGet - success := false - if $monitorNewWorld then - sayLooking(concat('"---->",form2String devaluate domain, - '"----> searching op table for:","%l"," "),op,sig,dollar) - someMatch := false - numvec := getDomainByteVector domain - predvec := domainPredicates domain - max := maxIndex opvec - k := getOpCode(op,opvec,max) or return - flag => newLookupInAddChain(op,sig,domain,dollar) - nil - idxmax := maxIndex numvec - start := vectorRef(opvec,k) - finish := - max > k => vectorRef(opvec,k + 2) - idxmax - if finish > idxmax then systemError '"limit too large" - numArgs := if hashCode? sig then -1 else (#sig)-1 - success := nil - $isDefaultingPackage: local := - -- use special defaulting handler when dollar non-trivial - dollar ~= domain and defaultPackageForm? devaluate domain - while finish > start repeat - PROGN - i := start - numTableArgs := arrayRef(numvec,i) - predIndex := arrayRef(numvec,i := i + 1) - (predIndex ~= 0) and null testBitVector(predvec,predIndex) => nil - exportSig := - [newExpandTypeSlot(numvec.(i + j + 1), - dollar,domain) for j in 0..numTableArgs] - sig ~= hashType(['Mapping,: exportSig],hashPercent) => nil --signifies no match - loc := arrayRef(numvec,i + numTableArgs + 2) - loc = 1 => (someMatch := true) - loc = 0 => - start := start + numTableArgs + 4 - i := start + 2 - someMatch := true --mark so that if subsumption fails, look for original - subsumptionSig := - [newExpandTypeSlot(arrayRef(numvec,i + j), - dollar,domain) for j in 0..numTableArgs] - if $monitorNewWorld then - sayBrightly [formatOpSignature(op,sig),'"--?-->", - formatOpSignature(op,subsumptionSig)] - nil - slot := vectorRef(domain,loc) - cons? slot => - slot.op = 'newGoGet => someMatch:=true - --treat as if operation were not there - --if sameObject?(QCAR slot,'newGoGet) then - -- UNWIND_-PROTECT --break infinite recursion - -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot rest slot), - -- if domain.loc = 'skip then domain.loc := slot) - return (success := slot) - slot is 'skip => --recursive call from above 'replaceGoGetSlot - return (success := newLookupInAddChain(op,sig,domain,dollar)) - systemError '"unexpected format" - start := start + numTableArgs + 4 - (success ~= 'failed) and success => - if $monitorNewWorld then - sayLooking1('"<----",uu) where uu() == - cons? success => [first success,:devaluate rest success] - success - success - subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u - flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) - nil - -hashNewLookupInCategories(op,sig,dom,dollar) == - slot4 := domainData dom - catVec := second slot4 - # catVec = 0 => nil --early exit if no categories - integer? KDR catVec.0 => - newLookupInCategories1(op,sig,dom,dollar) --old style - $lookupDefaults : local := false - if $monitorNewWorld then sayBrightly concat('"----->", - form2String devaluate dom,'"-----> searching default packages for ",op) - predvec := domainPredicates dom - packageVec := first slot4 ---the next three lines can go away with new category world - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[vectorRef(dom,5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - for i in 0..maxIndex packageVec | - (entry := packageVec.i) and entry ~= true repeat - package := - vector? entry => - if $monitorNewWorld then - sayLooking1('"already instantiated cat package",entry) - entry - ident? entry => - cat := catVec.i - packageForm := nil - if not property(entry,'LOADED) then loadLib entry - infovec := property(entry,'infovec) - success := - --vector? infovec => ----new world - true => ----new world - opvec := infovec.1 - max := maxIndex opvec - code := getOpCode(op,opvec,max) - null code => nil - byteVector := CDDDR infovec.3 - endPos := - code+2 > max => # byteVector - vectorRef(opvec,code+2) - --not nrunNumArgCheck(#sig.source,byteVector,opvec.code,endPos) => nil - --numOfArgs := byteVector.(opvec.code) - --numOfArgs ~= #sig.source => nil - packageForm := [entry,'$,:rest cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - ----old world - table := tableValue($Slot1DataBase,entry) or systemError nil - (u := LASSQ(op,table)) - and (v := or/[rest x for x in u]) => - packageForm := [entry,'$,:rest cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - nil - null success => - if $monitorNewWorld then - sayBrightlyNT '" not in: " - pp (packageForm and devaluate package or entry) - nil - if $monitorNewWorld then - sayLooking1('"candidate default package instantiated: ",success) - success - entry - null package => nil - if $monitorNewWorld then - sayLooking1('"Looking at instantiated package ",package) - res := basicLookup(op,sig,package,dollar) => - if $monitorNewWorld then - sayBrightly '"candidate default package succeeds" - return res - if $monitorNewWorld then - sayBrightly '"candidate fails -- continuing to search categories" - nil - -HasAttribute(domain,attrib) == - hashPercent := - vector? domain => hashType(domain.0,0) - hashType(domain,0) - isDomain domain => - integer?((first domain).0) => - -- following call to hashType was missing 2nd arg. - -- getDomainHash domain added on 4/01/94 by RSS - basicLookup("%%",hashType(attrib, hashPercent),domain,domain) - HasAttribute(CDDR domain, attrib) - integer? domainRef(domain,3) => newHasAttribute(domain,attrib) - (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain) - -newHasAttribute(domain,attrib) == - hashPercent := - vector? domain => hashType(domain.0,0) - hashType(domain,0) - predIndex := - hashCode? attrib => - -- following call to hashType was missing 2nd arg. - -- hashPercent added by PAB 15/4/94 - or/[x for x in domain.2 | attrib = hashType(first x, hashPercent)] - LASSOC(attrib,domain.2) - predIndex => - predIndex = 0 => true - predvec := domainPredicates domain - testBitVector(predvec,predIndex) - false - -newHasCategory(domain,catform) == - catform = $Type or catform = $Category => true - catform is ["Join",:cats] => - and/[newHasCategory(domain,cat) for cat in cats] - slot4 := domain.4 - auxvec := first slot4 - catvec := second slot4 - $isDefaultingPackage: local := defaultPackageForm? devaluate domain - #catvec > 0 and integer? KDR catvec.0 => --old style - predIndex := lazyMatchAssocV1(catform,catvec,domain) - null predIndex => false - predIndex = 0 => true - predvec := domainPredicates domain - testBitVector(predvec,predIndex) - lazyMatchAssocV(catform,auxvec,catvec,domain) --new style - -getCatForm(catvec, index, domain) == - integer?(form := vectorRef(catvec,index)) => domain.form - form - -HasSignature(domain,[op,sig]) == - compiledLookup(op,sig,domain) - -HasCategory(domain,catform') == - catform' is ['SIGNATURE,:f] => HasSignature(domain,f) - catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f) - isDomain domain => - integer?((first domain).0) => - catform' := devaluate catform' - basicLookup("%%",catform',domain,domain) - HasCategory(CDDR domain, catform') - catform:= devaluate catform' - integer? domainRef(domain,3) => newHasCategory(domain,catform) - domain0 := canonicalForm domain -- handles old style domains, Record, Union etc. - slot4 := domainData domain - catlist := slot4.1 - member(catform,catlist) or - opOf(catform) in '(Object Type) or --temporary hack - or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] - -domainEqual(a,b) == - vector? a and vector? b and a.0 = b.0 - |