-- 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. )package "BOOT" $noSubsumption:=true --$MERGELIB := nil ------- from nrunopt.boot ----------- --------------------> NEW DEFINITION (see nrunopt.boot.pamphlet) NRTmakeCategoryAlist() == $depthAssocCache: local := MAKE_-HASHTABLE 'ID $catAncestorAlist: local := NIL pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) | (k := predicateBitIndex b) ^= -1] slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] sixEtc := [5 + i for i in 1..#$pairlis] formals := ASSOCRIGHT $pairlis for x in slot1 repeat RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR x)) -----------code to make a new style slot4 ----------------- predList := ASSOCRIGHT slot1 --is list of predicate indices maxPredList := "MAX"/predList catformvec := ASSOCLEFT slot1 maxElement := "MAX"/$byteVec ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], ['CONS, MKQ LIST2VEC slot0, ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] --NOTE: this is new form: old form satisfies VECP CDDR form --------------------> NEW DEFINITION (see nrunopt.boot.pamphlet) encodeCatform x == k := NRTassocIndex x => k atom x or atom rest x => x [first x,:[encodeCatform y for y in rest x]] ------- from nrunfast.boot ----------- --------------------> NEW DEFINITION (see nrunfast.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 --======================================================= -- Expand Signature from Encoded Slot Form --======================================================= --------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) newExpandGoGetTypeSlot(slot,dollar,domain) == newExpandTypeSlot(slot,domain,domain) --------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) newExpandTypeSlot(slot, dollar, domain) == --> returns domain form for dollar.slot newExpandLocalType(sigDomainVal(dollar, domain, slot), dollar,domain) --------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) newExpandLocalType(lazyt,dollar,domain) == VECP lazyt => lazyt.0 ATOM lazyt => lazyt lazyt is [vec,.,:lazyForm] and VECP vec => --old style newExpandLocalTypeForm(lazyForm,dollar,domain) newExpandLocalTypeForm(lazyt,dollar,domain) --new style --------------------> NEW DEFINITION (see nrunfast.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 (see nrunfast.boot.pamphlet) newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == u = '$ => u INTEGERP u => typeFlag => newExpandTypeSlot(u, dollar,domain) domain.u u is ['NRTEVAL,y] => nrtEval(y,domain) u is ['QUOTE,y] => y u = "$$" => domain.0 atom u => u --can be first, rest, etc. newExpandLocalTypeForm(u,dollar,domain) --------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) nrtEval(expr,dom) == $:fluid := dom eval expr sigDomainVal(dollar,domain,index) == --returns a domain or a lazy slot index = 0 => "$" index = 2 => domain domain.index --------------------> NEW DEFINITION (see nrunfast.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(replaceSharpCalls s,d.0,dollar.0,domainArg) --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style a = '$ => s = devaluate dollar a = "$$" => s = devaluate domain STRINGP a => STRINGP s => a = s 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 ------- from template.boot ----------- --------------------> NEW DEFINITION (see template.boot.pamphlet) evalSlotDomain(u,dollar) == $returnNowhereFromGoGet: local := false $ : fluid := dollar $lookupDefaults : local := nil -- new world u = '$ => dollar u = "$$" => dollar FIXP u => VECP (y := dollar.u) => y y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? y is [v,:.] => VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] constructor? v or MEMQ(v,'(Record Union Mapping)) => lazyDomainSet(y,dollar,u) --new style has lazyt y y u is ['NRTEVAL,y] => eval y u is ['QUOTE,y] => y u is ['Record,:argl] => FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] for [.,tag,dom] in argl]) u is ['Union,:argl] and first argl is ['_:,.,.] => APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] for [.,tag,dom] in argl]) u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) systemErrorHere '"evalSlotDomain" ------- from nrungo.boot ----------- --------------------> NEW DEFINITION (see nrungo.boot.pamphlet) lazyCompareSigEqual(s,tslot,dollar,domain) == tslot = '$ => s = tslot -- devaluate dollar --needed for browser INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => lazyt is [.,.,.,[.,item,.]] and item is [.,[functorName,:.]] and functorName = CAR s => compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) nil compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) ------- from i-funsel.boot ----------- --------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == -- looks for a modemap for op with signature args1 -> tar -- in the domain of computation dc -- tar may be NIL (= unknown) null isLegitimateMode(tar, nil, nil) => nil dcName:= CAR dc member(dcName,'(Union Record Mapping Enumeration)) => -- First cut code that ignores args2, $Coerce and $SubDom -- When domains no longer have to have Set, the hard coded 6 and 7 -- should go. op = '_= => #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL tar and tar ^= '(Boolean) => NIL [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]] op = 'coerce => #args1 ^= 1 dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] args1.0 ^= dc => NIL tar and tar ^= $Expression => NIL [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] member(dcName,'(Record Union)) => findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) NIL fun:= NIL ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and SL := constructSubst dc -- if the arglist is homogeneous, first look for homogeneous -- functions. If we don't find any, look at remaining ones if isHomogeneousList args1 then q := NIL r := NIL for mm in CDR p repeat -- CDAR of mm is the signature argument list if isHomogeneousList CDAR mm then q := [mm,:q] else r := [mm,:r] q := allOrMatchingMms(q,args1,tar,dc) for mm in q repeat fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) r := reverse r else r := CDR p r := allOrMatchingMms(r,args1,tar,dc) if not fun then -- consider remaining modemaps for mm in r repeat fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) if not fun and $reportBottomUpFlag then sayMSG concat ['" -> no appropriate",:bright op,'"found in", :bright prefix2String dc] fun --------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) findFunctionInDomain1(omm,op,tar,args1,args2,SL) == dc:= CDR (dollarPair := ASSQ('$,SL)) -- need to drop '$ from SL mm:= subCopy(omm, SL) -- tests whether modemap mm is appropriate for the function -- defined by op, target type tar and argument types args $RTC:local:= NIL -- $RTC is a list of run-time checks to be performed [sig,slot,cond,y] := mm [osig,:.] := omm osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL)) if CONTAINED('_#, sig) or CONTAINED('construct,sig) then sig := [replaceSharpCalls t for t in sig] matchMmCond cond and matchMmSig(mm,tar,args1,args2) and EQ(y,'Subsumed) and -- hmmmm: do Union check in following because (as in DP) -- Unions are subsumed by total modemaps which are in the -- mm list in findFunctionInDomain. y := 'ELT -- if subsumed fails try it again not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]] EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]] EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]] y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] sayKeyedMsg("S2IF0006",[y]) NIL --------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == -- looks for a modemap for op with signature args1 -> tar -- in the domain of computation dc -- tar may be NIL (= unknown) dcName:= CAR dc not MEMQ(dcName,'(Record Union Enumeration)) => NIL fun:= NIL -- cat := constructorCategory dc makeFunc := GETL(dcName,"makeFunctionList") or systemErrorHere '"findFunctionInCategory" [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) -- get list of implementations and remove sharps maxargs := -1 impls := nil for [a,b,d] in funlist repeat not EQ(a,op) => nil d is ['XLAM,xargs,:.] => if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) else maxargs := MAX(maxargs,1) impls := cons([b,nil,true,d],impls) impls := cons([b,d,true,d],impls) impls := NREVERSE impls if maxargs ^= -1 then SL:= NIL for i in 1..maxargs repeat impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) impls and SL:= constructSubst dc for mm in impls repeat fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) if not fun and $reportBottomUpFlag then sayMSG concat ['" -> no appropriate",:bright op,'"found in", :bright prefix2String dc] fun ------- from i-eval.boot ----------- --------------------> NEW DEFINITION (see i-eval.boot.pamphlet) evalForm(op,opName,argl,mmS) == -- applies the first applicable function for mm in mmS until form repeat [sig,fun,cond]:= mm (CAR sig) = 'interpOnly => form := CAR sig #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 form:= $genValue or null cond => [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL for x in argl for t in CDDR sig] [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL for x in argl for t in CDDR sig for c in cond] form or null argl => dc:= CAR sig form := dc='local => --[fun,:form] atom fun => fun in $localVars => ['SPADCALL,:form,fun] [fun,:form,NIL] ['SPADCALL,:form,fun] dc is ["__FreeFunction__",:freeFun] => ['SPADCALL,:form,freeFun] fun is ['XLAM,xargs,:xbody] => rec := first form xbody is [['RECORDELT,.,ind,len]] => optRECORDELT([CAAR xbody,rec,ind,len]) xbody is [['SETRECORDELT,.,ind,len,.]] => optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) xbody is [['RECORDCOPY,.,len]] => optRECORDCOPY([CAAR xbody,rec,len]) ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] dcVector := evalDomain dc fun0 := newType? CAAR mm => mm' := first ncSigTransform mm ncGetFunction(opName, first mm', rest mm') NRTcompileEvalForm(opName,fun,dcVector) null fun0 => throwKeyedMsg("S2IE0008",[opName]) [bpi,:domain] := fun0 EQ(bpi,function Undef) => sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) NIL if $NRTmonitorIfTrue = true then sayBrightlyNT ['"Applying ",first fun0,'" to:"] pp [devaluateDeeply x for x in form] _$:fluid := domain ['SPADCALL, :form, fun0] not form => nil -- not form => throwKeyedMsg("S2IE0008",[opName]) form='interpOnly => rewriteMap(op,opName,argl) targetType := CADR sig if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType evalFormMkValue(op,form,targetType) ------- from clammed.boot ----------- --------------------> NEW DEFINITION (see interop.boot.pamphlet) coerceConvertMmSelection(funName,m1,m2) == -- calls selectMms with $Coerce=NIL and tests for required -- target type. funName is either 'coerce or 'convert. $declaredMode : local:= NIL $reportBottomUpFlag : local:= NIL l := selectMms1(funName,m2,[m1],[m1],NIL) mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1] mmS and CAR mmS ------- from i-coerce.boot ----------- --------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) coerceByFunction(T,m2) == -- using the new modemap selection without coercions -- should not be called by canCoerceFrom x := objVal T x = '_$fromCoerceable_$ => NIL m2 is ['Union,:.] => NIL m1 := objMode T m2 is ['Boolean,:.] and m1 is ['Equation,ud] => dcVector := evalDomain ud fun := isWrapped x => NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector) NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector) [fn,:d]:= fun isWrapped x => x:= unwrap x mkObjWrap(SPADCALL(CAR x,CDR x,fun),m2) x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL) code := ['SPADCALL, a, b, fun] objNew(code,$Boolean) -- If more than one function is found, any should suffice, I think -scm if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then mm := coerceConvertMmSelection(funName := 'convert,m1,m2) mm => [[dc,tar,:args],slot,.]:= mm dcVector := evalDomain(dc) fun:= --+ isWrapped x => NRTcompiledLookup(funName,slot,dcVector) NRTcompileEvalForm(funName,slot,dcVector) [fn,:d]:= fun fn = function Undef => NIL isWrapped x => --+ $: fluid := dcVector val := CATCH('coerceFailure, SPADCALL(unwrap x,fun)) (val = $coerceFailure) => NIL objNewWrap(val,m2) env := fun code := ['failCheck, ['SPADCALL, x, env]] -- tar is ['Union,:.] => objNew(['failCheck,code],m2) objNew(code,m2) -- try going back to types like RN instead of QF I m1' := eqType m1 m2' := eqType m2 (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2') NIL --------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) equalOne(object, domain) == -- tries using constant One and "=" from domain -- object should not be wrapped algEqual(object, getConstantFromDomain('(One),domain), domain) --------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) equalZero(object, domain) == -- tries using constant Zero and "=" from domain -- object should not be wrapped algEqual(object, getConstantFromDomain('(Zero),domain), domain) --------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) algEqual(object1, object2, domain) == -- sees if 2 objects of the same domain are equal by using the -- "=" from the domain -- objects should not be wrapped -- eqfunc := getFunctionFromDomain("=",domain,[domain,domain]) eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain) SPADCALL(object1,object2, eqfunc)