From c75b5923cb35d83910e45f13e9d15c981ea25387 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 04:57:39 +0000 Subject: remove pamphlets - part 7 --- src/interp/nrunfast.boot.pamphlet | 692 -------------------------------------- 1 file changed, 692 deletions(-) delete mode 100644 src/interp/nrunfast.boot.pamphlet (limited to 'src/interp/nrunfast.boot.pamphlet') diff --git a/src/interp/nrunfast.boot.pamphlet b/src/interp/nrunfast.boot.pamphlet deleted file mode 100644 index e6a29b12..00000000 --- a/src/interp/nrunfast.boot.pamphlet +++ /dev/null @@ -1,692 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nrunfast.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- 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() -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3