diff options
author | dos-reis <gdr@axiomatics.org> | 2007-10-17 04:31:11 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2007-10-17 04:31:11 +0000 |
commit | 3c643ccfe92e3fc3282a4701f70ce76b1199880e (patch) | |
tree | ddb197fa57e541286b03b682e22ee8f20ea5de56 /src | |
parent | ce09059aa3e8028ef11f5e9573bcc6fac593ef5e (diff) | |
download | open-axiom-3c643ccfe92e3fc3282a4701f70ce76b1199880e.tar.gz |
* g-util.boot (isDomain): Merge with version in interop.boot.pamphlet.
* i-funsel.boot.pamphlet (getFunctionFromDomain): Likewise.
* interop.boot.pamphlet (devaluate): Remove.
(isDomain): Likewise.
(NRTcompiledLookup): Likewise.
(compiledLookup): Likewise.
(basicLookup): Likewise.
(lookupInDomainVector): Likewise.
(lookupComplete): Likewise.
(lookupIncomplete): Likewise.
(lookupInCompactTable): Likewise.
(lazyMatchArg2): Likewise.
(getOpCode): Likewise.
(newExpandLocalType): Likewise.
(replaceGoGetSlot): Likewise.
(lazyMatchAssocV): Likewise.
(lazyDomainSet): Likewise.
(evalSlotDomain): Likewise.
(domainEqual): Likewise.
(coerceConvertMmSelection): Likewise.
(getFunctionFromDomain): Likewise.
Diffstat (limited to 'src')
-rw-r--r-- | src/interp/ChangeLog | 24 | ||||
-rw-r--r-- | src/interp/g-util.boot | 4 | ||||
-rw-r--r-- | src/interp/i-funsel.boot.pamphlet | 27 | ||||
-rw-r--r-- | src/interp/interop.boot.pamphlet | 301 |
4 files changed, 31 insertions, 325 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index c8a0ef18..6730f98d 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,5 +1,29 @@ 2007-10-16 Gabriel Dos Reis <gdr@cs.tamu.edu> + * g-util.boot (isDomain): Merge with version in interop.boot.pamphlet. + * i-funsel.boot.pamphlet (getFunctionFromDomain): Likewise. + * interop.boot.pamphlet (devaluate): Remove. + (isDomain): Likewise. + (NRTcompiledLookup): Likewise. + (compiledLookup): Likewise. + (basicLookup): Likewise. + (lookupInDomainVector): Likewise. + (lookupComplete): Likewise. + (lookupIncomplete): Likewise. + (lookupInCompactTable): Likewise. + (lazyMatchArg2): Likewise. + (getOpCode): Likewise. + (newExpandLocalType): Likewise. + (replaceGoGetSlot): Likewise. + (lazyMatchAssocV): Likewise. + (lazyDomainSet): Likewise. + (evalSlotDomain): Likewise. + (domainEqual): Likewise. + (coerceConvertMmSelection): Likewise. + (getFunctionFromDomain): Likewise. + +2007-10-16 Gabriel Dos Reis <gdr@cs.tamu.edu> + Fix SF/1814510 * i-output.boot.pamphlet (putWidth): Use GETL. * Makefile.pamphlet (i-output.$(FASLEXT)): New rule. diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index ea980250..4ee943ba 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -536,9 +536,9 @@ intern x == INTERN x x ---------------------> NEW DEFINITION (override in interop.boot.pamphlet) isDomain a == - REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain + PAIRP a and VECP(CAR a) and + member(CAR(a).0, $domainTypeTokens) -- variables used by browser diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet index bea96021..3ba29f64 100644 --- a/src/interp/i-funsel.boot.pamphlet +++ b/src/interp/i-funsel.boot.pamphlet @@ -715,39 +715,22 @@ hitListOfTarget(t) == EQ(CAR t,'Expression) => 1600 500 ---------------------> NEW DEFINITION (override in interop.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) - - -- NEW COMPILER COMPATIBILITY ON - - if not p then - p := - op = "^" => - findFunctionInDomain("**",dc,NIL,args,args,NIL,NIL) - op = "**" => - findFunctionInDomain("^",dc,NIL,args,args,NIL,NIL) - nil - - -- NEW COMPILER COMPATIBILITY OFF - - p => + p:= findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL) => +--+ + --sig := [NIL,:args] domain := evalDomain dc for mm in nreverse p until b repeat - [[.,:sig],:.] := mm - b := compiledLookup(op,sig,domain) + [[.,:osig],nsig,:.] := mm + b := compiledLookup(op,nsig,domain) b or throwKeyedMsg("S2IS0023",[op,dc]) - - throwKeyedMsg("S2IF0004",[op,dc]) isOpInDomain(opName,dom,nargs) == diff --git a/src/interp/interop.boot.pamphlet b/src/interp/interop.boot.pamphlet index 88d4e560..3e44127c 100644 --- a/src/interp/interop.boot.pamphlet +++ b/src/interp/interop.boot.pamphlet @@ -308,21 +308,6 @@ instantiate domenv == 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" @@ -371,76 +356,6 @@ $oldAxiomDomainDispatch := [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" @@ -478,72 +393,6 @@ 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) @@ -627,15 +476,6 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == 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 @@ -711,39 +551,6 @@ hashNewLookupInCategories(op,sig,dom,dollar) == 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) @@ -789,21 +596,6 @@ newHasCategory(domain,catform) == 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 @@ -831,99 +623,6 @@ HasCategory(domain,catform') == -- 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 |