From 7bacc11540fe33bf3530c361a59772ecd4d529d9 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 04:13:24 +0000 Subject: remove pamphlets - part 5 --- src/interp/interop.boot.pamphlet | 933 --------------------------------------- 1 file changed, 933 deletions(-) delete mode 100644 src/interp/interop.boot.pamphlet (limited to 'src/interp/interop.boot.pamphlet') diff --git a/src/interp/interop.boot.pamphlet b/src/interp/interop.boot.pamphlet deleted file mode 100644 index 88d4e560..00000000 --- a/src/interp/interop.boot.pamphlet +++ /dev/null @@ -1,933 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/interop.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\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. - -@ -<<*>>= -<> - -)package "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 == INTEGERP x - -$domainTypeTokens := ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory, - 'oldAxiomCategory, 0] - --- The name game. --- The compiler produces names that are of the form: --- a) cons(0, ) --- 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" - CAR dname = DNameStringID => - INTERN(CompStrToString CDR dname) - name0 := DNameToSExpr1 CAR CDR dname - args := CDR CDR dname - name0 = '_-_> => - froms := CAR args - froms := MAPCAR(function DNameToSExpr, CDR froms) - ret := CAR CDR args -- a tuple - ret := DNameToSExpr CAR CDR ret -- contents - CONS('Mapping, CONS(ret, froms)) - name0 = 'Union or name0 = 'Record => - sxs := MAPCAR(function DNameToSExpr, CDR CAR args) - CONS(name0, sxs) - name0 = 'Enumeration => - CONS(name0, MAPCAR(function DNameFixEnum, CDR CAR args)) - CONS(name0, MAPCAR(function DNameToSExpr, args)) - -DNameToSExpr dname == - CAR dname = DNameOtherID => - CDR dname - sx := DNameToSExpr1 dname - CONSP sx => sx - LIST sx - -DNameFixEnum arg == CompStrToString CDR arg - -SExprToDName(sexpr, cosigVal) == - -- is it a non-type valued object? - NOT cosigVal => [DNameOtherID, :sexpr] - if CAR sexpr = '_: then sexpr := CAR CDR CDR sexpr - CAR sexpr = 'Mapping => - args := [ SExprToDName(sx, 'T) for sx in CDR sexpr] - [DNameApplyID, - [DNameStringID,: StringToCompStr '"->"], - [DNameTupleID, : CDR args], - [DNameTupleID, CAR args]] - name0 := [DNameStringID, : StringToCompStr SYMBOL_-NAME CAR sexpr] - CAR sexpr = 'Union or CAR sexpr = 'Record => - [DNameApplyID, name0, - [DNameTupleID,: [ SExprToDName(sx, 'T) for sx in CDR sexpr]]] - newCosig := CDR GETDATABASE(CAR sexpr, QUOTE COSIG) - [DNameApplyID, name0, - : MAPCAR(function SExprToDName, CDR sexpr, newCosig)] - --- local garbage because Compiler strings are null terminated -StringToCompStr(str) == - CONCATENATE(QUOTE STRING, str, STRING (CODE_-CHAR 0)) - -CompStrToString(str) == - SUBSTRING(str, 0, (LENGTH str - 1)) --- local garbage ends - -runOldAxiomFunctor(:allArgs) == - [:args,env] := allArgs - GETDATABASE(env, 'CONSTRUCTORKIND) = 'category => - [$oldAxiomPreCategoryDispatch,: [env, :args]] - dom:=APPLY(env, args) - makeOldAxiomDispatchDomain dom - -makeLazyOldAxiomDispatchDomain domform == - attribute? domform => - [$attributeDispatch, domform, hashString(SYMBOL_-NAME domform)] - GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category => - [$oldAxiomPreCategoryDispatch,: domform] - dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] - NCONC(dd,dd) -- installs back pointer to head of domain. - dd - -makeOldAxiomDispatchDomain dom == - PAIRP dom => dom - [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom] - -closeOldAxiomFunctor(name) == - [function runOldAxiomFunctor,:SYMBOL_-FUNCTION name] - -lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) == - dom := instantiate domenv - SPADCALL(CDR dom, self, op, sig, box, skipdefaults, CAR(dom).3) - -lazyOldAxiomDomainHashCode(domenv, env) == CAR domenv - -lazyOldAxiomDomainDevaluate(domenv, env) == - dom := instantiate domenv - SPADCALL(CDR dom, CAR(dom).1) - -lazyOldAxiomAddChild(domenv, kid, env) == - CONS($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) - CONS($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], T) - -$oldAxiomPreCategoryDispatch := - VECTOR('oldAxiomPreCategory, - [function oldAxiomPreCategoryDevaluate], - [nil], - [nil], - [function oldAxiomPreCategoryHashCode], - [function oldAxiomPreCategoryBuild], - [nil]) - -oldAxiomCategoryDevaluate([[op,:args],:.], env) == - SExprToDName([op,:devaluateList args], T) - -oldAxiomPreCategoryParents(catform,dom) == - vars := ["$",:rest GETDATABASE(opOf catform, 'CONSTRUCTORFORM)] - vals := [dom,:rest catform] - -- parents := GETDATABASE(opOf catform, 'PARENTS) - parents := parentsOf opOf catform - PROGV(vars, vals, - LIST2VEC - [EVAL quoteCatOp cat for [cat,:pred] in parents | EVAL pred]) - -quoteCatOp cat == - atom cat => MKQ cat - ['LIST, MKQ CAR cat,: CDR cat] - - -oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) == - [catform,hash, pack,:.] := catenv - opIsHasCat op => if EQL(sig, hash) then [self] else nil - NULL(pack) => nil - if not VECP pack then - pack:=apply(pack, CONS(self, rest catform)) - RPLACA(CDDR catenv, pack) - fun := basicLookup(op, sig, pack, self) => [fun] - nil - -oldAxiomCategoryParentCount([.,.,.,parents,.], env) == LENGTH parents -oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) == - catform := ELT(parvec, n-1) - VECTORP KAR catform => catform - newcat := oldAxiomPreCategoryBuild(catform,dom,nil) - SETELT(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 SYMBOL_-NAME name - -attributeLookupExport(attrObj, self, op, sig, box, env) == - [name, hash] := attrObj - opIsHasCat op => if EQL(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 - - -orderedDefaults(conform,domform) == - $depthAssocCache : local := MAKE_-HASHTABLE 'ID - 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] - NREVERSE acc - -instantiate domenv == - -- following is a patch for a bug in runtime.as - -- has a lazy dispatch vector with an instantiated domenv - VECTORP CDR domenv => [$oldAxiomDomainDispatch ,: domenv] - callForm := CADR domenv - oldDom := CDDR domenv - [functor,:args] := callForm --- if null(fn := GETL(functor,'instantiate)) then --- ofn := SYMBOL_-FUNCTION functor --- loadFunctor functor --- fn := SYMBOL_-FUNCTION functor --- SETF(SYMBOL_-FUNCTION functor, ofn) --- PUT(functor, 'instantiate, fn) --- domvec := APPLY(fn, args) - domvec := APPLY(functor, args) - RPLACA(oldDom, $oldAxiomDomainDispatch) - RPLACD(oldDom, [CADR oldDom,: domvec]) - oldDom - -hashTypeForm([fn,: args], percentHash) == - hashType([fn,:devaluateList args], percentHash) - ---------------------> NEW DEFINITION (override in i-util.boot.pamphlet) -devaluate(d) == - isDomain d => - -- ?need a shortcut for old domains - -- ELT(CAR d, 0) = 'oldAxiomDomain => ... - -- FIXP(ELT(CAR d,0)) => d - DNameToSExpr(SPADCALL(CDR d,CAR(d).1)) - not REFVECP d => d - QSGREATERP(QVSIZE d,5) and QREFELT(d,3) is ['Category] => QREFELT(d,0) - QSGREATERP(QVSIZE d,0) => - d':=QREFELT(d,0) - isFunctor d' => d' - d - d - -$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 := CDR domenv - if hashCode? op then - EQL(op, $hashOp1) => op := 'One - EQL(op, $hashOp0) => op := 'Zero - EQL(op, $hashOpApply) => op := 'elt - EQL(op, $hashOpSet) => op := 'setelt - EQL(op, $hashSeg) => op := 'SEGMENT - constant := nil - if hashCode? sig and self and EQL(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 - RPLACA(box, val) - box - -oldAxiomDomainHashCode(domenv, env) == CAR domenv - -oldAxiomDomainHasCategory(domenv, cat, env) == - HasAttribute(domvec := CDR domenv, cat) or - HasCategory(domvec, devaluate cat) - -oldAxiomDomainDevaluate(domenv, env) == - SExprToDName(CDR(domenv).0, 'T) - -oldAxiomAddChild(domenv, child, env) == CONS($oldAxiomDomainDispatch, domenv) - -$oldAxiomDomainDispatch := - VECTOR('oldAxiomDomain, - [function oldAxiomDomainDevaluate], - [nil], - [function oldAxiomDomainLookupExport], - [function oldAxiomDomainHashCode], - [function oldAxiomAddChild]) - ---------------------> NEW DEFINITION (see g-util.boot.pamphlet) -isDomain a == - PAIRP a and VECP(CAR a) and - member(CAR(a).0, $domainTypeTokens) - --- following is interpreter interfact to function lookup --- perhaps it should always work with hashcodes for signature? ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -NRTcompiledLookup(op,sig,dom) == - if CONTAINED('_#,sig) then - sig := [NRTtypeHack t for t in sig] - hashCode? sig => compiledLookupCheck(op,sig,dom) - (fn := compiledLookup(op,sig,dom)) => fn - percentHash := - VECP dom => hashType(dom.0, 0) - getDomainHash dom - compiledLookupCheck(op, hashType(['Mapping,:sig], percentHash), dom) - ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -compiledLookup(op, sig, dollar) == - if not isDomain dollar then dollar := NRTevalDomain dollar - basicLookup(op, sig, dollar, dollar) - ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -basicLookup(op,sig,domain,dollar) == - -- following case is for old domains like Record and Union - -- or for getting operations out of yourself - VECP domain => - isNewWorldDomain domain => -- getting ops from yourself (or for defaults) - oldCompLookup(op, sig, domain, dollar) - -- getting ops from Record or Union - lookupInDomainVector(op,sig,domain,dollar) - hashPercent := - VECP dollar => hashType(dollar.0,0) - hashType(dollar,0) - box := [nil] - not VECP(dispatch := CAR domain) => error "bad domain format" - lookupFun := dispatch.3 - dispatch.0 = 0 => -- new compiler domain object - hashSig := - hashCode? sig => sig - opIsHasCat op => hashType(sig, hashPercent) - hashType(['Mapping,:sig], hashPercent) - - if SYMBOLP op then - op = 'Zero => op := $hashOp0 - op = 'One => op := $hashOp1 - op = 'elt => op := $hashOpApply - op = 'setelt => op := $hashOpSet - op := hashString SYMBOL_-NAME op - val:=CAR SPADCALL(CDR domain, dollar, op, hashSig, box, false, - lookupFun) => val - hashCode? sig => nil - #sig>1 or opIsHasCat op => nil - boxval := SPADCALL(CDR dollar, dollar, op, hashType(first sig, hashPercent), - box, false, lookupFun) => - [FUNCTION IDENTITY,: CAR boxval] - nil - opIsHasCat op => - HasCategory(domain, sig) - if hashCode? op then - EQL(op, $hashOp1) => op := 'One - EQL(op, $hashOp0) => op := 'Zero - EQL(op, $hashOpApply) => op := 'elt - EQL(op, $hashOpSet) => op := 'setelt - EQL(op, $hashSeg) => op := 'SEGMENT - hashCode? sig and EQL(sig, hashPercent) => - SPADCALL CAR SPADCALL(CDR dollar, dollar, op, '($), box, false, lookupFun) - CAR SPADCALL(CDR dollar, dollar, op, sig, box, false, lookupFun) - -basicLookupCheckDefaults(op,sig,domain,dollar) == - box := [nil] - not VECP(dispatch := CAR dollar) => error "bad domain format" - lookupFun := dispatch.3 - dispatch.0 = 0 => -- new compiler domain object - hashPercent := - VECP dollar => hashType(dollar.0,0) - hashType(dollar,0) - - hashSig := - hashCode? sig => sig - hashType( ['Mapping,:sig], hashPercent) - - if SYMBOLP op then op := hashString SYMBOL_-NAME op - CAR SPADCALL(CDR dollar, dollar, op, hashSig, box, not $lookupDefaults, lookupFun) - CAR SPADCALL(CDR dollar, dollar, op, sig, box, not $lookupDefaults, lookupFun) - -$hasCatOpHash := hashString '"%%" -opIsHasCat op == - hashCode? op => EQL(op, $hasCatOpHash) - EQ(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 := nil - u := lookupInDomainVector(op,sig,domvec,dollar) => u - $lookupDefaults := true - lookupInDomainVector(op,sig,domvec,dollar) - -oldCompLookupNoDefaults(op, sig, domvec, dollar) == - $lookupDefaults:local := nil - lookupInDomainVector(op,sig,domvec,dollar) - ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -lookupInDomainVector(op,sig,domain,dollar) == - PAIRP domain => basicLookupCheckDefaults(op,sig,domain,domain) - slot1 := domain.1 - SPADCALL(op,sig,dollar,slot1) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lookupComplete(op,sig,dollar,env) == - hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,nil) - newLookupInTable(op,sig,dollar,env,nil) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lookupIncomplete(op,sig,dollar,env) == - hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) - newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lookupInCompactTable(op,sig,dollar,env) == - hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) - newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (override in 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(s,d.0,dollar.0,domainArg) - --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) - isDomain d => - dhash:=getDomainHash d - dhash = - (if hashCode? s then s else hashType(s, dhash)) --- s = devaluate d - lazyMatch(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 - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -getOpCode(op,vec,max) == ---search Op vector for "op" returning code if found, nil otherwise - res := nil - hashCode? op => - for i in 0..max by 2 repeat - EQL(hashString PNAME QVELT(vec,i),op) => return (res := QSADD1 i) - res - for i in 0..max by 2 repeat - EQ(QVELT(vec,i),op) => return (res := QSADD1 i) - res - -hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == - opIsHasCat op => - HasCategory(domain, sig) - if hashCode? op and EQL(op, $hashOp1) then op := 'One - if hashCode? op and EQL(op, $hashOp0) then op := 'Zero - hashPercent := - VECP dollar => hashType(dollar.0,0) - hashType(dollar,0) - if hashCode? sig and EQL(sig, hashPercent) then - sig := hashType('(Mapping $), hashPercent) - dollar = nil => systemError() - $lookupDefaults = true => - 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 := 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 := if hashCode? sig then -1 else (#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 - numTableArgs :=numvec.i - predIndex := numvec.(i := QSADD1 i) - (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 := numvec.(i + numTableArgs + 2) - 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)) - (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 - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -newExpandLocalType(lazyt,dollar,domain) == - VECP lazyt => lazyt.0 - isDomain lazyt => devaluate lazyt - ATOM lazyt => lazyt - lazyt is [vec,.,:lazyForm] and VECP vec => --old style - newExpandLocalTypeForm(lazyForm,dollar,domain) - newExpandLocalTypeForm(lazyt,dollar,domain) --new style - -hashNewLookupInCategories(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]) => - 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 - ---------------------> NEW DEFINITION (override in 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 and SYMBOLP CAR 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 - -HasAttribute(domain,attrib) == - hashPercent := - VECP domain => hashType(domain.0,0) - hashType(domain,0) - isDomain domain => - FIXP((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) ---> - isNewWorldDomain domain => newHasAttribute(domain,attrib) ---+ - (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain) - -newHasAttribute(domain,attrib) == - hashPercent := - VECP 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 => - EQ(predIndex,0) => true - predvec := domain.3 - testBitVector(predvec,predIndex) - false - -newHasCategory(domain,catform) == - catform = '(Type) => true - slot4 := domain.4 - auxvec := CAR slot4 - catvec := CADR slot4 - $isDefaultingPackage: local := isDefaultPackageForm? devaluate domain - #catvec > 0 and INTEGERP KDR catvec.0 => --old style - predIndex := lazyMatchAssocV1(catform,catvec,domain) - null predIndex => false - EQ(predIndex,0) => true - predvec := QVELT(domain,3) - testBitVector(predvec,predIndex) - lazyMatchAssocV(catform,auxvec,catvec,domain) --new style - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 - n : FIXNUM := MAXINDEX catvec - -- following call to hashType was missing 2nd arg. 0 added on 3/31/94 by RSS - hashCode? x => - percentHash := - VECP domain => hashType(domain.0, 0) - getDomainHash domain - or/[ELT(auxvec,i) for i in 0..n | - x = hashType(newExpandLocalType(QVELT(catvec,i),domain,domain), percentHash)] - xop := CAR x - or/[ELT(auxvec,i) for i in 0..n | - --xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] - xop = CAR (lazyt := getCatForm(catvec,i,domain)) and lazyMatch(x,lazyt,domain,domain)] - -getCatForm(catvec, index, domain) == - NUMBERP(form := QVELT(catvec,index)) => domain.form - form - -has(domain,catform') == HasCategory(domain,catform') - -HasCategory(domain,catform') == - catform' is ['SIGNATURE,:f] => HasSignature(domain,f) - catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f) - isDomain domain => - FIXP((first domain).0) => - catform' := devaluate catform' - basicLookup("%%",catform',domain,domain) - HasCategory(CDDR domain, catform') - catform:= devaluate catform' - isNewWorldDomain domain => newHasCategory(domain,catform) - domain0:=domain.0 -- handles old style domains, Record, Union etc. - slot4 := domain.4 - catlist := slot4.1 - member(catform,catlist) or - MEMQ(opOf(catform),'(Object Type)) or --temporary hack - or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] - ---systemDependentMkAutoload(fn,cnam) == --- FBOUNDP(cnam) => "next" --- SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) - ---------------------> NEW DEFINITION (override in nrunfast.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 ---getInfovec name - SETELT(thisDomain,slot,slotDomain) - - ---------------------> NEW DEFINITION (override in template.boot.pamphlet) -evalSlotDomain(u,dollar) == - $returnNowhereFromGoGet: local := false - $ : fluid := dollar - $lookupDefaults : local := nil -- new world - isDomain u => u - u = '$ => dollar - u = "$$" => dollar - FIXP u => - VECP (y := dollar.u) => y - isDomain y => 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] => - y is ['ELT,:.] => evalSlotDomain(y,dollar) - 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 ['spadConstant,d,n] => - dom := evalSlotDomain(d,dollar) - SPADCALL(dom . n) - u is ['ELT,d,n] => - dom := evalSlotDomain(d,dollar) - slot := dom . n - slot is ['newGoGet,:env] => replaceGoGetSlot env - slot - u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) - systemErrorHere '"evalSlotDomain" - ---------------------> NEW DEFINITION (override in i-util.boot.pamphlet) -domainEqual(a,b) == - devaluate(a) = devaluate(b) - ---makeConstructorsAutoLoad() - --- following changes should go back into xrun.boot --- patched version from xrun.boot ---------------------> NEW DEFINITION (override in clammed.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.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 - mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and - sig is [dc,targ,oarg] and isEqualOrSubDomain(m1,oarg)] - mmS and CAR mmS - ---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) -getFunctionFromDomain(op,dc,args) == - -- finds the function op with argument types args in dc - -- complains, if no function or ambiguous - $reportBottomUpFlag:local:= NIL - member(CAR dc,$nonLisplibDomains) => - throwKeyedMsg("S2IF0002",[CAR dc]) - not constructor? CAR dc => - throwKeyedMsg("S2IF0003",[CAR dc]) - p:= findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL) => ---+ - --sig := [NIL,:args] - domain := evalDomain dc - for mm in nreverse p until b repeat - [[.,:osig],nsig,:.] := mm - b := compiledLookup(op,nsig,domain) - b or throwKeyedMsg("S2IS0023",[op,dc]) - throwKeyedMsg("S2IF0004",[op,dc]) - -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3