diff options
Diffstat (limited to 'src/interp/i-funsel.boot.pamphlet')
| -rw-r--r-- | src/interp/i-funsel.boot.pamphlet | 1833 |
1 files changed, 1833 insertions, 0 deletions
diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet new file mode 100644 index 00000000..6e34e518 --- /dev/null +++ b/src/interp/i-funsel.boot.pamphlet @@ -0,0 +1,1833 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/i-funsel.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\begin{verbatim} +New Selection of Modemaps + +selection of applicable modemaps is done in two steps: + first it tries to find a modemap inside an argument domain, and if + this fails, by evaluation of pattern modemaps +the result is a list of functions with signatures, which have the + following form: + [sig,elt,cond] where + sig is the signature gained by evaluating the modemap condition + elt is the slot number to get the implementation + cond are runtime checks which are the results of evaluating the + modemap condition + +the following flags are used: + $Coerce is NIL, if function selection is done which requires exact + matches (e.g. for coercion functions) + if $SubDom is true, then runtime checks have to be compiled +\end{verbatim} +\section{Functions} +\subsection{isPartialMode} +[[isPartialMode]] tests whether m contains [[$EmptyMode]]. The +constant [[$EmptyMode]] (defined in bootfuns.lisp) evaluates to +[[|$EmptyMode|]]. This constants is inserted in a modemap during +compile time if the modemap is not yet complete. +<<isPartialMode>>= +isPartialMode m == + CONTAINED($EmptyMode,m) + +@ +\section{License} +<<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. + +@ +<<*>>= +<<license>> + +SETANDFILEQ($constructorExposureList, '(Boolean Integer String)) + +sayFunctionSelection(op,args,target,dc,func) == + $abbreviateTypes : local := true + startTimingProcess 'debug + fsig := formatSignatureArgs args + if not LISTP fsig then fsig := LIST fsig + if func then func := bright ['"by ",func] + sayMSG concat ['%l,:bright '"Function Selection for",op,:func,'%l, + '" Arguments:",:bright fsig] + if target then sayMSG concat ['" Target type:", + :bright prefix2String target] + if dc then sayMSG concat ['" From: ", + :bright prefix2String dc] + stopTimingProcess 'debug + +sayFunctionSelectionResult(op,args,mmS) == + $abbreviateTypes : local := true + startTimingProcess 'debug + if mmS then printMms mmS + else sayMSG concat ['" -> no function",:bright op, + '"found for arguments",:bright formatSignatureArgs args] + stopTimingProcess 'debug + +selectMms(op,args,$declaredMode) == + -- selects applicable modemaps for node op and arguments args + -- if there is no local modemap, and it is not a package call, then + -- the cached function selectMms1 is called + startTimingProcess 'modemaps + n:= getUnname op + val := getValue op + opMode := objMode val + + -- see if we have a functional parameter + ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and + opMode is ['Mapping,:ta] => + imp := + val => wrapped2Quote objVal val + n + [[['local,:ta], imp , NIL]] + + ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and + opMode is ['Variable,f] => + emptyAtree op + op.0 := f + selectMms(op,args,$declaredMode) + + isSharpVarWithNum(n) and opMode is ['FunctionCalled,f] => + op.0 := f + selectMms(op,args,$declaredMode) + + types1 := getOpArgTypes(n,args) + numArgs := #args + member('(SubDomain (Domain)),types1) => NIL + member('(Domain),types1) => NIL + member($EmptyMode,types1) => NIL + + tar := getTarget op + dc := getAtree(op,'dollar) + + null dc and val and objMode(val) = $AnonymousFunction => + tree := mkAtree objValUnwrap getValue op + putTarget(tree,['Mapping,tar,:types1]) + bottomUp tree + val := getValue tree + [[['local,:rest objMode val], wrapped2Quote objVal val, NIL]] + + if (n = 'map) and (first types1 = $AnonymousFunction) + then + tree := mkAtree objValUnwrap getValue first args + ut := + tar => underDomainOf tar + NIL + ua := [underDomainOf x for x in rest types1] + member(NIL,ua) => NIL + putTarget(tree,['Mapping,ut,:ua]) + bottomUp tree + val := getValue tree + types1 := [objMode val,:rest types1] + RPLACA(args,tree) + + if numArgs = 1 and (n = "numer" or n = "denom") and + isEqualOrSubDomain(first types1,$Integer) and null dc then + dc := ['Fraction, $Integer] + putAtree(op, 'dollar, dc) + + + if $reportBottomUpFlag then sayFunctionSelection(n,types1,tar,dc,NIL) + + identType := 'Variable + for x in types1 while not $declaredMode repeat + not EQCAR(x,identType) => $declaredMode:= x + types2 := [altTypeOf(x,y,$declaredMode) for x in types1 for y in args] + + mmS:= + dc => selectDollarMms(dc,n,types1,types2) + + if n = "/" and tar = $Integer then + tar := $RationalNumber + putTarget(op,tar) + + -- now to speed up some standard selections + if not tar then + tar := defaultTarget(op,n,#types1,types1) + if tar and $reportBottomUpFlag then + sayMSG concat ['" Default target type:", + :bright prefix2String tar] + + selectLocalMms(op,n,types1,tar) or + (VECTORP op and selectMms1(n,tar,types1,types2,'T)) + if $reportBottomUpFlag then sayFunctionSelectionResult(n,types1,mmS) + stopTimingProcess 'modemaps + mmS + +-- selectMms1 is in clammed.boot + +selectMms2(op,tar,args1,args2,$Coerce) == + -- decides whether to find functions from a domain or package + -- or by general modemap evaluation + or/[STRINGP arg for arg in args1] => NIL + if tar = $EmptyMode then tar := NIL + nargs := #args1 + mmS := NIL + mmS := + -- special case map for the time being + $Coerce and (op = 'map) and (2 = nargs) and + (first(args1) is ['Variable,fun]) => + null (ud := underDomainOf CADR args1) => NIL + if tar then ut := underDomainOf(tar) + else ut := nil + null (mapMms := selectMms1(fun,ut,[ud],[NIL],true)) => NIL + mapMm := CDAAR mapMms + selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], + [NIL,CADR args2],$Coerce) + + $Coerce and (op = 'map) and (2 = nargs) and + (first(args1) is ['FunctionCalled,fun]) => + null (ud := underDomainOf CADR args1) => NIL + if tar then ut := underDomainOf(tar) + else ut := nil + funNode := mkAtreeNode fun + transferPropsToNode(fun,funNode) + null (mapMms := selectLocalMms(funNode,fun,[ud],NIL)) => NIL + mapMm := CDAAR mapMms + selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], + [NIL,CADR args2],$Coerce) + + -- get the argument domains and the target + a := nil + for x in args1 repeat if x then a := cons(x,a) + for x in args2 repeat if x then a := cons(x,a) + if tar and not isPartialMode tar then a := cons(tar,a) + + -- for typically homogeneous functions, throw in resolve too + if op in '(_= _+ _* _- ) then + r := resolveTypeList a + if r ^= nil then a := cons(r,a) + + if tar and not isPartialMode tar then + if xx := underDomainOf(tar) then a := cons(xx,a) + for x in args1 repeat + PAIRP(x) and CAR(x) in '(List Vector Stream FiniteSet Array) => + xx := underDomainOf(x) => a := cons(xx,a) + + -- now extend this list with those from the arguments to + -- any Unions, Mapping or Records + + a' := nil + a := nreverse REMDUP a + for x in a repeat + null x => 'iterate + x = '(RationalRadicals) => a' := cons($RationalNumber,a') + x is ['Union,:l] => + -- check if we have a tagged union + l and first l is [":",:.] => + for [.,.,t] in l repeat + a' := cons(t,a') + a' := append(reverse l,a') + x is ['Mapping,:l] => a' := append(reverse l,a') + x is ['Record,:l] => + a' := append(reverse [CADDR s for s in l],a') + x is ['FunctionCalled,name] => + (xm := get(name,'mode,$e)) and not isPartialMode xm => + a' := cons(xm,a') + a := append(a,REMDUP a') + a := [x for x in a | PAIRP(x)] + + -- step 1. see if we have one without coercing + a' := a + while a repeat + x:= CAR a + a:= CDR a + ATOM x => 'iterate + mmS := append(mmS, findFunctionInDomain(op,x,tar,args1,args2,NIL,NIL)) + + -- step 2. if we didn't get one, trying coercing (if we are + -- suppose to) + + if null(mmS) and $Coerce then + a := a' + while a repeat + x:= CAR a + a:= CDR a + ATOM x => 'iterate + mmS := append(mmS, + findFunctionInDomain(op,x,tar,args1,args2,$Coerce,NIL)) + + mmS or selectMmsGen(op,tar,args1,args2) + mmS and orderMms(op, mmS,args1,args2,tar) + +isAVariableType t == + t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.] + +defaultTarget(opNode,op,nargs,args) == + -- this is for efficiency. Chooses standard targets for operations + -- when no target exists. + + target := nil + + nargs = 0 => + op = 'nil => + putTarget(opNode, target := '(List (None))) + target + op = 'true or op = 'false => + putTarget(opNode, target := $Boolean) + target + op = 'pi => + putTarget(opNode, target := ['Pi]) + target + op = 'infinity => + putTarget(opNode, target := ['OnePointCompletion, $Integer]) + target + member(op, '(plusInfinity minusInfinity)) => + putTarget(opNode, target := ['OrderedCompletion, $Integer]) + target + target + + a1 := CAR args + ATOM a1 => target + a1f := QCAR a1 + + nargs = 1 => + op = 'kernel => + putTarget(opNode, target := ['Kernel, ['Expression, $Integer]]) + target + op = 'list => + putTarget(opNode, target := ['List, a1]) + target + target + + a2 := CADR args + + nargs >= 2 and op = "draw" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => + + -- this clears up some confusion over 2D and 3D graphics + + symNode := mkAtreeNode sym + transferPropsToNode(sym,symNode) + + nargs >= 3 and CADDR args is ['Segment,.] => + selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) + putTarget(opNode, target := '(ThreeDimensionalViewport)) + target + + (mms := selectLocalMms(symNode,sym,[$DoubleFloat],NIL)) => + [.,targ,:.] := CAAR mms + targ = $DoubleFloat => + putTarget(opNode, target := '(TwoDimensionalViewport)) + target + targ = ['Point, $DoubleFloat] => + putTarget(opNode, target := '(ThreeDimensionalViewport)) + target + target + + target + + nargs >= 2 and op = "makeObject" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => + -- we won't actually bother to put a target on makeObject + -- this is just to figure out what the first arg is + symNode := mkAtreeNode sym + transferPropsToNode(sym,symNode) + + nargs >= 3 and CADDR args is ['Segment,.] => + selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) + target + + selectLocalMms(symNode,sym,[$DoubleFloat],NIL) + target + + nargs = 2 => + op = "elt" => + a1 = '(BasicOperator) and a2 is ['List, ['OrderedVariableList, .]] => + ['Expression, $Integer] + target + + op = "eval" => + a1 is ['Expression,b1] and a2 is ['Equation, ['Polynomial,b2]] => + target := + canCoerce(b2, a1) => a1 + t := resolveTT(b1, b2) + (not t) or (t = $Any) => nil + resolveTT(a1, t) + if target then putTarget(opNode, target) + target + a1 is ['Equation, .] and a2 is ['Equation, .] => + target := resolveTT(a1, a2) + if target and not (target = $Any) then putTarget(opNode,target) + else target := nil + target + a1 is ['Equation, .] and a2 is ['List, a2e] and a2e is ['Equation, .] => + target := resolveTT(a1, a2e) + if target and not (target = $Any) then putTarget(opNode,target) + else target := nil + target + a2 is ['Equation, a2e] or a2 is ['List, ['Equation, a2e]] => + target := resolveTT(a1, a2e) + if target and not (target = $Any) then putTarget(opNode,target) + else target := nil + target + + op = "**" or op = "^" => + a2 = $Integer => + if (target := resolveTCat(a1,'(Field))) then + putTarget(opNode,target) + target + a1 = '(AlgebraicNumber) and (a2 = $Float or a2 = $DoubleFloat) => + target := ['Expression, a2] + putTarget(opNode,target) + target + a1 = '(AlgebraicNumber) and a2 is ['Complex, a3] and (a3 = $Float or a3 = $DoubleFloat) => + target := ['Expression, a3] + putTarget(opNode,target) + target + ((a2 = $RationalNumber) and + (typeIsASmallInteger(a1) or isEqualOrSubDomain(a1,$Integer))) => + putTarget(opNode, target := '(AlgebraicNumber)) + target + ((a2 = $RationalNumber) and (isAVariableType(a1) + or a1 is ['Polynomial,.] or a1 is ['RationalFunction,.])) => + putTarget(opNode, target := defaultTargetFE a1) + target + isAVariableType(a1) and (a2 = $PositiveInteger or a2 = $NonNegativeInteger) => + putTarget(opNode, target := '(Polynomial (Integer))) + target + isAVariableType(a2) => + putTarget(opNode, target := defaultTargetFE a1) + target + a2 is ['Polynomial, D] => + (a1 = a2) or isAVariableType(a1) + or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D) + or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => + putTarget(opNode, target := defaultTargetFE a2) + target + target + a2 is ['RationalFunction, D] => + (a1 = a2) or isAVariableType(a1) + or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D) + or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => + putTarget(opNode, target := defaultTargetFE a2) + target + target + target + + op = '_/ => + isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) => + putTarget(opNode, target := $RationalNumber) + target + a1 = a2 => + if (target := resolveTCat(CAR args,'(Field))) then + putTarget(opNode,target) + target + a1 is ['Variable,.] and a2 is ['Variable,.] => + putTarget(opNode,target := mkRationalFunction '(Integer)) + target + isEqualOrSubDomain(a1,$Integer) and a2 is ['Variable,.] => + putTarget(opNode,target := mkRationalFunction '(Integer)) + target + a1 is ['Variable,.] and + a2 is ['Polynomial,D] => + putTarget(opNode,target := mkRationalFunction D) + target + target + a2 is ['Variable,.] and + a1 is ['Polynomial,D] => + putTarget(opNode,target := mkRationalFunction D) + target + target + a2 is ['Polynomial,D] and (a1 = D) => + putTarget(opNode,target := mkRationalFunction D) + target + target + + a3 := CADDR args + nargs = 3 => + op = "eval" => + a3 is ['List, a3e] => + target := resolveTT(a1, a3e) + if not (target = $Any) then putTarget(opNode,target) + else target := nil + target + + target := resolveTT(a1, a3) + if not (target = $Any) then putTarget(opNode,target) + else target := nil + target + target + +mkRationalFunction D == ['Fraction, ['Polynomial, D]] + +defaultTargetFE(a,:options) == + a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a, + [QCAR $Symbol, 'RationalRadicals, + 'Pi]) or typeIsASmallInteger(a) or isEqualOrSubDomain(a, $Integer) or + a = '(AlgebraicNumber) => + IFCAR options => [$FunctionalExpression, ['Complex, $Integer]] + [$FunctionalExpression, $Integer] + a is ['Complex,uD] => defaultTargetFE(uD, true) + a is [D,uD] and MEMQ(D, '(Polynomial RationalFunction Fraction)) => + defaultTargetFE(uD, IFCAR options) + a is [=$FunctionalExpression,.] => a + IFCAR options => [$FunctionalExpression, ['Complex, a]] + [$FunctionalExpression, a] + +altTypeOf(type,val,$declaredMode) == + (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and + (a := getMinimalVarMode(objValUnwrap getValue(val),$declaredMode)) => + a + type is ['OrderedVariableList,vl] and + INTEGERP(val1 := objValUnwrap getValue(val)) and + (a := getMinimalVarMode(vl.(val1 - 1),$declaredMode)) => + a + type = $PositiveInteger => $Integer + type = $NonNegativeInteger => $Integer + type = '(List (PositiveInteger)) => '(List (Integer)) + NIL + +getOpArgTypes(opname, args) == + l := getOpArgTypes1(opname, args) + [f(a,opname) for a in l] where + f(x,op) == + x is ['FunctionCalled,g] and op ^= 'name => + m := get(g,'mode,$e) => + m is ['Mapping,:.] => m + x + x + x + +getOpArgTypes1(opname, args) == + null args => NIL + -- special cases first + opname = 'coef and args is [b,n] => + [CAR getModeSet b, CAR getModeSetUseSubdomain n] + opname = 'monom and args is [d,c] => + [CAR getModeSetUseSubdomain d,CAR getModeSet c] + opname = 'monom and args is [v,d,c] => + [CAR getModeSet v,CAR getModeSetUseSubdomain d,CAR getModeSet c] + (opname = 'cons) and (2 = #args) and (CADR(args) = 'nil) => + ms := [CAR getModeSet x for x in args] + if CADR(ms) = '(List (None)) then + ms := [first ms,['List,first ms]] + ms + nargs := #args + v := argCouldBelongToSubdomain(opname,nargs) + mss := NIL + for i in 0..(nargs-1) for x in args repeat + ms := + v.i = 0 => CAR getModeSet x + CAR getModeSetUseSubdomain x + mss := [ms,:mss] + nreverse mss + +argCouldBelongToSubdomain(op, nargs) == + -- this returns a vector containing 0 or ^0 for each argument. + -- if ^0, this indicates that there exists a modemap for the + -- op that needs a subdomain in that position + nargs = 0 => NIL + v := GETZEROVEC nargs + isMap(op) => v + mms := getModemapsFromDatabase(op,nargs) + null mms => v + nargs:=nargs-1 + -- each signature has form + -- [domain of implementation, target, arg1, arg2, ...] + for [sig,cond,:.] in mms repeat + for t in CDDR sig for i in 0..(nargs) repeat + CONTAINEDisDomain(t,cond) => + v.i := 1 + v.i + v + +CONTAINEDisDomain(symbol,cond) == +-- looks for [isSubDomain,symbol,[domain]] in cond: returning T or NIL +-- with domain being one of PositiveInteger and NonNegativeInteger + ATOM cond => false + MEMQ(QCAR cond,'(AND OR and or)) => + or/[CONTAINEDisDomain(symbol, u) for u in QCDR cond] + EQ(QCAR cond,'isDomain) => + EQ(symbol,CADR cond) and PAIRP(dom:=CADDR cond) and + MEMQ(dom,'(PositiveInteger NonNegativeInteger)) + false + +selectDollarMms(dc,name,types1,types2) == + -- finds functions for name in domain dc + isPartialMode dc => throwKeyedMsg("S2IF0001",NIL) + mmS := findFunctionInDomain(name,dc,NIL,types1,types2,'T,'T) => + orderMms(name, mmS,types1,types2,NIL) + if $reportBottomUpFlag then sayMSG + ["%b",'" function not found in ",prefix2String dc,"%d","%l"] + NIL + +selectLocalMms(op,name,types,tar) == + -- partial rewrite, looks now for exact local modemap + mmS:= getLocalMms(name,types,tar) => mmS + obj := getValue op + obj and (objVal obj is ['MAP,:mapDef]) and + analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) + +-- next defn may be better, test when more time. RSS 3/11/94 +-- selectLocalMms(op,name,types,tar) == +-- mmS := getLocalMms(name,types,tar) +-- -- if no target, just return what we got +-- mmS and null tar => mmS +-- matchingMms := nil +-- for mm in mmS repeat +-- [., targ, :.] := mm +-- if tar = targ then matchingMms := cons(mm, matchingMms) +-- -- if we got some exact matchs on the target, return them +-- matchingMms => nreverse matchingMms +-- +-- obj := getValue op +-- obj and (objVal obj is ['MAP,:mapDef]) and +-- analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) + +getLocalMms(name,types,tar) == + -- looks for exact or subsumed local modemap in $e + mmS := NIL + for (mm:=[dcSig,:.]) in get(name,'localModemap,$e) repeat + -- check format and destructure + dcSig isnt [dc,result,:args] => NIL + -- make number of args is correct + #types ^= #args => NIL + -- check for equal or subsumed arguments + subsume := (not $useIntegerSubdomain) or (tar = result) or + get(name,'recursive,$e) + acceptableArgs := + and/[f(b,a,subsume) for a in args for b in types] where + f(x,y,subsume) == + if subsume + then isEqualOrSubDomain(x,y) + else x = y + not acceptableArgs => + -- interpreted maps are ok + dc = 'interpOnly and not($Coerce)=> mmS := [mm,:mmS] + NIL + mmS := [mm,:mmS] + nreverse mmS + +mmCost(name, sig,cond,tar,args1,args2) == + cost := mmCost0(name, sig,cond,tar,args1,args2) + res := CADR sig + res = $PositiveInteger => cost - 2 + res = $NonNegativeInteger => cost - 1 + res = $DoubleFloat => cost + 1 + cost + +mmCost0(name, sig,cond,tar,args1,args2) == + sigArgs := CDDR sig + n:= + null cond => 1 + not (or/cond) => 1 + 0 + + -- try to favor homogeneous multiplication + +--if name = "*" and 2 = #sigArgs and first sigArgs ^= first rest sigArgs then n := n + 1 + + -- because of obscure problem in evalMm, sometimes we will have extra + -- modemaps with the wrong number of arguments if we want to the one + -- with no arguments and the name is overloaded. Thus check for this. + + if args1 then + for x1 in args1 for x2 in args2 for x3 in sigArgs repeat + n := n + + isEqualOrSubDomain(x1,x3) => 0 + topcon := first deconstructT x1 + topcon2 := first deconstructT x3 + topcon = topcon2 => 3 + CAR topcon2 = 'Mapping => 2 + 4 + else if sigArgs then n := n + 100000000000 + + res := CADR sig + res=tar => 10000*n + 10000*n + 1000*domainDepth(res) + hitListOfTarget(res) + +orderMms(name, mmS,args1,args2,tar) == + -- it counts the number of necessary coercions of the argument types + -- if this isn't enough, it compares the target types + mmS and null rest mmS => mmS + mS:= NIL + N:= NIL + for mm in MSORT mmS repeat + [sig,.,cond]:= mm + b:= 'T + p:= CONS(m := mmCost(name, sig,cond,tar,args1,args2),mm) + mS:= + null mS => list p + m < CAAR mS => CONS(p,mS) + S:= mS + until b repeat + b:= null CDR S or m < CAADR S => + RPLACD(S,CONS(p,CDR S)) + S:= CDR S + mS + mmS and [CDR p for p in mS] + +domainDepth(d) == + -- computes the depth of lisp structure d + atom d => 0 + MAX(domainDepth(CAR d)+1,domainDepth(CDR d)) + +hitListOfTarget(t) == + -- assigns a number between 1 and 998 to a type t + + -- want to make it hard to go to Polynomial Pi + + t = '(Polynomial (Pi)) => 90000 + + EQ(CAR t, 'Polynomial) => 300 + EQ(CAR t, 'List) => 400 + EQ(CAR t,'Matrix) => 910 + EQ(CAR t,'UniversalSegment) => 501 + EQ(CAR t,'RationalFunction) => 900 + EQ(CAR t,'Union) => 999 + 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 => + domain := evalDomain dc + for mm in nreverse p until b repeat + [[.,:sig],:.] := mm + b := compiledLookup(op,sig,domain) + b or throwKeyedMsg("S2IS0023",[op,dc]) + + + throwKeyedMsg("S2IF0004",[op,dc]) + +isOpInDomain(opName,dom,nargs) == + -- returns true only if there is an op in the given domain with + -- the given number of arguments + mmList := ASSQ(opName,getOperationAlistFromLisplib CAR dom) + mmList := subCopy(mmList,constructSubst dom) + null mmList => NIL + gotOne := NIL + nargs := nargs + 1 + for mm in CDR mmList while not gotOne repeat + nargs = #CAR mm => gotOne := [mm, :gotOne] + gotOne + +findCommonSigInDomain(opName,dom,nargs) == + -- this looks at all signatures in dom with given opName and nargs + -- number of arguments. If no matches, returns NIL. Otherwise returns + -- a "signature" where a type position is non-NIL only if all + -- signatures shares that type . + CAR(dom) in '(Union Record Mapping) => NIL + mmList := ASSQ(opName,getOperationAlistFromLisplib CAR dom) + mmList := subCopy(mmList,constructSubst dom) + null mmList => NIL + gotOne := NIL + nargs := nargs + 1 + vec := NIL + for mm in CDR mmList repeat + nargs = #CAR mm => + null vec => vec := LIST2VEC CAR mm + for i in 0.. for x in CAR mm repeat + if vec.i and vec.i ^= x then vec.i := NIL + VEC2LIST vec + +findUniqueOpInDomain(op,opName,dom) == + -- return function named op in domain dom if unique, choose one if not + mmList := ASSQ(opName,getOperationAlistFromLisplib CAR dom) + mmList := subCopy(mmList,constructSubst dom) + null mmList => + throwKeyedMsg("S2IS0021",[opName,dom]) + if #CDR mmList > 1 then + mm := selectMostGeneralMm CDR mmList + sayKeyedMsg("S2IS0022",[opName,dom,['Mapping,:CAR mm]]) + else mm := CADR mmList + [sig,slot,:.] := mm + fun := +--+ + $genValue => + compiledLookupCheck(opName,sig,evalDomain dom) + NRTcompileEvalForm(opName, sig, evalDomain dom) + NULL(fun) or NULL(PAIRP(fun)) => NIL + CAR fun = function(Undef) => throwKeyedMsg("S2IS0023",[opName,dom]) + binVal := + $genValue => wrap fun + fun + putValue(op,objNew(binVal,m:=['Mapping,:sig])) + putModeSet(op,[m]) + +selectMostGeneralMm mmList == + -- selects the modemap in mmList with arguments all the other + -- argument types can be coerced to + -- also selects function with #args closest to 2 + min := 100 + mml := mmList + while mml repeat + [mm,:mml] := mml + sz := #CAR mm + if (met := ABS(sz - 3)) < min then + min := met + fsz := sz + mmList := [mm for mm in mmList | (#CAR mm) = fsz] + mml := CDR mmList + genMm := CAR mmList + while mml repeat + [mm,:mml] := mml + and/[canCoerceFrom(genMmArg,mmArg) for mmArg in CDAR mm + for genMmArg in CDAR genMm] => genMm := mm + genMm + +--------------------> NEW DEFINITION (override in xrun.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)) => + -- 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], 6, [NIL, NIL]]] + op = 'coerce => + #args1 ^= 1 or args1.0 ^= dc => NIL + tar and tar ^= $OutputForm => NIL + [[[dc, $OutputForm, dc], 7, [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 + mm:= subCopy(mm,SL) + 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 + mm:= subCopy(mm,SL) + 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 + +allOrMatchingMms(mms,args1,tar,dc) == + -- if there are exact matches on the arg types, return them + -- otherwise return the original list + null mms or null rest mms => mms + x := NIL + for mm in mms repeat + [sig,:.] := mm + [res,:args] := MSUBSTQ(dc,"$",sig) + args ^= args1 => nil + x := CONS(mm,x) + if x then x + else mms + +isHomogeneousList y == + y is [x] => true + y and rest y => + z := CAR y + "and"/[x = z for x in CDR y] + NIL + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +findFunctionInDomain1(mm,op,tar,args1,args2,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 + dc:= CDR ASSQ('$,SL) + [sig,slot,cond,y] := mm + 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),slot,nreverse $RTC]] + EQ(y,'CONST) => [[CONS(dc,sig),slot,nreverse $RTC]] +-- EQ(y,'ASCONST) => [[CONS(dc,sig),slot,nreverse $RTC]] + y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] + sayKeyedMsg("S2IF0006",[y]) + NIL + +--------------------> NEW DEFINITION (override in xrun.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)) => 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 + mm:= subCopy(mm,SL) + 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 + +matchMmCond(cond) == + -- tests the condition, which comes with a modemap + -- cond is 'T or a list, but I hate to test for 'T (ALBI) + $domPvar: local := nil + atom cond or + cond is ['AND,:conds] or cond is ['and,:conds] => + and/[matchMmCond c for c in conds] + cond is ['OR,:conds] or cond is ['or,:conds] => + or/[matchMmCond c for c in conds] + cond is ['has,dom,x] => + hasCaty(dom,x,NIL) ^= 'failed + cond is ['not,cond1] => not matchMmCond cond1 + keyedSystemError("S2GE0016", + ['"matchMmCond",'"unknown form of condition"]) + +matchMmSig(mm,tar,args1,args2) == + -- matches the modemap signature against args1 -> tar + -- if necessary, runtime checks are created for subdomains + -- then the modemap condition is evaluated + [sig,:.]:= mm + if CONTAINED('_#, sig) then + sig := [replaceSharpCalls COPY t for t in sig] + null args1 => matchMmSigTar(tar,CAR sig) + a:= CDR sig + arg:= NIL + for i in 1.. while args1 and args2 and a until not b repeat + x1:= CAR args1 + args1:= CDR args1 + x2:= CAR args2 + args2:= CDR args2 + x:= CAR a + a:= CDR a + rtc:= NIL + if x is ['SubDomain,y,:.] then x:= y + b := isEqualOrSubDomain(x1,x) or + (STRINGP(x) and (x1 is ['Variable,v]) and (x = PNAME v)) or + $SubDom and isSubDomain(x,x1) => rtc:= 'T + $Coerce => x2=x or canCoerceFrom(x1,x) + x1 is ['Variable,:.] and x = '(Symbol) + $RTC:= CONS(rtc,$RTC) + null args1 and null a and b and matchMmSigTar(tar,CAR sig) + +matchMmSigTar(t1,t2) == + -- t1 is a target type specified by :: or by a declared variable + -- t2 is the target of a modemap signature + null t1 or + isEqualOrSubDomain(t2,t1) => true + if t2 is ['Union,a,b] then + if a='"failed" then return matchMmSigTar(t1, b) + if b='"failed" then return matchMmSigTar(t1, a) + $Coerce and + isPartialMode t1 => resolveTM(t2,t1) +-- I think this should be true -SCM +-- true + canCoerceFrom(t2,t1) + +constructSubst(d) == + -- constructs a substitution which substitutes d for $ + -- and the arguments of d for #1, #2 .. + SL:= list CONS('$,d) + for x in CDR d for i in 1.. repeat + SL:= CONS(CONS(INTERNL('"#",STRINGIMAGE i),x),SL) + SL + +filterModemapsFromPackages(mms, names, op) == + -- mms is a list of modemaps + -- names is a list of domain constructors + -- this returns a 2-list containing those modemaps that have one + -- of the names in the package source of the modemap and all the + -- rest of the modemaps in the second element. + good := NIL + bad := NIL + -- hack to speed up factorization choices for mpolys and to overcome + -- some poor naming of packages + mpolys := '("Polynomial" "MultivariatePolynomial" + "DistributedMultivariatePolynomial" + "HomogeneousDistributedMultivariatePolynomial") + mpacks := '("MFactorize" "MRationalFactorize") + for mm in mms repeat + isFreeFunctionFromMm(mm) => bad := cons(mm, bad) + type := getDomainFromMm mm + null type => bad := cons(mm,bad) + if PAIRP type then type := first type + GETDATABASE(type,'CONSTRUCTORKIND) = 'category => bad := cons(mm,bad) + name := object2String type + found := nil + for n in names while not found repeat + STRPOS(n,name,0,NIL) => found := true + -- hack, hack + (op = 'factor) and member(n,mpolys) and member(name,mpacks) => + found := true + if found + then good := cons(mm, good) + else bad := cons(mm,bad) + [good,bad] + + +isTowerWithSubdomain(towerType,elem) == + not PAIRP towerType => NIL + dt := deconstructT towerType + 2 ^= #dt => NIL + s := underDomainOf(towerType) + isEqualOrSubDomain(s,elem) and constructM(first dt,[elem]) + +selectMmsGen(op,tar,args1,args2) == + -- general modemap evaluation of op with argument types args1 + -- evaluates the condition and looks for the slot number + -- returns all functions which are applicable + -- args2 is a list of polynomial types for symbols + $Subst: local := NIL + $SymbolType: local := NIL + + null (S := getModemapsFromDatabase(op,QLENGTH args1)) => NIL + + if (op = 'map) and (2 = #args1) and + (CAR(args1) is ['Mapping,., elem]) and + (a := isTowerWithSubdomain(CADR args1,elem)) + then args1 := [CAR args1,a] + + -- we first split the modemaps into two groups: + -- haves: these are from packages that have one of the top level + -- constructor names in the package name + -- havenots: everything else + + -- get top level constructor names for constructors with parameters + conNames := nil + if op = 'reshape then args := APPEND(rest args1, rest args2) + else args := APPEND(args1,args2) + if tar then args := [tar,:args] + -- for common aggregates, use under domain also + for a in REMDUP args repeat + a => + atom a => nil + fa := QCAR a + fa in '(Record Union) => NIL + conNames := insert(STRINGIMAGE fa, conNames) + + if conNames + then [haves,havenots] := filterModemapsFromPackages(S,conNames,op) + else + haves := NIL + havenots := S + + mmS := NIL + + if $reportBottomUpFlag then + sayMSG ['%l,:bright '"Modemaps from Associated Packages"] + + if haves then + [havesExact,havesInexact] := exact?(haves,tar,args1) where + exact?(mmS,tar,args) == + ex := inex := NIL + for (mm := [sig,[mmC,:.],:.]) in mmS repeat + [c,t,:a] := sig + ok := true + for pat in a for arg in args while ok repeat + not CONTAINED(['isDomain,pat,arg],mmC) => ok := NIL + ok => ex := CONS(mm,ex) + inex := CONS(mm,inex) + [ex,inex] + if $reportBottomUpFlag then + for mm in APPEND(havesExact,havesInexact) for i in 1.. repeat + sayModemapWithNumber(mm,i) + if havesExact then + mmS := matchMms(havesExact,op,tar,args1,args2) where + matchMms(mmaps,op,tar,args1,args2) == + mmS := NIL + for [sig,mmC] in mmaps repeat + -- sig is [dc,result,:args] + $Subst := + tar and not isPartialMode tar => + -- throw in the target if it is not the same as one + -- of the arguments + res := CADR sig + member(res,CDDR sig) => NIL + [[res,:tar]] + NIL + [c,t,:a] := sig + if a then matchTypes(a,args1,args2) + not EQ($Subst,'failed) => + mmS := nconc(evalMm(op,tar,sig,mmC),mmS) + mmS + if mmS then + if $reportBottomUpFlag then + sayMSG '" found an exact match!" + return mmS + mmS := matchMms(havesInexact,op,tar,args1,args2) + else if $reportBottomUpFlag then sayMSG '" no modemaps" + mmS => mmS + + if $reportBottomUpFlag then + sayMSG ['%l,:bright '"Remaining General Modemaps"] + -- for mm in havenots for i in 1.. repeat sayModemapWithNumber(mm,i) + + if havenots then + [havesNExact,havesNInexact] := exact?(havenots,tar,args1) + if $reportBottomUpFlag then + for mm in APPEND(havesNExact,havesNInexact) for i in 1.. repeat + sayModemapWithNumber(mm,i) + if havesNExact then + mmS := matchMms(havesNExact,op,tar,args1,args2) + if mmS then + if $reportBottomUpFlag then + sayMSG '" found an exact match!" + return mmS + mmS := matchMms(havesNInexact,op,tar,args1,args2) + else if $reportBottomUpFlag then sayMSG '" no modemaps" + mmS + +matchTypes(pm,args1,args2) == + -- pm is a list of pattern variables, args1 a list of argument types, + -- args2 a list of polynomial types for symbols + -- the result is a match from pm to args, if one exists + for v in pm for t1 in args1 for t2 in args2 until $Subst='failed repeat + p:= ASSQ(v,$Subst) => + t:= CDR p + t=t1 => $Coerce and EQCAR(t1,'Symbol) and + (q := ASSQ(v,$SymbolType)) and t2 and + (t3 := resolveTT(CDR q, t2)) and + RPLACD(q, t3) + $Coerce => + if EQCAR(t,'Symbol) and (q := ASSQ(v,$SymbolType)) then + t := CDR q + if EQCAR(t1,'Symbol) and t2 then t1:= t2 + t0 := resolveTT(t,t1) => RPLACD(p,t0) + $Subst:= 'failed + $Subst:= 'failed + $Subst:= CONS(CONS(v,t1),$Subst) + if EQCAR(t1,'Symbol) and t2 then $SymbolType:= CONS(CONS(v,t2),$SymbolType) + +evalMm(op,tar,sig,mmC) == + -- evaluates a modemap with signature sig and condition mmC + -- the result is a list of lists [sig,slot,cond] or NIL + --if $Coerce is NIL, tar has to be the same as the computed target type +--if CONTAINED('LinearlyExplicitRingOver,mmC) then hohoho() + mS:= NIL + for st in evalMmStack mmC repeat + SL:= evalMmCond(op,sig,st) + not EQ(SL,'failed) => + SL := fixUpTypeArgs SL + sig:= [subCopy(deepSubCopy(x,SL),$Subst) for x in sig] + not containsVars sig => + isFreeFunctionFromMmCond mmC and (m := evalMmFreeFunction(op,tar,sig,mmC)) => + mS:= nconc(m,mS) + "or"/[^isValidType(arg) for arg in sig] => nil + [dc,t,:args]:= sig + $Coerce or null tar or tar=t => + mS:= nconc(findFunctionInDomain(op,dc,t,args,args,NIL,'T),mS) + mS + +evalMmFreeFunction(op,tar,sig,mmC) == + [dc,t,:args]:= sig + $Coerce or null tar or tar=t => + nilArgs := nil + for a in args repeat nilArgs := [NIL,:nilArgs] + [[[["__FreeFunction__",:dc],t,:args], [t, :args], nilArgs]] + nil + +evalMmStack(mmC) == + -- translates the modemap condition mmC into a list of stacks + mmC is ['AND,:a] => + ["NCONC"/[evalMmStackInner cond for cond in a]] + mmC is ['OR,:args] => [:evalMmStack a for a in args] + mmC is ['partial,:mmD] => evalMmStack mmD + mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] => + evalMmStack CONS('AND,[['ofCategory,pvar,c] for c in args]) + mmC is ['ofType,:.] => [NIL] + mmC is ['has,pat,x] => + MEMQ(x,'(ATTRIBUTE SIGNATURE)) => + [[['ofCategory,pat,['CATEGORY,'unknown,x]]]] + [['ofCategory,pat,x]] + [[mmC]] + +evalMmStackInner(mmC) == + mmC is ['OR,:args] => + keyedSystemError("S2GE0016", + ['"evalMmStackInner",'"OR condition nested inside an AND"]) + mmC is ['partial,:mmD] => evalMmStackInner mmD + mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] => + [['ofCategory, pvar, c] for c in args] + mmC is ['ofType,:.] => NIL + mmC is ['isAsConstant] => NIL + mmC is ['has,pat,x] => + MEMQ(x,'(ATTRIBUTE SIGNATURE)) => + [['ofCategory,pat,['CATEGORY,'unknown,x]]] + [['ofCategory,pat,x]] + [mmC] + +evalMmCond(op,sig,st) == + $insideEvalMmCondIfTrue : local := true + evalMmCond0(op,sig,st) + +evalMmCond0(op,sig,st) == + -- evaluates the nonempty list of modemap conditions st + -- the result is either 'failed or a substitution list + SL:= evalMmDom st + SL='failed => 'failed + for p in SL until p1 and not b repeat b:= + p1:= ASSQ(CAR p,$Subst) + p1 and + t1:= CDR p1 + t:= CDR p + t=t1 or + containsVars t => + if $Coerce and EQCAR(t1,'Symbol) then t1:= getSymbolType CAR p + resolveTM1(t1,t) + $Coerce and + -- if we are looking at the result of a function, the coerce + -- goes the opposite direction + (t1 = $AnonymousFunction and t is ['Mapping, :.]) => t + CAR p = CADR sig and not member(CAR p, CDDR sig) => + canCoerceFrom(t,t1) => 'T + NIL + canCoerceFrom(t1,t) => 'T + isSubDomain(t,t1) => RPLACD(p,t1) + EQCAR(t1,'Symbol) and canCoerceFrom(getSymbolType CAR p,t) + ( SL and p1 and not b and 'failed ) or evalMmCat(op,sig,st,SL) + +fixUpTypeArgs SL == + for (p := [v, :t2]) in SL repeat + t1 := LASSOC(v, $Subst) + null t1 => RPLACD(p,replaceSharpCalls t2) + RPLACD(p, coerceTypeArgs(t1, t2, SL)) + SL + +replaceSharpCalls t == + noSharpCallsHere t => t + doReplaceSharpCalls t + +doReplaceSharpCalls t == + ATOM t => t + t is ['_#, l] => #l + t is ['construct,: l] => EVAL ['LIST,:l] + [CAR t,:[ doReplaceSharpCalls u for u in CDR t]] + +noSharpCallsHere t == + t isnt [con, :args] => true + MEMQ(con,'(construct _#)) => NIL + and/[noSharpCallsHere u for u in args] + +coerceTypeArgs(t1, t2, SL) == + -- if the type t has type-valued arguments, coerce them to the new types, + -- if needed. + t1 isnt [con1, :args1] or t2 isnt [con2, :args2] => t2 + con1 ^= con2 => t2 + coSig := CDR GETDATABASE(CAR t1, 'COSIG) + and/coSig => t2 + csub1 := constructSubst t1 + csub2 := constructSubst t2 + cs1 := CDR getConstructorSignature con1 + cs2 := CDR getConstructorSignature con2 + [con1, : + [makeConstrArg(arg1, arg2, constrArg(c1,csub1,SL), + constrArg(c2,csub2,SL), cs) + for arg1 in args1 for arg2 in args2 for c1 in cs1 for c2 in cs2 + for cs in coSig]] + +constrArg(v,sl,SL) == + x := LASSOC(v,sl) => + y := LASSOC(x,SL) => y + y := LASSOC(x, $Subst) => y + x + y := LASSOC(x, $Subst) => y + v + +makeConstrArg(arg1, arg2, t1, t2, cs) == + if arg1 is ['_#, l] then arg1 := # l + if arg2 is ['_#, l] then arg2 := # l + cs => arg2 + t1 = t2 => arg2 + obj1 := objNewWrap(arg1, t1) + obj2 := coerceInt(obj1, t2) + null obj2 => throwKeyedMsgCannotCoerceWithValue(wrap arg1,t1,t2) + objValUnwrap obj2 + +evalMmDom(st) == + -- evals all isDomain(v,d) of st + SL:= NIL + for mmC in st until SL='failed repeat + mmC is ['isDomain,v,d] => + STRINGP d => SL:= 'failed + p:= ASSQ(v,SL) and not (d=CDR p) => SL:= 'failed + d1:= subCopy(d,SL) + CONSP(d1) and MEMQ(v,d1) => SL:= 'failed + SL:= augmentSub(v,d1,SL) + mmC is ['isFreeFunction,v,fun] => + SL:= augmentSub(v,subCopy(fun,SL),SL) + SL + +orderMmCatStack st == + -- tries to reorder stack so that free pattern variables appear + -- as parameters first + null(st) or null rest(st) => st + vars := DELETE_-DUPLICATES [CADR(s) for s in st | isPatternVar(CADR(s))] + null vars => st + havevars := nil + haventvars := nil + for s in st repeat + cat := CADDR s + mem := nil + for v in vars while not mem repeat + if MEMQ(v,cat) then + mem := true + havevars := cons(s,havevars) + if not mem then haventvars := cons(s,haventvars) + null havevars => st + st := nreverse nconc(haventvars,havevars) + SORT(st, function mmCatComp) + +mmCatComp(c1, c2) == + b1 := ASSQ(CADR c1, $Subst) + b2 := ASSQ(CADR c2, $Subst) + b1 and null(b2) => true + false + +evalMmCat(op,sig,stack,SL) == + -- evaluates all ofCategory's of stack as soon as possible + $hope:local:= NIL + numConds:= #stack + stack:= orderMmCatStack [mmC for mmC in stack | EQCAR(mmC,'ofCategory)] + while stack until not makingProgress repeat + st := stack + stack := NIL + makingProgress := NIL + for mmC in st repeat + S:= evalMmCat1(mmC,op, SL) + S='failed and $hope => + stack:= CONS(mmC,stack) + S = 'failed => return S + not atom S => + makingProgress:= 'T + SL:= mergeSubs(S,SL) + if stack or S='failed then 'failed else SL + +evalMmCat1(mmC is ['ofCategory,d,c],op, SL) == + -- evaluates mmC using information from the lisplib + -- d may contain variables, and the substitution list $Subst is used + -- the result is a substitution or failed + $domPvar: local := NIL + $hope:= NIL + NSL:= hasCate(d,c,SL) + NSL='failed and isPatternVar d and $Coerce and ( p:= ASSQ(d,$Subst) ) + and (EQCAR(CDR p,'Variable) or EQCAR(CDR p,'Symbol)) => + RPLACD(p,getSymbolType d) + hasCate(d,c,SL) + NSL='failed and isPatternVar d => + -- following is hack to take care of the case where we have a + -- free substitution variable with a category condition on it. + -- This would arise, for example, where a package has an argument + -- that is not in a needed modemap. After making the following + -- dummy substitutions, the package can be instantiated and the + -- modemap used. RSS 12-22-85 + -- If c is not Set, Ring or Field then the more general mechanism + dom := defaultTypeForCategory(c, SL) + null dom => + op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) + null (p := ASSQ(d,$Subst)) => + dom => + NSL := [CONS(d,dom)] + op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) + if containsVars dom then dom := resolveTM(CDR p, dom) + $Coerce and canCoerce(CDR p, dom) => + NSL := [CONS(d,dom)] + op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) + NSL + +hasCate(dom,cat,SL) == + -- asks whether dom has cat under SL + -- augments substitution SL or returns 'failed + dom = $EmptyMode => NIL + isPatternVar dom => + (p:= ASSQ(dom,SL)) and ((NSL := hasCate(CDR p,cat,SL)) ^= 'failed) => + NSL + (p:= ASSQ(dom,$Subst)) or (p := ASSQ(dom, SL)) => +-- S:= hasCate(CDR p,cat,augmentSub(CAR p,CDR p,copy SL)) + S:= hasCate1(CDR p,cat,SL, dom) + not (S='failed) => S + hasCateSpecial(dom,CDR p,cat,SL) + if SL ^= 'failed then $hope:= 'T + 'failed + SL1 := [[v,:d] for [v,:d] in SL | not containsVariables d] + if SL1 then cat := subCopy(cat, SL1) + hasCaty(dom,cat,SL) + +hasCate1(dom, cat, SL, domPvar) == + $domPvar:local := domPvar + hasCate(dom, cat, SL) + +hasCateSpecial(v,dom,cat,SL) == + -- v is a pattern variable, dom it's binding under $Subst + -- tries to change dom, so that it has category cat under SL + -- the result is a substitution list or 'failed + dom is ['FactoredForm,arg] => + if isSubDomain(arg,$Integer) then arg := $Integer + d := ['FactoredRing,arg] + SL:= hasCate(arg,'(Ring),augmentSub(v,d,SL)) + SL = 'failed => 'failed + hasCaty(d,cat,SL) + EQCAR(cat,'Field) or EQCAR(cat, 'DivisionRing) => + if isSubDomain(dom,$Integer) then dom := $Integer + d:= eqType [$QuotientField, dom] + hasCaty(dom,'(IntegralDomain),augmentSub(v,d,SL)) + cat is ['PolynomialCategory, d, :.] => + dom' := ['Polynomial, d] + (containsVars d or canCoerceFrom(dom, dom')) + and hasCaty(dom', cat, augmentSub(v,dom',SL)) + isSubDomain(dom,$Integer) => + NSL:= hasCate($Integer,cat,augmentSub(v,$Integer,SL)) + NSL = 'failed => + hasCateSpecialNew(v, dom, cat, SL) + hasCaty($Integer,cat,NSL) + hasCateSpecialNew(v, dom, cat, SL) + +-- to be used in $newSystem only +hasCateSpecialNew(v,dom,cat,SL) == + fe := member(QCAR cat, '(ElementaryFunctionCategory + TrigonometricFunctionCategory ArcTrigonometricFunctionCategory + HyperbolicFunctionCategory ArcHyperbolicFunctionCategory + PrimitiveFunctionCategory SpecialFunctionCategory Evalable + CombinatorialOpsCategory TranscendentalFunctionCategory + AlgebraicallyClosedFunctionSpace ExpressionSpace + LiouvillianFunctionCategory FunctionSpace)) + alg := member(QCAR cat, '(RadicalCategory AlgebraicallyClosedField)) + fefull := fe or alg or EQCAR(cat, 'CombinatorialFunctionCategory) + partialResult := + EQCAR(dom, 'Variable) or EQCAR(dom, 'Symbol) => + CAR(cat) in + '(SemiGroup AbelianSemiGroup Monoid AbelianGroup AbelianMonoid + PartialDifferentialRing Ring InputForm) => + d := ['Polynomial, $Integer] + augmentSub(v, d, SL) + EQCAR(cat, 'Group) => + d := ['Fraction, ['Polynomial, $Integer]] + augmentSub(v, d, SL) + fefull => + d := defaultTargetFE dom + augmentSub(v, d, SL) + 'failed + isEqualOrSubDomain(dom, $Integer) => + fe => + d := defaultTargetFE $Integer + augmentSub(v, d, SL) + alg => + d := '(AlgebraicNumber) + --d := defaultTargetFE $Integer + augmentSub(v, d, SL) + 'failed + underDomainOf dom = $ComplexInteger => + d := defaultTargetFE $ComplexInteger + hasCaty(d,cat,augmentSub(v, d, SL)) + (dom = $RationalNumber) and alg => + d := '(AlgebraicNumber) + --d := defaultTargetFE $Integer + augmentSub(v, d, SL) + fefull => + d := defaultTargetFE dom + augmentSub(v, d, SL) + 'failed + partialResult = 'failed => 'failed + hasCaty(d, cat, partialResult) + +hasCaty(d,cat,SL) == + -- calls hasCat, which looks up a hashtable and returns: + -- 1. T, NIL or a (has x1 x2) condition, if cat is not parameterized + -- 2. a list of pairs (argument to cat,condition) otherwise + -- then the substitution SL is augmented, or the result is 'failed + cat is ['CATEGORY,.,:y] => hasAttSig(d,subCopy(y,constructSubst d),SL) + cat is ['SIGNATURE,foo,sig] => + hasSig(d,foo,subCopy(sig,constructSubst d),SL) + cat is ['ATTRIBUTE,a] => hasAtt(d,subCopy(a,constructSubst d),SL) + x:= hasCat(opOf d,opOf cat) => + y:= KDR cat => + S := constructSubst d + for [z,:cond] in x until not (S1='failed) repeat + S' := [[p, :mkDomPvar(p, d, z, y)] for [p,:d] in S] + if $domPvar then + dom := [CAR d, :[domArg(arg, i, z, y) for i in 0.. + for arg in CDR d]] + SL := augmentSub($domPvar, dom, copy SL) + z' := [domArg2(a, S, S') for a in z] + S1:= unifyStruct(y,z',copy SL) + if not (S1='failed) then S1:= + atom cond => S1 + ncond := subCopy(cond, S) + ncond is ['has, =d, =cat] => 'failed + hasCaty1(ncond,S1) + S1 + atom x => SL + ncond := subCopy(x, constructSubst d) + ncond is ['has, =d, =cat] => 'failed + hasCaty1(ncond, SL) + 'failed + +mkDomPvar(p, d, subs, y) == + l := MEMQ(p, $FormalMapVariableList) => + domArg(d, #$FormalMapVariableList - #l, subs, y) + d + +domArg(type, i, subs, y) == + p := MEMQ($FormalMapVariableList.i, subs) => + y.(#subs - #p) + type + +domArg2(arg, SL1, SL2) == + isSharpVar arg => subCopy(arg, SL1) + arg = '_$ and $domPvar => $domPvar + subCopy(arg, SL2) + +hasCaty1(cond,SL) == + -- cond is either a (has a b) or an OR clause of such conditions + -- SL is augmented, if cond is true, otherwise the result is 'failed + $domPvar: local := NIL + cond is ['has,a,b] => hasCate(a,b,SL) + cond is ['AND,:args] => + for x in args while not (S='failed) repeat S:= + x is ['has,a,b] => hasCate(a,b, SL) + -- next line is for an obscure bug in the table + x is [['has,a,b]] => hasCate(a,b, SL) + --'failed + hasCaty1(x, SL) + S + cond is ['OR,:args] => + for x in args until not (S='failed) repeat S:= + x is ['has,a,b] => hasCate(a,b,copy SL) + -- next line is for an obscure bug in the table + x is [['has,a,b]] => hasCate(a,b,copy SL) + --'failed + hasCaty1(x, copy SL) + S + keyedSystemError("S2GE0016", + ['"hasCaty1",'"unexpected condition from category table"]) + +hasAttSig(d,x,SL) == + -- d is domain, x a list of attributes and signatures + -- the result is an augmented SL, if d has x, 'failed otherwise + for y in x until SL='failed repeat SL:= + y is ['ATTRIBUTE,a] => hasAtt(d,a,SL) + y is ['SIGNATURE,foo,s] => hasSig(d,foo,s,SL) + keyedSystemError("S2GE0016", + ['"hasAttSig",'"unexpected form of unnamed category"]) + SL + +hasSigAnd(andCls, S0, SL) == + dead := NIL + SA := 'failed + for cls in andCls while not dead repeat + SA := + atom cls => copy SL + cls is ['has,a,b] => + hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) + keyedSystemError("S2GE0016", + ['"hasSigAnd",'"unexpected condition for signature"]) + if SA = 'failed then dead := true + SA + +hasSigOr(orCls, S0, SL) == + found := NIL + SA := 'failed + for cls in orCls until found repeat + SA := + atom cls => copy SL + cls is ['has,a,b] => + hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) + cls is ['AND,:andCls] or cls is ['and,:andCls] => + hasSigAnd(andCls, S0, SL) + keyedSystemError("S2GE0016", + ['"hasSigOr",'"unexpected condition for signature"]) + if SA ^= 'failed then found := true + SA + +hasSig(dom,foo,sig,SL) == + -- tests whether domain dom has function foo with signature sig + -- under substitution SL + $domPvar: local := nil + fun:= constructor? CAR dom => + S0:= constructSubst dom + p := ASSQ(foo,getOperationAlistFromLisplib CAR dom) => + for [x,.,cond,.] in CDR p until not (S='failed) repeat + S:= + atom cond => copy SL + cond is ['has,a,b] => + hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) + cond is ['AND,:andCls] or cond is ['and,:andCls] => + hasSigAnd(andCls, S0, SL) + cond is ['OR,:orCls] or cond is ['or,:orCls] => + hasSigOr(orCls, S0, SL) + keyedSystemError("S2GE0016", + ['"hasSig",'"unexpected condition for signature"]) + not (S='failed) => S:= unifyStruct(subCopy(x,S0),sig,S) + S + 'failed + 'failed + +hasAtt(dom,att,SL) == + -- tests whether dom has attribute att under SL + -- needs S0 similar to hasSig above ?? + $domPvar: local := nil + fun:= CAR dom => + atts:= subCopy(GETDATABASE(fun,'ATTRIBUTES),constructSubst dom) => + PAIRP (u := getInfovec CAR dom) => + --UGH! New world has attributes stored as pairs not as lists!! + for [x,:cond] in atts until not (S='failed) repeat + S:= unifyStruct(x,att,copy SL) + not atom cond and not (S='failed) => S := hasCatExpression(cond,S) + S + for [x,cond] in atts until not (S='failed) repeat + S:= unifyStruct(x,att,copy SL) + not atom cond and not (S='failed) => S := hasCatExpression(cond,S) + S + 'failed + 'failed + +hasCatExpression(cond,SL) == + cond is ['OR,:l] => + or/[(y:=hasCatExpression(x,SL)) ^= 'failed for x in l] => y + cond is ['AND,:l] => + and/[(SL:= hasCatExpression(x,SL)) ^= 'failed for x in l] => SL + cond is ['has,a,b] => hasCate(a,b,SL) + keyedSystemError("S2GE0016", + ['"hasSig",'"unexpected condition for attribute"]) + +unifyStruct(s1,s2,SL) == + -- tests for equality of s1 and s2 under substitutions SL and $Subst + -- the result is a substitution list or 'failed + s1=s2 => SL + if s1 is ['_:,x,.] then s1:= x + if s2 is ['_:,x,.] then s2:= x + if ^atom s1 and CAR s1 = '_# then s1:= LENGTH CADR s1 + if ^atom s2 and CAR s2 = '_# then s2:= LENGTH CADR s2 + s1=s2 => SL + isPatternVar s1 => unifyStructVar(s1,s2,SL) + isPatternVar s2 => unifyStructVar(s2,s1,SL) + atom s1 or atom s2 => 'failed + until null s1 or null s2 or SL='failed repeat + SL:= unifyStruct(CAR s1,CAR s2,SL) + s1:= CDR s1 + s2:= CDR s2 + s1 or s2 => 'failed + SL + +unifyStructVar(v,s,SL) == + -- the first argument is a pattern variable, which is not substituted + -- by SL + CONTAINED(v,s) => 'failed + ps := LASSOC(s, SL) + s1 := (ps => ps; s) + (s0 := LASSOC(v, SL)) or (s0 := LASSOC(v,$Subst)) => + S:= unifyStruct(s0,s1,copy SL) + S='failed => + $Coerce and not atom s0 and constructor? CAR s0 => + containsVars s0 or containsVars s1 => + ns0 := subCopy(s0, SL) + ns1 := subCopy(s1, SL) + containsVars ns0 or containsVars ns1 => + $hope:= 'T + 'failed + if canCoerce(ns0, ns1) then s3 := s1 + else if canCoerce(ns1, ns0) then s3 := s0 + else s3 := nil + s3 => + if (s3 ^= s0) then SL := augmentSub(v,s3,SL) + if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) + SL + 'failed + $domPvar => + s3 := resolveTT(s0,s1) + s3 => + if (s3 ^= s0) then SL := augmentSub(v,s3,SL) + if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) + SL + 'failed +-- isSubDomain(s,s0) => augmentSub(v,s0,SL) + 'failed + 'failed + augmentSub(v,s,S) + augmentSub(v,s,SL) + +ofCategory(dom,cat) == + -- entry point to category evaluation from other points than type + -- analysis + -- the result is true or NIL + $Subst:local:= NIL + $hope:local := NIL + IDENTP dom => NIL + cat is ['Join,:cats] => and/[ofCategory(dom,c) for c in cats] + (hasCaty(dom,cat,NIL) ^= 'failed) + +printMms(mmS) == + -- mmS a list of modemap signatures + sayMSG '" " + for [sig,imp,.] in mmS for i in 1.. repeat + istr := STRCONC('"[",STRINGIMAGE i,'"]") + if QCSIZE(istr) = 3 then istr := STRCONC(istr,'" ") + sayMSG [:bright istr,'"signature: ",:formatSignature CDR sig] + CAR sig='local => + sayMSG ['" implemented: local function ",imp] + imp is ['XLAM,:.] => + sayMSG concat('" implemented: XLAM from ", + prefix2String CAR sig) + sayMSG concat('" implemented: slot ",imp, + '" from ",prefix2String CAR sig) + sayMSG '" " + +containsVars(t) == + -- tests whether term t contains a * variable + atom t => isPatternVar t + containsVars1(t) + +containsVars1(t) == + -- recursive version, which works on a list + [t1,:t2]:= t + atom t1 => + isPatternVar t1 or + atom t2 => isPatternVar t2 + containsVars1(t2) + containsVars1(t1) or + atom t2 => isPatternVar t2 + containsVars1(t2) + +<<isPartialMode>> + +getSymbolType var == +-- var is a pattern variable + p:= ASSQ(var,$SymbolType) => CDR p + t:= '(Polynomial (Integer)) + $SymbolType:= CONS(CONS(var,t),$SymbolType) + t + +isEqualOrSubDomain(d1,d2) == + -- last 2 parts are for tagged unions (hack for now, RSS) + (d1=d2) or isSubDomain(d1,d2) or + (atom(d1) and ((d2 is ['Variable,=d1]) or (d2 is [=d1]))) + or (atom(d2) and ((d1 is ['Variable,=d2]) or (d1 is [=d2]))) + +defaultTypeForCategory(cat, SL) == + -- this function returns a domain belonging to cat + -- note that it is important to note that in some contexts one + -- might not want to use this result. For example, evalMmCat1 + -- calls this and should possibly fail in some cases. + cat := subCopy(cat, SL) + c := CAR cat + d := GETDATABASE(c, 'DEFAULTDOMAIN) + d => [d, :CDR cat] + cat is [c] => + c = 'Field => $RationalNumber + c in '(Ring IntegralDomain EuclideanDomain GcdDomain + OrderedRing DifferentialRing) => '(Integer) + c = 'OrderedSet => $Symbol + c = 'FloatingPointSystem => '(Float) + NIL + cat is [c,p1] => + c = 'FiniteLinearAggregate => ['Vector, p1] + c = 'VectorCategory => ['Vector, p1] + c = 'SetAggregate => ['Set, p1] + c = 'SegmentCategory => ['Segment, p1] + NIL + cat is [c,p1,p2] => + NIL + cat is [c,p1,p2,p3] => + cat is ['MatrixCategory, d, ['Vector, =d], ['Vector, =d]] => + ['Matrix, d] + NIL + NIL + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |