diff options
Diffstat (limited to 'src/interp/nrunfast.boot')
| -rw-r--r-- | src/interp/nrunfast.boot | 670 |
1 files changed, 670 insertions, 0 deletions
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot new file mode 100644 index 00000000..db9136af --- /dev/null +++ b/src/interp/nrunfast.boot @@ -0,0 +1,670 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- 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. + + +--======================================================================= +-- Basic Functions +--======================================================================= +initNewWorld() == + $NRTflag := true + $NRTvec := true + $NRTmakeCompactDirect := true + $NRTquick := true + $NRTmakeShortDirect := true + $newWorld := true + $monitorNewWorld := false + $consistencyCheck := false + $spadLibFT := 'NRLIB + $NRTmonitorIfTrue := false + $updateCatTableIfTrue := false + $doNotCompressHashTableIfTrue := true + +isNewWorldDomain domain == INTEGERP domain.3 --see HasCategory/Attribute + +getDomainByteVector dom == CDDR dom.4 + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +getOpCode(op,vec,max) == +--search Op vector for "op" returning code if found, nil otherwise + res := nil + for i in 0..max by 2 repeat + EQ(QVELT(vec,i),op) => return (res := QSADD1 i) + res + +--======================================================= +-- Lookup From Compiled Code +--======================================================= +newGoGet(:l) == + [:arglist,env] := l + slot := replaceGoGetSlot env + APPLY(first slot,[:arglist,rest slot]) --SPADCALL it! + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +replaceGoGetSlot env == + [thisDomain,index,:op] := env + thisDomainForm := devaluate thisDomain + bytevec := getDomainByteVector thisDomain + numOfArgs := bytevec.index + goGetDomainSlotIndex := bytevec.(index := QSADD1 index) + goGetDomain := + goGetDomainSlotIndex = 0 => thisDomain + thisDomain.goGetDomainSlotIndex + if PAIRP goGetDomain then + goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) + sig := + [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) + for i in 0..numOfArgs] + thisSlot := bytevec.(QSADD1 index) + if $monitorNewWorld then + sayLooking(concat('"%l","..",form2String thisDomainForm, + '" wants",'"%l",'" "),op,sig,goGetDomain) + slot := .basicLookup(op,sig,goGetDomain,goGetDomain) + slot = nil => + $returnNowhereFromGoGet = true => + ['nowhere,:goGetDomain] --see newGetDomainOpTable + sayBrightly concat('"Function: ",formatOpSignature(op,sig), + '" is missing from domain: ",form2String goGetDomain.0) + keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) + if $monitorNewWorld then + sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) + SETELT(thisDomain,thisSlot,slot) + if $monitorNewWorld then + sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) + slot + +--======================================================= +-- Lookup Function in Slot 1 (via SPADCALL) +--======================================================= +lookupFF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) + +lookupUF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupInCompactTable(op,sig,dollar,env) == + newLookupInTable(op,sig,dollar,env,true) + +newLookupInTable(op,sig,dollar,[domain,opvec],flag) == + dollar = nil => systemError() + $lookupDefaults = true => + newLookupInCategories(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 := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return + flag => newLookupInAddChain(op,sig,domain,dollar) + nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + numArgs := QSDIFFERENCE(#sig,1) + success := nil + $isDefaultingPackage: local := + -- use special defaulting handler when dollar non-trivial + dollar ^= domain and isDefaultPackageForm? devaluate domain + while finish > start repeat + PROGN + i := start + numArgs ^= (numTableArgs :=numvec.i) => nil + predIndex := numvec.(i := QSADD1 i) + NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil + loc := newCompareSig(sig,numvec,(i := QSADD1 i),dollar,domain) + null loc => nil --signifies no match + loc = 1 => (someMatch := true) + loc = 0 => + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + i := start + 2 + someMatch := true --mark so that if subsumption fails, look for original + subsumptionSig := + [newExpandTypeSlot(numvec.(QSPLUS(i,j)), + dollar,domain) for j in 0..numTableArgs] + if $monitorNewWorld then + sayBrightly [formatOpSignature(op,sig),'"--?-->", + formatOpSignature(op,subsumptionSig)] + nil + slot := domain.loc + null atom slot => + EQ(QCAR slot,'newGoGet) => someMatch:=true + --treat as if operation were not there + --if EQ(QCAR slot,'newGoGet) then + -- UNWIND_-PROTECT --break infinite recursion + -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), + -- if domain.loc = 'skip then domain.loc := slot) + return (success := slot) + slot = 'skip => --recursive call from above 'replaceGoGetSlot + return (success := newLookupInAddChain(op,sig,domain,dollar)) + systemError '"unexpected format" + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + NE(success,'failed) and success => + if $monitorNewWorld then + sayLooking1('"<----",uu) where uu == + PAIRP 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 + + +isDefaultPackageForm? x == x is [op,:.] + and IDENTP op and (s := PNAME op).(MAXINDEX s) = "&" + + +--======================================================= +-- Lookup Addlist (from lookupInDomainTable or lookupInDomain) +--======================================================= +newLookupInAddChain(op,sig,addFormDomain,dollar) == + if $monitorNewWorld then sayLooking1('"looking up add-chain: ",addFormDomain) + addFunction:=newLookupInDomain(op,sig,addFormDomain,dollar,5) + addFunction => + if $monitorNewWorld then + sayLooking1(concat('"<----add-chain function found for ", + form2String devaluate addFormDomain,'"<----"),CDR addFunction) + addFunction + nil + +--======================================================= +-- Lookup In Domain (from lookupInAddChain) +--======================================================= +newLookupInDomain(op,sig,addFormDomain,dollar,index) == + addFormCell := addFormDomain.index => + INTEGERP KAR addFormCell => + or/[newLookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] + if null VECP addFormCell then lazyDomainSet(addFormCell,addFormDomain,index) + lookupInDomainVector(op,sig,addFormDomain.index,dollar) + nil + +--======================================================= +-- Category Default Lookup (from goGet or lookupInAddChain) +--======================================================= +newLookupInCategories(op,sig,dom,dollar) == + slot4 := dom.4 + catVec := CADR slot4 + SIZE catVec = 0 => nil --early exit if no categories + INTEGERP KDR catVec.0 => + newLookupInCategories1(op,sig,dom,dollar) --old style + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + packageVec := QCAR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[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 ^= 'T repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := catVec.i + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + --VECP 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 => SIZE byteVector + opvec.(code+2) + not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil + --numOfArgs := byteVector.(opvec.code) + --numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + ----old world + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u | #sig = #x.0]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true 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 = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +nrunNumArgCheck(num,bytevec,start,finish) == + args := bytevec.start + num = args => true + (start := start + args + 4) = finish => nil + nrunNumArgCheck(num,bytevec,start,finish) + +newLookupInCategories1(op,sig,dom,dollar) == + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + slot4 := dom.4 + packageVec := CAR slot4 + catVec := CAR QCDR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[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 := ELT(packageVec,i)) + and (VECP entry or (predIndex := CDR (node := ELT(catVec,i))) and + (EQ(predIndex,0) or testBitVector(predvec,predIndex))) repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := QCAR node + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + VECP infovec => + opvec := infovec.1 + max := MAXINDEX opvec + code := getOpCode(op,opvec,max) + null code => nil + byteVector := CDDR infovec.3 + numOfArgs := byteVector.(opvec.code) + numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u | #sig = #x.0]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true 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 := lookupInDomainVector(op,sig,package,dollar) => + if $monitorNewWorld = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +--======================================================= +-- Instantiate Default Package if Signature Matches +--======================================================= + +getNewDefaultPackage(op,sig,infovec,dom,dollar) == + hohohoho() + opvec := infovec . 1 + numvec := CDDR infovec . 3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + numArgs := QSDIFFERENCE(#sig,1) + success := nil + while finish > start repeat + PROGN + i := start + numArgs ^= (numTableArgs :=numvec.i) => nil + newCompareSigCheaply(sig,numvec,(i := QSPLUS(i,2))) => + return (success := true) + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + null success => nil + defaultPackage := cacheCategoryPackage(packageVec,catVec,i) + +--======================================================= +-- Compare Signature to One Derived from Table +--======================================================= +newCompareSig(sig, numvec, index, dollar, domain) == + k := index + null (target := first sig) + or lazyMatchArg(target,numvec.k,dollar,domain) => + and/[lazyMatchArg(s,numvec.(k := i),dollar,domain) + for s in rest sig for i in (index+1)..] => numvec.(QSINC1 k) + nil + nil + +--======================================================= +-- Compare Signature to One Derived from Table +--======================================================= +lazyMatchArg(s,a,dollar,domain) == lazyMatchArg2(s,a,dollar,domain,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +lazyMatchArg2(s,a,dollar,domain,typeFlag) == + if s = '$ then +-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup + s := devaluate dollar -- calls from HasCategory can have $s + INTEGERP a => + not typeFlag => s = domain.a + a = 6 and $isDefaultingPackage => s = devaluate dollar + VECP (d := domainVal(dollar,domain,a)) => + s = d.0 => true + domainArg := ($isDefaultingPackage => domain.6.0; domain.0) + KAR s = QCAR d.0 and lazyMatchArgDollarCheck(s,d.0,dollar.0,domainArg) + --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) + lazyMatch(s,d,dollar,domain) --new style + a = '$ => s = devaluate dollar + STRINGP a => + s is ['QUOTE,y] and PNAME y = a + IDENTP s and PNAME s = a + atom a => a = s + op := opOf a + op = 'NRTEVAL => s = nrtEval(CADR a,domain) + op = 'QUOTE => s = CADR a + lazyMatch(s,a,dollar,domain) + --above line is temporarily necessary until system is compiled 8/15/90 +--s = a + +lazyMatch(source,lazyt,dollar,domain) == + lazyt is [op,:argl] and null atom source and op=CAR source + and #(sargl := CDR source) = #argl => + MEMQ(op,'(Record Union)) and first argl is [":",:.] => + and/[stag = atag and lazyMatchArg(s,a,dollar,domain) + for [.,stag,s] in sargl for [.,atag,a] in argl] + MEMQ(op,'(Union Mapping QUOTE)) => + and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl] + coSig := GETDATABASE(op,'COSIG) + NULL coSig => error ["bad Constructor op", op] + and/[lazyMatchArg2(s,a,dollar,domain,flag) + for s in sargl for a in argl for flag in rest coSig] + STRINGP source and lazyt is ['QUOTE,=source] => true + NUMBERP source => + lazyt is ['_#, slotNum] => source = #(domain.slotNum) + lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum) + nil + source is ['construct,:l] => l = lazyt + -- A hideous hack on the same lines as the previous four lines JHD/MCD + nil + + +lazyMatchArgDollarCheck(s,d,dollarName,domainName) == + #s ^= #d => nil + scoSig := GETDATABASE(opOf s,'COSIG) or return nil + if MEMQ(opOf s, '(Union Mapping Record)) then + scoSig := [true for x in s] + and/[fn for x in rest s for arg in rest d for xt in rest scoSig] where + fn == + x = arg => true + x is ['elt,someDomain,opname] => lookupInDomainByName(opname,evalDomain someDomain,arg) + x = '$ and (arg = dollarName or arg = domainName) => true + x = dollarName and arg = domainName => true + ATOM x or ATOM arg => false + xt and CAR x = CAR arg => + lazyMatchArgDollarCheck(x,arg,dollarName,domainName) + false + +lookupInDomainByName(op,domain,arg) == + atom arg => nil + opvec := domain . 1 . 2 + numvec := getDomainByteVector domain + predvec := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + success := false + while finish > start repeat + i := start + numberOfArgs :=numvec.i + predIndex := numvec.(i := QSADD1 i) + NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil + slotIndex := numvec.(i + 2 + numberOfArgs) + newStart := QSPLUS(start,QSPLUS(numberOfArgs,4)) + slot := domain.slotIndex + null atom slot and EQ(CAR slot,CAR arg) and EQ(CDR slot,CDR arg) => return (success := true) + start := QSPLUS(start,QSPLUS(numberOfArgs,4)) + success + +--======================================================= +-- Expand Signature from Encoded Slot Form +--======================================================= +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandGoGetTypeSlot(slot,dollar,domain) == + newExpandTypeSlot(slot,domain,domain) + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandTypeSlot(slot, dollar, domain) == +--> returns domain form for dollar.slot + newExpandLocalType(domainVal(dollar, domain, slot), dollar,domain) + + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalType(lazyt,dollar,domain) == + VECP lazyt => lazyt.0 + lazyt is [vec,.,:lazyForm] and VECP vec => --old style + newExpandLocalTypeForm(lazyForm,dollar,domain) + newExpandLocalTypeForm(lazyt,dollar,domain) --new style + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalTypeForm([functorName,:argl],dollar,domain) == + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] + for [.,tag,dom] in argl]] + MEMQ(functorName, '(Union Mapping)) => + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] + functorName = 'QUOTE => [functorName,:argl] + coSig := GETDATABASE(functorName,'COSIG) + NULL coSig => error ["bad functorName", functorName] + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) + for a in argl for flag in rest coSig]] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == + u = '$ => dollar.0 -------eliminate this as $ is rep by 0 + INTEGERP u => + typeFlag => newExpandTypeSlot(u, dollar,domain) + domain.u + u is ['NRTEVAL,y] => nrtEval(y,domain) + u is ['QUOTE,y] => y + atom u => u --can be first, rest, etc. + newExpandLocalTypeForm(u,dollar,domain) + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +nrtEval(expr,dom) == + $:fluid := dom + eval expr + +domainVal(dollar,domain,index) == +--returns a domain or a lazy slot + index = 0 => dollar + index = 2 => domain + domain.index + + +--======================================================= +-- Convert Lazy Domain to Domain Form +--======================================================= + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lazyDomainSet(lazyForm,thisDomain,slot) == + form := + lazyForm is [vec,.,:u] and VECP vec => u --old style + lazyForm --new style + slotDomain := evalSlotDomain(form,thisDomain) + if $monitorNewWorld then + sayLooking1(concat(form2String devaluate thisDomain, + '" activating lazy slot ",slot,'": "),slotDomain) + name := CAR form + SETELT(thisDomain,slot,slotDomain) + +--======================================================= +-- HasCategory/Attribute +--======================================================= +-- PLEASE NOTE: This function has the rather charming side-effect that +-- e.g. it works if domform is an Aldor Category. This is being used +-- by extendscategoryForm in c-util to allow Aldor domains to be used +-- in spad code. Please do not break this! An example is the use of +-- Interval (an Aldor domain) by SIGNEF in limitps.spad. MCD. +newHasTest(domform,catOrAtt) == + domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) => + ofCategory(domform, catOrAtt) + catOrAtt = '(Type) => true + GETDATABASE(opOf domform, 'ASHARP?) => fn(domform,catOrAtt) where + -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where + fn(a,b) == + categoryForm?(a) => assoc(b, ancestorsOf(a, nil)) + isPartialMode a => throwKeyedMsg("S2IS0025",NIL) + b is ["SIGNATURE",:opSig] => + HasSignature(evalDomain a,opSig) + b is ["ATTRIBUTE",attr] => HasAttribute(evalDomain a,attr) + hasCaty(a,b,NIL) ^= 'failed + HasCategory(evalDomain a,b) => true -- for asharp domains: must return Boolean + op := opOf catOrAtt + isAtom := atom catOrAtt + null isAtom and op = 'Join => + and/[newHasTest(domform,x) for x in rest catOrAtt] +-- we will refuse to say yes for 'Cat has Cat' +--GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL) +-- on second thoughts we won't! + GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => + domform = catOrAtt => 'T + for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] | aCat = catOrAtt repeat + return evalCond cond where + evalCond x == + ATOM x => x + [pred,:l] := x + pred = 'has => + l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2) + l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1) + newHasTest(first l ,first rest l) + pred = 'OR => or/[evalCond i for i in l] + pred = 'AND => and/[evalCond i for i in l] + x + null isAtom and constructor? op => + domain := eval mkEvalable domform + newHasCategory(domain,catOrAtt) + newHasAttribute(eval mkEvalable domform,catOrAtt) + +lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 + n : FIXNUM := MAXINDEX catvec + xop := CAR x + or/[ELT(auxvec,i) for i in 0..n | + xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] + +lazyMatchAssocV1(x,vec,domain) == --old style slot4 + n : FIXNUM := MAXINDEX vec + xop := CAR x + or/[QCDR QVELT(vec,i) for i in 0..n | + xop = CAR (lazyt := CAR QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)] + +--newHasAttribute(domain,attrib) == +-- predIndex := LASSOC(attrib,domain.2) => +-- EQ(predIndex,0) => true +-- predvec := domain.3 +-- testBitVector(predvec,predIndex) +-- false + +--======================================================= +-- Utility Functions +--======================================================= + +sayLooking(prefix,op,sig,dom) == + $monitorNewWorld := false + dollar := devaluate dom + atom dollar or VECP dollar or or/[VECP x for x in dollar] => systemError nil + sayBrightly + concat(prefix,formatOpSignature(op,sig),bright '"from ",form2String dollar) + $monitorNewWorld := true + +sayLooking1(prefix,dom) == + $monitorNewWorld := false + dollar := + VECP dom => devaluate dom + devaluateList dom + sayBrightly concat(prefix,form2String dollar) + $monitorNewWorld := true + +cc() == -- don't remove this function + clearConstructorCaches() + clearClams() |