diff --git a/changelog b/changelog index cea806d..4951176 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090821 tpd src/axiom-website/patches.html 20090821.05.tpd.patch +20090821 tpd src/interp/Makefile move i-funsel.boot to i-funsel.lisp +20090821 tpd src/interp/i-funsel.lisp added, rewritten from i-funsel.boot +20090821 tpd src/interp/i-funsel.boot removed, rewritten to i-funsel.lisp 20090821 tpd src/axiom-website/patches.html 20090821.04.tpd.patch 20090821 tpd src/interp/Makefile move i-intern.boot to i-intern.lisp 20090821 tpd src/interp/i-intern.lisp added, rewritten from i-intern.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index e059301..a7c5e57 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1832,5 +1832,7 @@ parsing.lisp missing @ at end of source
bookvol10.4, unittest2 fix credits output
20090821.04.tpd.patch i-intern.lisp rewrite from boot to lisp
+20090821.05.tpd.patch +i-funsel.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 0482eb4..4b550b8 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -427,7 +427,6 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ - ${DOC}/i-funsel.boot.dvi \ ${DOC}/i-map.boot.dvi ${DOC}/incl.boot.dvi \ ${DOC}/info.boot.dvi ${DOC}/interop.boot.dvi \ ${DOC}/intfile.boot.dvi \ @@ -3144,47 +3143,27 @@ ${MID}/i-eval.lisp: ${IN}/i-eval.lisp.pamphlet @ -\subsection{i-funsel.boot} +\subsection{i-funsel.lisp} <>= -${OUT}/i-funsel.${O}: ${MID}/i-funsel.clisp - @ echo 294 making ${OUT}/i-funsel.${O} from ${MID}/i-funsel.clisp - @ (cd ${MID} ; \ +${OUT}/i-funsel.${O}: ${MID}/i-funsel.lisp + @ echo 136 making ${OUT}/i-funsel.${O} from ${MID}/i-funsel.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-funsel.clisp"' \ + echo '(progn (compile-file "${MID}/i-funsel.lisp"' \ ':output-file "${OUT}/i-funsel.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-funsel.clisp"' \ + echo '(progn (compile-file "${MID}/i-funsel.lisp"' \ ':output-file "${OUT}/i-funsel.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-funsel.clisp: ${IN}/i-funsel.boot.pamphlet - @ echo 295 making ${MID}/i-funsel.clisp \ - from ${IN}/i-funsel.boot.pamphlet +<>= +${MID}/i-funsel.lisp: ${IN}/i-funsel.lisp.pamphlet + @ echo 137 making ${MID}/i-funsel.lisp from \ + ${IN}/i-funsel.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-funsel.boot.pamphlet >i-funsel.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-funsel.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-funsel.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-funsel.boot ) - -@ -<>= -${DOC}/i-funsel.boot.dvi: ${IN}/i-funsel.boot.pamphlet - @echo 296 making ${DOC}/i-funsel.boot.dvi \ - from ${IN}/i-funsel.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-funsel.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-funsel.boot ; \ - rm -f ${DOC}/i-funsel.boot.pamphlet ; \ - rm -f ${DOC}/i-funsel.boot.tex ; \ - rm -f ${DOC}/i-funsel.boot ) + ${TANGLE} ${IN}/i-funsel.lisp.pamphlet >i-funsel.lisp ) @ @@ -6528,8 +6507,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet deleted file mode 100644 index b388591..0000000 --- a/src/interp/i-funsel.boot.pamphlet +++ /dev/null @@ -1,1839 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-funsel.boot} -\author{The Axiom Team} -\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 m == - CONTAINED($EmptyMode,m) - -@ -\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. - -@ -<<*>>= -<> - -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 assigns a penalty to each signature according to the following -formula: -\begin{verbatim} - 10000*n + 1000*domainDepth(res) + hitListOfTargets(res) -\end{verbatim} -where: -\begin{itemize} -\item {\bf n} is a penalty taking into account the number of coercions -necessary to coerce the types of the given arguments to those of the -signature under consideration. -\item {\bf res} is the codomain of the signature -\item {\bf hitListOfTarget} assigns a penalty between 1 and 1600 using -a short list of constructors: Polynomial (300), List (400), 500 is the -default, UniversalSegment (501), RationalFunction (900), Matrix (910), -Union (999), Expression (1600). Note that RationalFunction is actually -not a domain, so it should never happen. -\item {\bf domainDepth} calculates the maximal depth of the type -\item {\bf finally} the preference order of PI, NNI, and DFLOAT as -targets is done at the very end. -\end{itemize} -In particular, note that if we have two signatures taking types A and B, -and the given argument does not match exactly but has to be coerced, then -the types A and B themselves are not sorted by preference. -<<*>>= -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 - if $reportBottomUpFlag then - sayMSG ['"cost=",prefix2String cost,'" for ", name,'": ",_ - :formatSignature CDR sig] - 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 - -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) => - 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]) - -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 - -findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == - -- looks for a modemap for op with signature args1 -> tar - -- in the domain of computation dc - -- tar may be NIL (= unknown) - null isLegitimateMode(tar, nil, nil) => nil - dcName:= CAR dc - member(dcName,'(Union Record Mapping Enumeration)) => - -- First cut code that ignores args2, $Coerce and $SubDom - -- When domains no longer have to have Set, the hard coded 6 and 7 - -- should go. - op = '_= => - #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL - tar and tar ^= '(Boolean) => NIL - [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]] - op = 'coerce => - dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> - [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] - args1.0 ^= dc => NIL - tar and tar ^= $Expression => NIL - [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] - member(dcName,'(Record Union)) => - findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) - NIL - fun:= NIL - ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and - SL := constructSubst dc - -- if the arglist is homogeneous, first look for homogeneous - -- functions. If we don't find any, look at remaining ones - if isHomogeneousList args1 then - q := NIL - r := NIL - for mm in CDR p repeat - -- CDAR of mm is the signature argument list - if isHomogeneousList CDAR mm then q := [mm,:q] - else r := [mm,:r] - q := allOrMatchingMms(q,args1,tar,dc) - for mm in q repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - r := reverse r - else r := CDR p - r := allOrMatchingMms(r,args1,tar,dc) - if not fun then -- consider remaining modemaps - for mm in r repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - if not fun and $reportBottomUpFlag then - sayMSG concat - ['" -> no appropriate",:bright op,'"found in", - :bright prefix2String dc] - fun - -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 - -findFunctionInDomain1(omm,op,tar,args1,args2,SL) == - dc:= CDR (dollarPair := ASSQ('$,SL)) - -- need to drop '$ from SL - mm:= subCopy(omm, SL) - -- tests whether modemap mm is appropriate for the function - -- defined by op, target type tar and argument types args - $RTC:local:= NIL - -- $RTC is a list of run-time checks to be performed - - [sig,slot,cond,y] := mm - [osig,:.] := omm - osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL)) - if CONTAINED('_#, sig) or CONTAINED('construct, sig) then - sig := [replaceSharpCalls t for t in sig] - matchMmCond cond and matchMmSig(mm,tar,args1,args2) and - EQ(y,'Subsumed) and - -- hmmmm: do Union check in following because (as in DP) - -- Unions are subsumed by total modemaps which are in the - -- mm list in findFunctionInDomain. - y := 'ELT -- if subsumed fails try it again - not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and - (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f - EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]] - EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]] - EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]] - y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] - sayKeyedMsg("S2IF0006",[y]) - NIL - -findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == - -- looks for a modemap for op with signature args1 -> tar - -- in the domain of computation dc - -- tar may be NIL (= unknown) - dcName:= CAR dc - not MEMQ(dcName,'(Record Union Enumeration)) => NIL - fun:= NIL - -- cat := constructorCategory dc - makeFunc := GET(dcName,"makeFunctionList") or - systemErrorHere '"findFunctionInCategory" - [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) - -- get list of implementations and remove sharps - maxargs := -1 - impls := nil - for [a,b,d] in funlist repeat - not EQ(a,op) => nil - d is ['XLAM,xargs,:.] => - if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) - else maxargs := MAX(maxargs,1) - impls := cons([b,nil,true,d],impls) - impls := cons([b,d,true,d],impls) - impls := NREVERSE impls - if maxargs ^= -1 then - SL:= NIL - for i in 1..maxargs repeat - impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) - impls and - SL:= constructSubst dc - for mm in impls repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - if not fun and $reportBottomUpFlag then - sayMSG concat - ['" -> no appropriate",:bright op,'"found in", - :bright prefix2String dc] - fun - -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) - -<> - -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} diff --git a/src/interp/i-funsel.lisp.pamphlet b/src/interp/i-funsel.lisp.pamphlet new file mode 100644 index 0000000..d7aa652 --- /dev/null +++ b/src/interp/i-funsel.lisp.pamphlet @@ -0,0 +1,6205 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-funsel.lisp} +\author{The Axiom Team} +\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 m == + CONTAINED($EmptyMode,m) + +<<*>>= +(IN-PACKAGE "BOOT" ) + +;SETANDFILEQ($constructorExposureList, '(Boolean Integer String)) + +(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 + +(DEFUN |sayFunctionSelection| (|op| |args| |target| |dc| |func|) + (PROG (|$abbreviateTypes| |fsig|) + (DECLARE (SPECIAL |$abbreviateTypes|)) + (RETURN + (PROGN + (SPADLET |$abbreviateTypes| (QUOTE T)) + (|startTimingProcess| (QUOTE |debug|)) + (SPADLET |fsig| (|formatSignatureArgs| |args|)) + (COND ((NULL (LISTP |fsig|)) (SPADLET |fsig| (LIST |fsig|)))) + (COND (|func| (SPADLET |func| (|bright| (CONS "by " (CONS |func| NIL)))))) + (|sayMSG| + (|concat| + (CONS (QUOTE |%l|) + (APPEND (|bright| "Function Selection for") + (CONS |op| + (APPEND |func| + (CONS (QUOTE |%l|) (CONS " Arguments:" (|bright| |fsig|))))))))) + (COND + (|target| + (|sayMSG| + (|concat| + (CONS " Target type:" (|bright| (|prefix2String| |target|))))))) + (COND + (|dc| + (|sayMSG| + (|concat| + (CONS " From: " (|bright| (|prefix2String| |dc|))))))) + (|stopTimingProcess| (QUOTE |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 + +(DEFUN |sayFunctionSelectionResult| (|op| |args| |mmS|) + (PROG (|$abbreviateTypes|) + (DECLARE (SPECIAL |$abbreviateTypes|)) + (RETURN + (PROGN + (SPADLET |$abbreviateTypes| (QUOTE T)) + (|startTimingProcess| (QUOTE |debug|)) + (COND + (|mmS| (|printMms| |mmS|)) + ((QUOTE T) + (|sayMSG| + (|concat| + (CONS " -> no function" + (APPEND (|bright| |op|) + (CONS "found for arguments" + (|bright| (|formatSignatureArgs| |args|))))))))) + (|stopTimingProcess| (QUOTE |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 + +(DEFUN |selectMms| (|op| |args| |$declaredMode|) + (DECLARE (SPECIAL |$declaredMode|)) + (PROG (|n| |opMode| |ta| |imp| |ISTMP#1| |f| |numArgs| |tree| |ut| |ua| + |val| |types1| |dc| |identType| |types2| |tar| |mmS|) + (RETURN + (SEQ + (PROGN + (|startTimingProcess| (QUOTE |modemaps|)) + (SPADLET |n| (|getUnname| |op|)) + (SPADLET |val| (|getValue| |op|)) + (SPADLET |opMode| (|objMode| |val|)) + (COND + ((AND + (OR (AND (|isSharpVarWithNum| |n|) |opMode|) (AND |val| |opMode|)) + (PAIRP |opMode|) + (EQ (QCAR |opMode|) (QUOTE |Mapping|)) + (PROGN (SPADLET |ta| (QCDR |opMode|)) (QUOTE T))) + (SPADLET |imp| + (COND (|val| (|wrapped2Quote| (|objVal| |val|))) ((QUOTE T) |n|))) + (CONS + (CONS (CONS (QUOTE |local|) |ta|) (CONS |imp| (CONS NIL NIL))) + NIL)) + ((AND + (OR (AND (|isSharpVarWithNum| |n|) |opMode|) (AND |val| |opMode|)) + (PAIRP |opMode|) + (EQ (QCAR |opMode|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |opMode|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |f| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|emptyAtree| |op|) + (SETELT |op| 0 |f|) + (|selectMms| |op| |args| |$declaredMode|)) + ((AND + (|isSharpVarWithNum| |n|) + (PAIRP |opMode|) + (EQ (QCAR |opMode|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |opMode|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |f| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SETELT |op| 0 |f|) + (|selectMms| |op| |args| |$declaredMode|)) + ((QUOTE T) + (SPADLET |types1| (|getOpArgTypes| |n| |args|)) + (SPADLET |numArgs| (|#| |args|)) + (COND + ((|member| (QUOTE (|SubDomain| (|Domain|))) |types1|) NIL) + ((|member| (QUOTE (|Domain|)) |types1|) NIL) + ((|member| |$EmptyMode| |types1|) NIL) + ((QUOTE T) + (SPADLET |tar| (|getTarget| |op|)) + (SPADLET |dc| (|getAtree| |op| (QUOTE |dollar|))) + (COND + ((AND (NULL |dc|) + |val| + (BOOT-EQUAL (|objMode| |val|) |$AnonymousFunction|)) + (SPADLET |tree| (|mkAtree| (|objValUnwrap| (|getValue| |op|)))) + (|putTarget| |tree| (CONS (QUOTE |Mapping|) (CONS |tar| |types1|))) + (|bottomUp| |tree|) + (SPADLET |val| (|getValue| |tree|)) + (CONS + (CONS + (CONS (QUOTE |local|) (CDR (|objMode| |val|))) + (CONS (|wrapped2Quote| (|objVal| |val|)) (CONS NIL NIL))) + NIL)) + ((QUOTE T) + (COND + ((AND + (BOOT-EQUAL |n| (QUOTE |map|)) + (BOOT-EQUAL (CAR |types1|) |$AnonymousFunction|)) + (SPADLET |tree| + (|mkAtree| (|objValUnwrap| (|getValue| (CAR |args|))))) + (SPADLET |ut| + (COND (|tar| (|underDomainOf| |tar|)) ((QUOTE T) NIL))) + (SPADLET |ua| + (PROG (#0=#:G166098) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166103 (CDR |types1|) (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|underDomainOf| |x|) #0#)))))))) + (COND + ((|member| NIL |ua|) NIL) + ((QUOTE T) + (|putTarget| |tree| (CONS (QUOTE |Mapping|) (CONS |ut| |ua|))) + (|bottomUp| |tree|) + (SPADLET |val| (|getValue| |tree|)) + (SPADLET |types1| (CONS (|objMode| |val|) (CDR |types1|))) + (RPLACA |args| |tree|))))) + (COND + ((AND + (EQL |numArgs| 1) + (OR + (BOOT-EQUAL |n| (QUOTE |numer|)) + (BOOT-EQUAL |n| (QUOTE |denom|))) + (|isEqualOrSubDomain| (CAR |types1|) |$Integer|) + (NULL |dc|)) + (SPADLET |dc| (CONS (QUOTE |Fraction|) (CONS |$Integer| NIL))) + (|putAtree| |op| (QUOTE |dollar|) |dc|))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelection| |n| |types1| |tar| |dc| NIL))) + (SPADLET |identType| (QUOTE |Variable|)) + (SEQ + (DO ((#2=#:G166113 |types1| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL) + (NULL (NULL |$declaredMode|))) + NIL) + (SEQ + (EXIT + (COND + ((NULL (EQCAR |x| |identType|)) + (EXIT (SPADLET |$declaredMode| |x|))))))) + (SPADLET |types2| + (PROG (#3=#:G166125) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166131 |types1| (CDR #4#)) + (|x| NIL) + (#5=#:G166132 |args| (CDR #5#)) + (|y| NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ |x| (CAR #4#)) NIL) + (ATOM #5#) + (PROGN (SETQ |y| (CAR #5#)) NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS (|altTypeOf| |x| |y| |$declaredMode|) #3#)))))))) + (SPADLET |mmS| + (COND + (|dc| (|selectDollarMms| |dc| |n| |types1| |types2|)) + ((QUOTE T) + (COND + ((AND (BOOT-EQUAL |n| (QUOTE /)) (BOOT-EQUAL |tar| |$Integer|)) + (SPADLET |tar| |$RationalNumber|) + (|putTarget| |op| |tar|))) + (COND + ((NULL |tar|) + (SPADLET |tar| + (|defaultTarget| |op| |n| (|#| |types1|) |types1|)) + (COND + ((AND |tar| |$reportBottomUpFlag|) + (|sayMSG| + (|concat| + (CONS " Default target type:" + (|bright| (|prefix2String| |tar|)))))) + ((QUOTE T) NIL)))) + (OR + (|selectLocalMms| |op| |n| |types1| |tar|) + (AND + (VECTORP |op|) + (|selectMms1| |n| |tar| |types1| |types2| (QUOTE T))))))) + (COND + (|$reportBottomUpFlag| + (|sayFunctionSelectionResult| |n| |types1| |mmS|))) + (|stopTimingProcess| (QUOTE |modemaps|)) + (EXIT |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) + +(DEFUN |selectMms2| (|op| |tar| |args1| |args2| |$Coerce|) + (DECLARE (SPECIAL |$Coerce|)) + (PROG (|nargs| |ISTMP#2| |fun| |ud| |ut| |funNode| |mapMms| |mapMm| |r| + |xx| |t| |l| |ISTMP#1| |name| |xm| |a'| |x| |a| |mmS|) + (RETURN + (SEQ + (COND + ((PROG (#0=#:G166213) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166219 NIL #0#) + (#2=#:G166220 |args1| (CDR #2#)) + (|arg| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |arg| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (OR #0# (STRINGP |arg|)))))))) + NIL) + ((QUOTE T) + (COND ((BOOT-EQUAL |tar| |$EmptyMode|) (SPADLET |tar| NIL))) + (SPADLET |nargs| (|#| |args1|)) + (SPADLET |mmS| NIL) + (SPADLET |mmS| + (COND + ((AND + |$Coerce| + (BOOT-EQUAL |op| (QUOTE |map|)) + (EQL 2 |nargs|) + (PROGN + (SPADLET |ISTMP#1| (CAR |args1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |fun| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((NULL (SPADLET |ud| (|underDomainOf| (CADR |args1|)))) NIL) + ((QUOTE T) + (COND + (|tar| (SPADLET |ut| (|underDomainOf| |tar|))) + ((QUOTE T) (SPADLET |ut| NIL))) + (COND + ((NULL + (SPADLET |mapMms| + (|selectMms1| |fun| |ut| + (CONS |ud| NIL) + (CONS NIL NIL) + (QUOTE T)))) + NIL) + ((QUOTE T) + (SPADLET |mapMm| (CDAAR |mapMms|)) + (|selectMms1| |op| |tar| + (CONS + (CONS (QUOTE |Mapping|) |mapMm|) + (CONS (CADR |args1|) NIL)) + (CONS NIL (CONS (CADR |args2|) NIL)) |$Coerce|)))))) + ((AND + |$Coerce| + (BOOT-EQUAL |op| (QUOTE |map|)) + (EQL 2 |nargs|) + (PROGN + (SPADLET |ISTMP#1| (CAR |args1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |fun| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((NULL (SPADLET |ud| (|underDomainOf| (CADR |args1|)))) NIL) + ((QUOTE T) + (COND + (|tar| (SPADLET |ut| (|underDomainOf| |tar|))) + ((QUOTE T) (SPADLET |ut| NIL))) + (SPADLET |funNode| (|mkAtreeNode| |fun|)) + (|transferPropsToNode| |fun| |funNode|) + (COND + ((NULL + (SPADLET |mapMms| + (|selectLocalMms| |funNode| |fun| (CONS |ud| NIL) NIL))) + NIL) + ((QUOTE T) + (SPADLET |mapMm| (CDAAR |mapMms|)) + (|selectMms1| |op| |tar| + (CONS + (CONS (QUOTE |Mapping|) |mapMm|) + (CONS (CADR |args1|) NIL)) + (CONS NIL (CONS (CADR |args2|) NIL)) |$Coerce|)))))) + ((QUOTE T) + (SPADLET |a| NIL) + (DO ((#3=#:G166230 |args1| (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |x| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (COND (|x| (SPADLET |a| (CONS |x| |a|))) ((QUOTE T) NIL))))) + (DO ((#4=#:G166239 |args2| (CDR #4#)) (|x| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) NIL) + (SEQ + (EXIT + (COND (|x| (SPADLET |a| (CONS |x| |a|))) ((QUOTE T) NIL))))) + (COND + ((AND |tar| (NULL (|isPartialMode| |tar|))) + (SPADLET |a| (CONS |tar| |a|)))) + (COND + ((|member| |op| (QUOTE (= + * -))) + (SPADLET |r| (|resolveTypeList| |a|)) + (COND + ((NEQUAL |r| NIL) (SPADLET |a| (CONS |r| |a|))) + ((QUOTE T) NIL)))) + (COND + ((AND |tar| (NULL (|isPartialMode| |tar|))) + (COND + ((SPADLET |xx| (|underDomainOf| |tar|)) + (SPADLET |a| (CONS |xx| |a|))) + ((QUOTE T) NIL)))) + (SEQ + (DO ((#5=#:G166248 |args1| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (|member| (CAR |x|) + (QUOTE (|List| |Vector| |Stream| |FiniteSet| |Array|)))) + (EXIT + (COND + ((SPADLET |xx| (|underDomainOf| |x|)) + (EXIT (SPADLET |a| (CONS |xx| |a|))))))))))) + (SPADLET |a'| NIL) + (SPADLET |a| (NREVERSE (REMDUP |a|))) + (DO ((#6=#:G166271 |a| (CDR #6#)) (|x| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) NIL) + (SEQ + (COND + ((NULL |x|) (QUOTE |iterate|)) + ((BOOT-EQUAL |x| (QUOTE (|RationalRadicals|))) + (SPADLET |a'| (CONS |$RationalNumber| |a'|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |Union|)) + (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) + (COND + ((AND |l| + (PROGN + (SPADLET |ISTMP#1| (CAR |l|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |:|))))) + (DO ((#7=#:G166281 |l| (CDR #7#)) (#8=#:G166199 NIL)) + ((OR (ATOM #7#) + (PROGN (SETQ #8# (CAR #7#)) NIL) + (PROGN (PROGN (SPADLET |t| (CADDR #8#)) #8#) NIL)) + NIL) + (SEQ (EXIT (SPADLET |a'| (CONS |t| |a'|)))))) + ((QUOTE T) (SPADLET |a'| (APPEND (REVERSE |l|) |a'|))))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |Mapping|)) + (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) + (SPADLET |a'| (APPEND (REVERSE |l|) |a'|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |Record|)) + (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) + (SPADLET |a'| + (APPEND + (REVERSE + (PROG (#9=#:G166292) + (SPADLET #9# NIL) + (RETURN + (DO ((#10=#:G166297 |l| (CDR #10#)) (|s| NIL)) + ((OR (ATOM #10#) (PROGN (SETQ |s| (CAR #10#)) NIL)) + (NREVERSE0 #9#)) + (SEQ (EXIT (SETQ #9# (CONS (CADDR |s|) #9#)))))))) + |a'|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |name| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((AND + (SPADLET |xm| (|get| |name| (QUOTE |mode|) |$e|)) + (NULL (|isPartialMode| |xm|))) + (EXIT (SPADLET |a'| (CONS |xm| |a'|))))))))) + (SPADLET |a| (APPEND |a| (REMDUP |a'|))) + (SPADLET |a| + (PROG (#11=#:G166308) + (SPADLET #11# NIL) + (RETURN + (DO ((#12=#:G166314 |a| (CDR #12#)) (|x| NIL)) + ((OR (ATOM #12#) (PROGN (SETQ |x| (CAR #12#)) NIL)) + (NREVERSE0 #11#)) + (SEQ + (EXIT + (COND ((PAIRP |x|) (SETQ #11# (CONS |x| #11#)))))))))) + (SPADLET |a'| |a|) + (DO () + ((NULL |a|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x| (CAR |a|)) + (SPADLET |a| (CDR |a|)) + (COND + ((ATOM |x|) (QUOTE |iterate|)) + ((QUOTE T) + (SPADLET |mmS| + (APPEND |mmS| + (|findFunctionInDomain| |op| |x| |tar| |args1| |args2| + NIL NIL))))))))) + (COND + ((AND (NULL |mmS|) |$Coerce|) + (SPADLET |a| |a'|) + (DO () + ((NULL |a|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x| (CAR |a|)) + (SPADLET |a| (CDR |a|)) + (COND + ((ATOM |x|) (QUOTE |iterate|)) + ((QUOTE T) + (SPADLET |mmS| + (APPEND |mmS| + (|findFunctionInDomain| |op| |x| |tar| |args1| + |args2| |$Coerce| NIL))))))))))) + (OR |mmS| (|selectMmsGen| |op| |tar| |args1| |args2|)))))) + (AND |mmS| (|orderMms| |op| |mmS| |args1| |args2| |tar|)))))))) + +;isAVariableType t == +; t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.] + +(DEFUN |isAVariableType| (|t|) + (PROG (|ISTMP#1|) + (RETURN + (OR + (AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (BOOT-EQUAL |t| |$Symbol|) + (AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |OrderedVariableList|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))))))) + +;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 + +(DEFUN |defaultTarget| (|opNode| |op| |nargs| |args|) + (PROG (|a1| |a1f| |a2| |mms| |LETTMP#1| |targ| |sym| |symNode| |b1| |b2| + |t| |ISTMP#2| |ISTMP#3| |a2e| D1 D |a3| |ISTMP#1| |a3e| |target|) + (RETURN + (SEQ + (PROGN + (SPADLET |target| NIL) + (COND + ((EQL |nargs| 0) + (COND + ((BOOT-EQUAL |op| (QUOTE |nil|)) + (|putTarget| |opNode| (SPADLET |target| (QUOTE (|List| (|None|))))) + |target|) + ((OR + (BOOT-EQUAL |op| (QUOTE |true|)) + (BOOT-EQUAL |op| (QUOTE |false|))) + (|putTarget| |opNode| (SPADLET |target| |$Boolean|)) + |target|) + ((BOOT-EQUAL |op| (QUOTE |pi|)) + (|putTarget| |opNode| (SPADLET |target| (CONS (QUOTE |Pi|) NIL))) + |target|) + ((BOOT-EQUAL |op| (QUOTE |infinity|)) + (|putTarget| |opNode| + (SPADLET |target| + (CONS (QUOTE |OnePointCompletion|) (CONS |$Integer| NIL)))) + |target|) + ((|member| |op| (QUOTE (|plusInfinity| |minusInfinity|))) + (|putTarget| |opNode| + (SPADLET |target| + (CONS (QUOTE |OrderedCompletion|) (CONS |$Integer| NIL)))) + |target|) + ((QUOTE T) |target|))) + ((QUOTE T) + (SPADLET |a1| (CAR |args|)) + (COND + ((ATOM |a1|) |target|) + ((QUOTE T) + (SPADLET |a1f| (QCAR |a1|)) + (COND + ((EQL |nargs| 1) + (COND + ((BOOT-EQUAL |op| (QUOTE |kernel|)) + (|putTarget| |opNode| + (SPADLET |target| + (CONS + (QUOTE |Kernel|) + (CONS (CONS (QUOTE |Expression|) (CONS |$Integer| NIL)) NIL)))) + |target|) + ((BOOT-EQUAL |op| (QUOTE |list|)) + (|putTarget| |opNode| + (SPADLET |target| (CONS (QUOTE |List|) (CONS |a1| NIL)))) + |target|) + ((QUOTE T) |target|))) + ((QUOTE T) + (SPADLET |a2| (CADR |args|)) + (COND + ((AND + (>= |nargs| 2) + (BOOT-EQUAL |op| (QUOTE |draw|)) + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Segment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (SPADLET |symNode| (|mkAtreeNode| |sym|)) + (|transferPropsToNode| |sym| |symNode|) + (COND + ((AND (>= |nargs| 3) + (PROGN + (SPADLET |ISTMP#1| (CADDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Segment|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| (CONS |$DoubleFloat| NIL)) NIL) + (|putTarget| |opNode| + (SPADLET |target| (QUOTE (|ThreeDimensionalViewport|)))) + |target|) + ((SPADLET |mms| + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| NIL) NIL)) + (SPADLET |LETTMP#1| (CAAR |mms|)) + (SPADLET |targ| (CADR |LETTMP#1|)) + (COND + ((BOOT-EQUAL |targ| |$DoubleFloat|) + (|putTarget| |opNode| + (SPADLET |target| (QUOTE (|TwoDimensionalViewport|)))) + |target|) + ((BOOT-EQUAL |targ| + (CONS (QUOTE |Point|) (CONS |$DoubleFloat| NIL))) + (|putTarget| |opNode| + (SPADLET |target| + (QUOTE (|ThreeDimensionalViewport|)))) |target|) + ((QUOTE T) |target|))) + ((QUOTE T) |target|))) + ((AND (>= |nargs| 2) + (BOOT-EQUAL |op| (QUOTE |makeObject|)) + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |sym| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Segment|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (SPADLET |symNode| (|mkAtreeNode| |sym|)) + (|transferPropsToNode| |sym| |symNode|) + (COND + ((AND (>= |nargs| 3) + (PROGN + (SPADLET |ISTMP#1| (CADDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Segment|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| (CONS |$DoubleFloat| NIL)) NIL) + |target|) + ((QUOTE T) + (|selectLocalMms| |symNode| |sym| + (CONS |$DoubleFloat| NIL) NIL) |target|))) + ((EQL |nargs| 2) + (COND + ((BOOT-EQUAL |op| (QUOTE |elt|)) + (COND + ((AND + (BOOT-EQUAL |a1| (QUOTE (|BasicOperator|))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |OrderedVariableList|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL)))))))) + (CONS (QUOTE |Expression|) (CONS |$Integer| NIL))) + ((QUOTE T) |target|))) + ((BOOT-EQUAL |op| (QUOTE |eval|)) + (COND + ((AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Expression|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |b1| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b2| (QCAR |ISTMP#3|)) + (QUOTE T))))))))) + (SPADLET |target| + (COND + ((|canCoerce| |b2| |a1|) |a1|) + ((QUOTE T) + (SPADLET |t| (|resolveTT| |b1| |b2|)) + (COND + ((OR (NULL |t|) (BOOT-EQUAL |t| |$Any|)) NIL) + ((QUOTE T) (|resolveTT| |a1| |t|)))))) + (COND (|target| (|putTarget| |opNode| |target|))) |target|) + ((AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (SPADLET |target| (|resolveTT| |a1| |a2|)) + (COND + ((AND |target| (NULL (BOOT-EQUAL |target| |$Any|))) + (|putTarget| |opNode| |target|)) + ((QUOTE T) (SPADLET |target| NIL))) + |target|) + ((AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a2e| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PAIRP |a2e|) + (EQ (QCAR |a2e|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2e|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (SPADLET |target| (|resolveTT| |a1| |a2e|)) + (COND + ((AND |target| (NULL (BOOT-EQUAL |target| |$Any|))) + (|putTarget| |opNode| |target|)) + ((QUOTE T) (SPADLET |target| NIL))) + |target|) + ((OR + (AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a2e| (QCAR |ISTMP#1|)) (QUOTE T))))) + (AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE |Equation|)) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |a2e| (QCAR |ISTMP#3|)) + (QUOTE T)))))))))) + (PROGN + (SPADLET |target| (|resolveTT| |a1| |a2e|)) + (COND + ((AND |target| (NULL (BOOT-EQUAL |target| |$Any|))) + (|putTarget| |opNode| |target|)) + ((QUOTE T) (SPADLET |target| NIL))) + |target|)))) + ((OR (BOOT-EQUAL |op| (QUOTE **)) (BOOT-EQUAL |op| (QUOTE ^))) + (COND + ((BOOT-EQUAL |a2| |$Integer|) + (COND + ((SPADLET |target| (|resolveTCat| |a1| (QUOTE (|Field|)))) + (|putTarget| |opNode| |target|))) + |target|) + ((AND + (BOOT-EQUAL |a1| (QUOTE (|AlgebraicNumber|))) + (OR + (BOOT-EQUAL |a2| |$Float|) + (BOOT-EQUAL |a2| |$DoubleFloat|))) + (SPADLET |target| + (CONS (QUOTE |Expression|) (CONS |a2| NIL))) + (|putTarget| |opNode| |target|) |target|) + ((AND + (BOOT-EQUAL |a1| (QUOTE (|AlgebraicNumber|))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Complex|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a3| (QCAR |ISTMP#1|)) (QUOTE T)))) + (OR + (BOOT-EQUAL |a3| |$Float|) + (BOOT-EQUAL |a3| |$DoubleFloat|))) + (SPADLET |target| + (CONS (QUOTE |Expression|) (CONS |a3| NIL))) + (|putTarget| |opNode| |target|) |target|) + ((AND + (BOOT-EQUAL |a2| |$RationalNumber|) + (OR + (|typeIsASmallInteger| |a1|) + (|isEqualOrSubDomain| |a1| |$Integer|))) + (|putTarget| |opNode| + (SPADLET |target| (QUOTE (|AlgebraicNumber|)))) |target|) + ((AND + (BOOT-EQUAL |a2| |$RationalNumber|) + (OR + (|isAVariableType| |a1|) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |RationalFunction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))))) + (|putTarget| |opNode| + (SPADLET |target| (|defaultTargetFE| |a1|))) |target|) + ((AND + (|isAVariableType| |a1|) + (OR + (BOOT-EQUAL |a2| |$PositiveInteger|) + (BOOT-EQUAL |a2| |$NonNegativeInteger|))) + (|putTarget| |opNode| + (SPADLET |target| (QUOTE (|Polynomial| (|Integer|))))) + |target|) + ((|isAVariableType| |a2|) + (|putTarget| |opNode| + (SPADLET |target| (|defaultTargetFE| |a1|))) |target|) + ((AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((OR + (BOOT-EQUAL |a1| |a2|) + (|isAVariableType| |a1|) + (AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |RationalFunction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL D1 D)) + (BOOT-EQUAL |a1| D) + (AND + (PAIRP |a1|) + (EQUAL (QCAR |a1|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL D1 |a1|))) + (|putTarget| |opNode| + (SPADLET |target| (|defaultTargetFE| |a2|))) |target|) + ((QUOTE T) |target|))) + ((AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |RationalFunction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((OR + (BOOT-EQUAL |a1| |a2|) + (|isAVariableType| |a1|) + (AND (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |RationalFunction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL D1 D)) + (BOOT-EQUAL |a1| D) + (AND + (PAIRP |a1|) + (EQUAL (QCAR |a1|) |$QuotientField|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D1 (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL D1 |a1|))) + (|putTarget| |opNode| + (SPADLET |target| (|defaultTargetFE| |a2|))) |target|) + ((QUOTE T) |target|))) + ((QUOTE T) |target|))) + ((BOOT-EQUAL |op| (QUOTE /)) + (COND + ((AND + (|isEqualOrSubDomain| |a1| |$Integer|) + (|isEqualOrSubDomain| |a2| |$Integer|)) + (|putTarget| |opNode| + (SPADLET |target| |$RationalNumber|)) |target|) + ((BOOT-EQUAL |a1| |a2|) + (COND + ((SPADLET |target| + (|resolveTCat| (CAR |args|) (QUOTE (|Field|)))) + (|putTarget| |opNode| |target|))) + |target|) + ((AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (|putTarget| |opNode| + (SPADLET |target| + (|mkRationalFunction| (QUOTE (|Integer|))))) + |target|) + ((AND + (|isEqualOrSubDomain| |a1| |$Integer|) + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (|putTarget| |opNode| + (SPADLET |target| + (|mkRationalFunction| (QUOTE (|Integer|))))) + |target|) + ((QUOTE T) + (AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) + (COND + ((AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (|putTarget| |opNode| + (SPADLET |target| (|mkRationalFunction| D))) |target|) + ((QUOTE T) |target|))) + (AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) + (COND + ((AND + (PAIRP |a1|) + (EQ (QCAR |a1|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T))))) + (|putTarget| |opNode| + (SPADLET |target| (|mkRationalFunction| D))) |target|) + ((QUOTE T) |target|))) + (COND + ((AND + (PAIRP |a2|) + (EQ (QCAR |a2|) (QUOTE |Polynomial|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET D (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL |a1| D)) + (|putTarget| |opNode| + (SPADLET |target| (|mkRationalFunction| D))) |target|) + ((QUOTE T) |target|))))))) + ((QUOTE T) + (SPADLET |a3| (CADDR |args|)) + (SEQ + (COND + ((EQL |nargs| 3) + (COND + ((BOOT-EQUAL |op| (QUOTE |eval|)) + (EXIT + (COND + ((AND + (PAIRP |a3|) + (EQ (QCAR |a3|) (QUOTE |List|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a3|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a3e| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |target| (|resolveTT| |a1| |a3e|)) + (COND + ((NULL (BOOT-EQUAL |target| |$Any|)) + (|putTarget| |opNode| |target|)) + ((QUOTE T) (SPADLET |target| NIL))) + |target|) + ((QUOTE T) + (SPADLET |target| (|resolveTT| |a1| |a3|)) + (COND + ((NULL (BOOT-EQUAL |target| |$Any|)) + (|putTarget| |opNode| |target|)) + ((QUOTE T) (SPADLET |target| NIL))) + |target|)))))) + ((QUOTE T) |target|)))))))))))))))) + +;mkRationalFunction D == ['Fraction, ['Polynomial, D]] + +(DEFUN |mkRationalFunction| (D) + (CONS (QUOTE |Fraction|) + (CONS (CONS (QUOTE |Polynomial|) (CONS D NIL)) NIL))) + +;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] + +(DEFUN |defaultTargetFE| (&REST #0=#:G166758 &AUX |options| |a|) + (DSETQ (|a| . |options|) #0#) + (PROG (D |uD| |ISTMP#1|) + (RETURN + (COND + ((OR + (AND + (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (BOOT-EQUAL |a| |$RationalNumber|) + (MEMQ + (QCAR |a|) + (CONS + (QCAR |$Symbol|) + (CONS (QUOTE |RationalRadicals|) (CONS (QUOTE |Pi|) NIL)))) + (|typeIsASmallInteger| |a|) + (|isEqualOrSubDomain| |a| |$Integer|) + (BOOT-EQUAL |a| (QUOTE (|AlgebraicNumber|)))) + (COND + ((IFCAR |options|) + (CONS |$FunctionalExpression| + (CONS (CONS (QUOTE |Complex|) (CONS |$Integer| NIL)) NIL))) + ((QUOTE T) + (CONS |$FunctionalExpression| (CONS |$Integer| NIL))))) + ((AND + (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |Complex|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |uD| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|defaultTargetFE| |uD| (QUOTE T))) + ((AND + (PAIRP |a|) + (PROGN + (SPADLET D (QCAR |a|)) + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |uD| (QCAR |ISTMP#1|)) (QUOTE T)))) + (MEMQ D (QUOTE (|Polynomial| |RationalFunction| |Fraction|)))) + (|defaultTargetFE| |uD| (IFCAR |options|))) + ((AND + (PAIRP |a|) + (EQUAL (QCAR |a|) |$FunctionalExpression|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + |a|) + ((IFCAR |options|) + (CONS |$FunctionalExpression| + (CONS (CONS (QUOTE |Complex|) (CONS |a| NIL)) NIL))) + ((QUOTE T) + (CONS |$FunctionalExpression| (CONS |a| NIL))))))) + +;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 + +(DEFUN |altTypeOf| (|type| |val| |$declaredMode|) + (DECLARE (SPECIAL |$declaredMode|)) + (PROG (|ISTMP#1| |vl| |val1| |a|) + (RETURN + (COND + ((AND + (OR + (EQCAR |type| (QUOTE |Symbol|)) + (EQCAR |type| (QUOTE |Variable|))) + (SPADLET |a| + (|getMinimalVarMode| + (|objValUnwrap| (|getValue| |val|)) |$declaredMode|))) + |a|) + ((AND (PAIRP |type|) + (EQ (QCAR |type|) (QUOTE |OrderedVariableList|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |vl| (QCAR |ISTMP#1|)) (QUOTE T)))) + (INTEGERP (SPADLET |val1| (|objValUnwrap| (|getValue| |val|)))) + (SPADLET |a| + (|getMinimalVarMode| + (ELT |vl| (SPADDIFFERENCE |val1| 1)) + |$declaredMode|))) + |a|) + ((BOOT-EQUAL |type| |$PositiveInteger|) |$Integer|) + ((BOOT-EQUAL |type| |$NonNegativeInteger|) |$Integer|) + ((BOOT-EQUAL |type| (QUOTE (|List| (|PositiveInteger|)))) + (QUOTE (|List| (|Integer|)))) + ((QUOTE T) 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 + +(DEFUN |getOpArgTypes,f| (|x| |op|) + (PROG (|ISTMP#1| |g| |m|) + (RETURN + (SEQ + (IF (AND + (AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |FunctionCalled|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |g| (QCAR |ISTMP#1|)) (QUOTE T))))) + (NEQUAL |op| (QUOTE |name|))) + (EXIT + (SEQ + (IF (SPADLET |m| (|get| |g| (QUOTE |mode|) |$e|)) + (EXIT + (SEQ + (IF (AND (PAIRP |m|) (EQ (QCAR |m|) (QUOTE |Mapping|))) + (EXIT |m|)) + (EXIT |x|)))) + (EXIT |x|)))) + (EXIT |x|))))) + +(DEFUN |getOpArgTypes| (|opname| |args|) + (PROG (|l|) + (RETURN + (SEQ + (PROGN + (SPADLET |l| (|getOpArgTypes1| |opname| |args|)) + (PROG (#0=#:G166792) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166797 |l| (CDR #1#)) (|a| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |a| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|getOpArgTypes,f| |a| |opname|) #0#)))))))))))) + +;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 + +(DEFUN |getOpArgTypes1| (|opname| |args|) + (PROG (|b| |n| |ISTMP#1| |d| |ISTMP#2| |c| |nargs| |v| |ms| |mss|) + (RETURN + (SEQ + (COND + ((NULL |args|) NIL) + ((AND + (BOOT-EQUAL |opname| (QUOTE |coef|)) + (PAIRP |args|) + (PROGN + (SPADLET |b| (QCAR |args|)) + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |n| (QCAR |ISTMP#1|)) (QUOTE T))))) + (CONS + (CAR (|getModeSet| |b|)) + (CONS (CAR (|getModeSetUseSubdomain| |n|)) NIL))) + ((AND + (BOOT-EQUAL |opname| (QUOTE |monom|)) + (PAIRP |args|) + (PROGN + (SPADLET |d| (QCAR |args|)) + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#1|)) (QUOTE T))))) + (CONS + (CAR (|getModeSetUseSubdomain| |d|)) + (CONS (CAR (|getModeSet| |c|)) NIL))) + ((AND + (BOOT-EQUAL |opname| (QUOTE |monom|)) + (PAIRP |args|) + (PROGN + (SPADLET |v| (QCAR |args|)) + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |d| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (CONS + (CAR (|getModeSet| |v|)) + (CONS + (CAR (|getModeSetUseSubdomain| |d|)) + (CONS (CAR (|getModeSet| |c|)) NIL)))) + ((AND + (BOOT-EQUAL |opname| (QUOTE |cons|)) + (EQL 2 (|#| |args|)) + (BOOT-EQUAL (CADR |args|) (QUOTE |nil|))) + (SPADLET |ms| + (PROG (#0=#:G166858) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166863 |args| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CAR (|getModeSet| |x|)) #0#)))))))) + (COND + ((BOOT-EQUAL (CADR |ms|) (QUOTE (|List| (|None|)))) + (SPADLET |ms| + (CONS + (CAR |ms|) + (CONS (CONS (QUOTE |List|) (CONS (CAR |ms|) NIL)) NIL))))) + |ms|) + ((QUOTE T) + (SPADLET |nargs| (|#| |args|)) + (SPADLET |v| (|argCouldBelongToSubdomain| |opname| |nargs|)) + (SPADLET |mss| NIL) + (DO ((#2=#:G166875 (SPADDIFFERENCE |nargs| 1)) + (|i| 0 (QSADD1 |i|)) + (#3=#:G166876 |args| (CDR #3#)) + (|x| NIL)) + ((OR + (QSGREATERP |i| #2#) + (ATOM #3#) + (PROGN (SETQ |x| (CAR #3#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |ms| + (COND + ((EQL (ELT |v| |i|) 0) (CAR (|getModeSet| |x|))) + ((QUOTE T) (CAR (|getModeSetUseSubdomain| |x|))))) + (SPADLET |mss| (CONS |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 + +(DEFUN |argCouldBelongToSubdomain| (|op| |nargs|) + (PROG (|v| |mms| |sig| |cond|) + (RETURN + (SEQ + (COND + ((EQL |nargs| 0) NIL) + ((QUOTE T) + (SPADLET |v| (GETZEROVEC |nargs|)) + (COND + ((|isMap| |op|) |v|) + ((QUOTE T) + (SPADLET |mms| (|getModemapsFromDatabase| |op| |nargs|)) + (COND + ((NULL |mms|) |v|) + ((QUOTE T) + (SPADLET |nargs| (SPADDIFFERENCE |nargs| 1)) + (SEQ + (DO ((#0=#:G166914 |mms| (CDR #0#)) (#1=#:G166905 NIL)) + ((OR + (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR #1#)) + (SPADLET |cond| (CADR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (DO ((#2=#:G166925 (CDDR |sig|) (CDR #2#)) + (|t| NIL) + (|i| 0 (QSADD1 |i|))) + ((OR + (ATOM #2#) + (PROGN (SETQ |t| (CAR #2#)) NIL) + (QSGREATERP |i| |nargs|)) NIL) + (SEQ + (EXIT + (COND + ((|CONTAINEDisDomain| |t| |cond|) + (EXIT (SETELT |v| |i| (PLUS 1 (ELT |v| |i|)))))))))))) + (EXIT |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 + +(DEFUN |CONTAINEDisDomain| (|symbol| |cond|) + (PROG (|dom|) + (RETURN + (SEQ + (COND + ((ATOM |cond|) NIL) + ((MEMQ (QCAR |cond|) (QUOTE (AND OR |and| |or|))) + (PROG (#0=#:G166941) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166947 NIL #0#) + (#2=#:G166948 (QCDR |cond|) (CDR #2#)) + (|u| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |u| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (OR #0# (|CONTAINEDisDomain| |symbol| |u|))))))))) + ((EQ (QCAR |cond|) (QUOTE |isDomain|)) + (AND + (EQ |symbol| (CADR |cond|)) + (PAIRP (SPADLET |dom| (CADDR |cond|))) + (MEMQ |dom| (QUOTE (|PositiveInteger| |NonNegativeInteger|))))) + ((QUOTE T) NIL)))))) + +;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 + +(DEFUN |selectDollarMms| (|dc| |name| |types1| |types2|) + (PROG (|mmS|) + (RETURN + (COND + ((|isPartialMode| |dc|) (|throwKeyedMsg| (QUOTE S2IF0001) NIL)) + ((SPADLET |mmS| + (|findFunctionInDomain| |name| |dc| NIL |types1| |types2| + (QUOTE T) (QUOTE T))) + (|orderMms| |name| |mmS| |types1| |types2| NIL)) + ((QUOTE T) + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS (QUOTE |%b|) + (CONS " function not found in " + (CONS (|prefix2String| |dc|) + (CONS (QUOTE |%d|) (CONS (QUOTE |%l|) NIL)))))))) 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) + +(DEFUN |selectLocalMms| (|op| |name| |types| |tar|) + (PROG (|mmS| |obj| |ISTMP#1| |mapDef|) + (RETURN + (COND + ((SPADLET |mmS| (|getLocalMms| |name| |types| |tar|)) |mmS|) + ((QUOTE T) + (SPADLET |obj| (|getValue| |op|)) + (AND + |obj| + (PROGN (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) + (PROGN + (SPADLET |mapDef| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (|analyzeMap| |op| |types| |mapDef| |tar|) + (|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 + +(DEFUN |getLocalMms,f| (|x| |y| |subsume|) + (IF |subsume| (|isEqualOrSubDomain| |x| |y|) (BOOT-EQUAL |x| |y|))) + +(DEFUN |getLocalMms| (|name| |types| |tar|) + (PROG (|dcSig| |dc| |ISTMP#1| |result| |args| |subsume| + |acceptableArgs| |mmS|) + (RETURN + (SEQ + (PROGN + (SPADLET |mmS| NIL) + (DO ((#0=#:G167010 (|get| |name| (QUOTE |localModemap|) |$e|) (CDR #0#)) + (|mm| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |mm| (CAR #0#)) NIL) + (PROGN (PROGN (SPADLET |dcSig| (CAR |mm|)) |mm|) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL + (AND + (PAIRP |dcSig|) + (PROGN + (SPADLET |dc| (QCAR |dcSig|)) + (SPADLET |ISTMP#1| (QCDR |dcSig|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |result| (QCAR |ISTMP#1|)) + (SPADLET |args| (QCDR |ISTMP#1|)) + (QUOTE T)))))) + NIL) + ((NEQUAL (|#| |types|) (|#| |args|)) NIL) + ((QUOTE T) + (SPADLET |subsume| + (OR + (NULL |$useIntegerSubdomain|) + (BOOT-EQUAL |tar| |result|) + (|get| |name| (QUOTE |recursive|) |$e|))) + (SPADLET |acceptableArgs| + (PROG (#1=#:G167017) + (SPADLET #1# (QUOTE T)) + (RETURN + (DO ((#2=#:G167024 NIL (NULL #1#)) + (#3=#:G167025 |args| (CDR #3#)) + (|a| NIL) + (#4=#:G167026 |types| (CDR #4#)) + (|b| NIL)) + ((OR #2# + (ATOM #3#) + (PROGN (SETQ |a| (CAR #3#)) NIL) + (ATOM #4#) + (PROGN (SETQ |b| (CAR #4#)) NIL)) + #1#) + (SEQ + (EXIT + (SETQ #1# (AND #1# (|getLocalMms,f| |b| |a| |subsume|))))))))) + (COND + ((NULL |acceptableArgs|) + (COND + ((AND (BOOT-EQUAL |dc| (QUOTE |interpOnly|)) (NULL |$Coerce|)) + (SPADLET |mmS| (CONS |mm| |mmS|))) + ((QUOTE T) NIL))) + ((QUOTE T) (SPADLET |mmS| (CONS |mm| |mmS|))))))))) + (NREVERSE |mmS|)))))) + +@ +mmCost assigns a penalty to each signature according to the following +formula: +\begin{verbatim} + 10000*n + 1000*domainDepth(res) + hitListOfTargets(res) +\end{verbatim} +where: +\begin{itemize} +\item {\bf n} is a penalty taking into account the number of coercions +necessary to coerce the types of the given arguments to those of the +signature under consideration. +\item {\bf res} is the codomain of the signature +\item {\bf hitListOfTarget} assigns a penalty between 1 and 1600 using +a short list of constructors: Polynomial (300), List (400), 500 is the +default, UniversalSegment (501), RationalFunction (900), Matrix (910), +Union (999), Expression (1600). Note that RationalFunction is actually +not a domain, so it should never happen. +\item {\bf domainDepth} calculates the maximal depth of the type +\item {\bf finally} the preference order of PI, NNI, and DFLOAT as +targets is done at the very end. +\end{itemize} +In particular, note that if we have two signatures taking types A and B, +and the given argument does not match exactly but has to be coerced, then +the types A and B themselves are not sorted by preference. +<<*>>= +;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 +; if $reportBottomUpFlag then +; sayMSG ['"cost=",prefix2String cost,'" for ", name,'": ",_ +; :formatSignature CDR sig] +; cost + +(DEFUN |mmCost| (|name| |sig| |cond| |tar| |args1| |args2|) + (PROG (|cost| |res|) + (RETURN + (PROGN + (SPADLET |cost| (|mmCost0| |name| |sig| |cond| |tar| |args1| |args2|)) + (SPADLET |res| (CADR |sig|)) + (COND + ((BOOT-EQUAL |res| |$PositiveInteger|) (SPADDIFFERENCE |cost| 2)) + ((BOOT-EQUAL |res| |$NonNegativeInteger|) (SPADDIFFERENCE |cost| 1)) + ((BOOT-EQUAL |res| |$DoubleFloat|) (PLUS |cost| 1)) + ((QUOTE T) + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS "cost=" + (CONS (|prefix2String| |cost|) + (CONS " for " + (CONS |name| + (CONS ": " (|formatSignature| (CDR |sig|)))))))))) + |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) + +(DEFUN |mmCost0| (|name| |sig| |cond| |tar| |args1| |args2|) + (PROG (|sigArgs| |topcon| |topcon2| |n| |res|) + (RETURN + (SEQ + (PROGN + (SPADLET |sigArgs| (CDDR |sig|)) + (SPADLET |n| + (COND + ((NULL |cond|) 1) + ((NULL + (PROG (#0=#:G167060) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167066 NIL #0#) + (#2=#:G167067 |cond| (CDR #2#)) + (#3=#:G167056 NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ #3# (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (OR #0# #3#)))))))) + 1) + ((QUOTE T) 0))) + (COND + (|args1| + (DO ((#4=#:G167079 |args1| (CDR #4#)) + (|x1| NIL) + (#5=#:G167080 |args2| (CDR #5#)) + (|x2| NIL) + (#6=#:G167081 |sigArgs| (CDR #6#)) + (|x3| NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ |x1| (CAR #4#)) NIL) + (ATOM #5#) + (PROGN (SETQ |x2| (CAR #5#)) NIL) + (ATOM #6#) + (PROGN (SETQ |x3| (CAR #6#)) NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |n| + (PLUS |n| + (COND + ((|isEqualOrSubDomain| |x1| |x3|) 0) + ((QUOTE T) + (SPADLET |topcon| (CAR (|deconstructT| |x1|))) + (SPADLET |topcon2| (CAR (|deconstructT| |x3|))) + (COND + ((BOOT-EQUAL |topcon| |topcon2|) 3) + ((BOOT-EQUAL (CAR |topcon2|) (QUOTE |Mapping|)) 2) + ((QUOTE T) 4)))))))))) + (|sigArgs| (SPADLET |n| (PLUS |n| 100000000000))) ((QUOTE T) NIL)) + (SPADLET |res| (CADR |sig|)) + (COND + ((BOOT-EQUAL |res| |tar|) (TIMES 10000 |n|)) + ((QUOTE T) + (PLUS + (PLUS (TIMES 10000 |n|) (TIMES 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] + +(DEFUN |orderMms| (|name| |mmS| |args1| |args2| |tar|) + (PROG (N |sig| |cond| |m| |p| |b| S |mS|) + (RETURN + (SEQ + (COND + ((AND |mmS| (NULL (CDR |mmS|))) |mmS|) + ((QUOTE T) + (SPADLET |mS| NIL) + (SPADLET N NIL) + (DO ((#0=#:G167119 (MSORT |mmS|) (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |sig| (CAR |mm|)) + (SPADLET |cond| (CADDR |mm|)) + (SPADLET |b| (QUOTE T)) + (SPADLET |p| + (CONS + (SPADLET |m| + (|mmCost| |name| |sig| |cond| |tar| |args1| |args2|)) |mm|)) + (SPADLET |mS| + (COND + ((NULL |mS|) (LIST |p|)) + ((> (CAAR |mS|) |m|) (CONS |p| |mS|)) + ((QUOTE T) + (SPADLET S |mS|) + (DO ((#1=#:G167128 NIL |b|)) + (#1# NIL) + (SEQ + (EXIT + (COND + ((SPADLET |b| (OR (NULL (CDR S)) (> (CAADR S) |m|))) + (RPLACD S (CONS |p| (CDR S)))) + ((QUOTE T) (SPADLET S (CDR S))))))) + |mS|))))))) + (AND + |mmS| + (PROG (#2=#:G167136) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167141 |mS| (CDR #3#)) (|p| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |p| (CAR #3#)) NIL)) (NREVERSE0 #2#)) + (SEQ (EXIT (SETQ #2# (CONS (CDR |p|) #2#)))))))))))))) + +;domainDepth(d) == +; -- computes the depth of lisp structure d +; atom d => 0 +; MAX(domainDepth(CAR d)+1,domainDepth(CDR d)) + +(DEFUN |domainDepth| (|d|) + (COND + ((ATOM |d|) 0) + ((QUOTE T) + (MAX (PLUS (|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 + +(DEFUN |hitListOfTarget| (|t|) + (COND + ((BOOT-EQUAL |t| (QUOTE (|Polynomial| (|Pi|)))) 90000) + ((EQ (CAR |t|) (QUOTE |Polynomial|)) 300) + ((EQ (CAR |t|) (QUOTE |List|)) 400) + ((EQ (CAR |t|) (QUOTE |Matrix|)) 910) + ((EQ (CAR |t|) (QUOTE |UniversalSegment|)) 501) + ((EQ (CAR |t|) (QUOTE |RationalFunction|)) 900) + ((EQ (CAR |t|) (QUOTE |Union|)) 999) + ((EQ (CAR |t|) (QUOTE |Expression|)) 1600) + ((QUOTE T) 500))) + +;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) => +; 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]) + +(DEFUN |getFunctionFromDomain| (|op| |dc| |args|) + (PROG (|$reportBottomUpFlag| |p| |domain| |osig| |nsig| |b|) + (DECLARE (SPECIAL |$reportBottomUpFlag|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$reportBottomUpFlag| NIL) + (COND + ((|member| (CAR |dc|) |$nonLisplibDomains|) + (|throwKeyedMsg| (QUOTE S2IF0002) (CONS (CAR |dc|) NIL))) + ((NULL (|constructor?| (CAR |dc|))) + (|throwKeyedMsg| (QUOTE S2IF0003) (CONS (CAR |dc|) NIL))) + ((SPADLET |p| + (|findFunctionInDomain| |op| |dc| NIL |args| |args| NIL NIL)) + (SPADLET |domain| (|evalDomain| |dc|)) + (DO ((#0=#:G167183 (NREVERSE |p|) (CDR #0#)) + (|mm| NIL) + (#1=#:G167184 NIL |b|)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL) #1#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |osig| (CDAR |mm|)) + (SPADLET |nsig| (CADR |mm|)) + (SPADLET |b| (|compiledLookup| |op| |nsig| |domain|)))))) + (OR |b| (|throwKeyedMsg| (QUOTE S2IS0023) (CONS |op| (CONS |dc| NIL))))) + ((QUOTE T) + (|throwKeyedMsg| (QUOTE S2IF0004) (CONS |op| (CONS |dc| NIL)))))))))) + +;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 + +(DEFUN |isOpInDomain| (|opName| |dom| |nargs|) + (PROG (|mmList| |gotOne|) + (RETURN + (SEQ + (PROGN + (SPADLET |mmList| + (ASSQ |opName| (|getOperationAlistFromLisplib| (CAR |dom|)))) + (SPADLET |mmList| (|subCopy| |mmList| (|constructSubst| |dom|))) + (COND + ((NULL |mmList|) NIL) + ((QUOTE T) + (SPADLET |gotOne| NIL) + (SPADLET |nargs| (PLUS |nargs| 1)) + (SEQ + (DO ((#0=#:G167207 (CDR |mmList|) (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |mm| (CAR #0#)) NIL) + (NULL (NULL |gotOne|))) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |nargs| (|#| (CAR |mm|))) + (EXIT (SPADLET |gotOne| (CONS |mm| |gotOne|)))))))) + (EXIT |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 + +(DEFUN |findCommonSigInDomain| (|opName| |dom| |nargs|) + (PROG (|mmList| |gotOne| |vec|) + (RETURN + (SEQ + (COND + ((|member| (CAR |dom|) (QUOTE (|Union| |Record| |Mapping|))) NIL) + ((QUOTE T) + (SPADLET |mmList| + (ASSQ |opName| (|getOperationAlistFromLisplib| (CAR |dom|)))) + (SPADLET |mmList| (|subCopy| |mmList| (|constructSubst| |dom|))) + (COND + ((NULL |mmList|) NIL) + ((QUOTE T) + (SPADLET |gotOne| NIL) + (SPADLET |nargs| (PLUS |nargs| 1)) + (SPADLET |vec| NIL) + (SEQ + (DO ((#0=#:G167227 (CDR |mmList|) (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |nargs| (|#| (CAR |mm|))) + (EXIT + (COND + ((NULL |vec|) (SPADLET |vec| (LIST2VEC (CAR |mm|)))) + ((QUOTE T) + (DO ((|i| 0 (QSADD1 |i|)) + (#1=#:G167237 (CAR |mm|) (CDR #1#)) + (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (ELT |vec| |i|) (NEQUAL (ELT |vec| |i|) |x|)) + (SETELT |vec| |i| NIL)) + ((QUOTE T) 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]) + +(DEFUN |findUniqueOpInDomain| (|op| |opName| |dom|) + (PROG (|mmList| |mm| |sig| |slot| |fun| |binVal| |m|) + (RETURN + (PROGN + (SPADLET |mmList| + (ASSQ |opName| (|getOperationAlistFromLisplib| (CAR |dom|)))) + (SPADLET |mmList| (|subCopy| |mmList| (|constructSubst| |dom|))) + (COND + ((NULL |mmList|) + (|throwKeyedMsg| (QUOTE S2IS0021) (CONS |opName| (CONS |dom| NIL)))) + ((QUOTE T) + (COND + ((> (|#| (CDR |mmList|)) 1) + (SPADLET |mm| (|selectMostGeneralMm| (CDR |mmList|))) + (|sayKeyedMsg| (QUOTE S2IS0022) + (CONS |opName| + (CONS |dom| + (CONS (CONS (QUOTE |Mapping|) (CAR |mm|)) NIL))))) + ((QUOTE T) (SPADLET |mm| (CADR |mmList|)))) + (SPADLET |sig| (CAR |mm|)) + (SPADLET |slot| (CADR |mm|)) + (SPADLET |fun| + (COND + (|$genValue| + (|compiledLookupCheck| |opName| |sig| (|evalDomain| |dom|))) + ((QUOTE T) + (|NRTcompileEvalForm| |opName| |sig| (|evalDomain| |dom|))))) + (COND + ((OR (NULL |fun|) (NULL (PAIRP |fun|))) NIL) + ((BOOT-EQUAL (CAR |fun|) (|function| |Undef|)) + (|throwKeyedMsg| (QUOTE S2IS0023) (CONS |opName| (CONS |dom| NIL)))) + ((QUOTE T) + (SPADLET |binVal| + (COND (|$genValue| (|wrap| |fun|)) ((QUOTE T) |fun|))) + (|putValue| |op| + (|objNew| |binVal| (SPADLET |m| (CONS (QUOTE |Mapping|) |sig|)))) + (|putModeSet| |op| (CONS |m| NIL)))))))))) + +;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 + +(DEFUN |selectMostGeneralMm| (|mmList|) + (PROG (|sz| |met| |min| |fsz| |LETTMP#1| |mm| |mml| |genMm|) + (RETURN + (SEQ + (PROGN + (SPADLET |min| 100) + (SPADLET |mml| |mmList|) + (DO () + ((NULL |mml|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |LETTMP#1| |mml|) + (SPADLET |mm| (CAR |LETTMP#1|)) + (SPADLET |mml| (CDR |LETTMP#1|)) + (SPADLET |sz| (|#| (CAR |mm|))) + (COND + ((> |min| (SPADLET |met| (ABS (SPADDIFFERENCE |sz| 3)))) + (SPADLET |min| |met|) (SPADLET |fsz| |sz|)) + ((QUOTE T) NIL)))))) + (SPADLET |mmList| + (PROG (#0=#:G167305) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167311 |mmList| (CDR #1#)) (|mm| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (|#| (CAR |mm|)) |fsz|) + (SETQ #0# (CONS |mm| #0#)))))))))) + (SPADLET |mml| (CDR |mmList|)) + (SPADLET |genMm| (CAR |mmList|)) + (DO () + ((NULL |mml|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |LETTMP#1| |mml|) + (SPADLET |mm| (CAR |LETTMP#1|)) + (SPADLET |mml| (CDR |LETTMP#1|)) + (COND + ((PROG (#2=#:G167327) + (SPADLET #2# (QUOTE T)) + (RETURN + (DO ((#3=#:G167334 NIL (NULL #2#)) + (#4=#:G167335 (CDAR |mm|) (CDR #4#)) + (|mmArg| NIL) + (#5=#:G167336 (CDAR |genMm|) (CDR #5#)) + (|genMmArg| NIL)) + ((OR #3# + (ATOM #4#) + (PROGN (SETQ |mmArg| (CAR #4#)) NIL) + (ATOM #5#) + (PROGN (SETQ |genMmArg| (CAR #5#)) NIL)) + #2#) + (SEQ + (EXIT + (SETQ #2# (AND #2# (|canCoerceFrom| |genMmArg| |mmArg|)))))))) + (SPADLET |genMm| |mm|))))))) + |genMm|))))) + +;findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == +; -- looks for a modemap for op with signature args1 -> tar +; -- in the domain of computation dc +; -- tar may be NIL (= unknown) +; null isLegitimateMode(tar, nil, nil) => nil +; dcName:= CAR dc +; member(dcName,'(Union Record Mapping Enumeration)) => +; -- First cut code that ignores args2, $Coerce and $SubDom +; -- When domains no longer have to have Set, the hard coded 6 and 7 +; -- should go. +; op = '_= => +; #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL +; tar and tar ^= '(Boolean) => NIL +; [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]] +; op = 'coerce => +; dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> +; [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] +; args1.0 ^= dc => NIL +; tar and tar ^= $Expression => NIL +; [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] +; member(dcName,'(Record Union)) => +; findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) +; NIL +; fun:= NIL +; ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and +; SL := constructSubst dc +; -- if the arglist is homogeneous, first look for homogeneous +; -- functions. If we don't find any, look at remaining ones +; if isHomogeneousList args1 then +; q := NIL +; r := NIL +; for mm in CDR p repeat +; -- CDAR of mm is the signature argument list +; if isHomogeneousList CDAR mm then q := [mm,:q] +; else r := [mm,:r] +; q := allOrMatchingMms(q,args1,tar,dc) +; for mm in q repeat +; fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) +; r := reverse r +; else r := CDR p +; r := allOrMatchingMms(r,args1,tar,dc) +; if not fun then -- consider remaining modemaps +; for mm in r repeat +; fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) +; if not fun and $reportBottomUpFlag then +; sayMSG concat +; ['" -> no appropriate",:bright op,'"found in", +; :bright prefix2String dc] +; fun + +(DEFUN |findFunctionInDomain| + (|op| |dc| |tar| |args1| |args2| |$Coerce| |$SubDom|) + (DECLARE (SPECIAL |$Coerce| |$SubDom|)) + (PROG (|dcName| |p| SL |q| |r| |fun|) + (RETURN + (SEQ + (COND + ((NULL (|isLegitimateMode| |tar| NIL NIL)) NIL) + ((QUOTE T) + (SPADLET |dcName| (CAR |dc|)) + (COND + ((|member| |dcName| (QUOTE (|Union| |Record| |Mapping| |Enumeration|))) + (COND + ((BOOT-EQUAL |op| (QUOTE =)) + (COND + ((OR + (NEQUAL (|#| |args1|) 2) + (NEQUAL (ELT |args1| 0) |dc|) + (NEQUAL (ELT |args1| 1) |dc|)) + NIL) + ((AND |tar| (NEQUAL |tar| (QUOTE (|Boolean|)))) NIL) + ((QUOTE T) + (CONS + (CONS + (CONS |dc| + (CONS (QUOTE (|Boolean|)) (CONS |dc| (CONS |dc| NIL)))) + (CONS + (CONS (QUOTE (|Boolean|)) + (CONS (QUOTE $) (CONS (QUOTE $) NIL))) + (CONS (CONS NIL (CONS NIL NIL)) NIL))) + NIL)))) + ((BOOT-EQUAL |op| (QUOTE |coerce|)) + (COND + ((AND + (BOOT-EQUAL |dcName| (QUOTE |Enumeration|)) + (OR + (BOOT-EQUAL (ELT |args1| 0) |$Symbol|) + (BOOT-EQUAL |tar| |dc|))) + (CONS + (CONS + (CONS |dc| (CONS |dc| (CONS |$Symbol| NIL))) + (CONS + (CONS (QUOTE $) (CONS |$Symbol| NIL)) + (CONS (CONS NIL (CONS NIL NIL)) NIL))) + NIL)) + ((NEQUAL (ELT |args1| 0) |dc|) NIL) + ((AND |tar| (NEQUAL |tar| |$Expression|)) NIL) + ((QUOTE T) + (CONS + (CONS + (CONS |dc| (CONS |$Expression| (CONS |dc| NIL))) + (CONS + (CONS |$Expression| (CONS (QUOTE $) NIL)) + (CONS (CONS NIL (CONS NIL NIL)) NIL))) + NIL)))) + ((|member| |dcName| (QUOTE (|Record| |Union|))) + (|findFunctionInCategory| |op| |dc| |tar| |args1| |args2| + |$Coerce| |$SubDom|)) + ((QUOTE T) NIL))) + ((QUOTE T) + (SPADLET |fun| NIL) + (AND + (SPADLET |p| (ASSQ |op| (|getOperationAlistFromLisplib| |dcName|))) + (PROGN + (SPADLET SL (|constructSubst| |dc|)) + (COND + ((|isHomogeneousList| |args1|) + (SPADLET |q| NIL) + (SPADLET |r| NIL) + (DO ((#0=#:G167376 (CDR |p|) (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((|isHomogeneousList| (CDAR |mm|)) + (SPADLET |q| (CONS |mm| |q|))) + ((QUOTE T) (SPADLET |r| (CONS |mm| |r|))))))) + (SPADLET |q| (|allOrMatchingMms| |q| |args1| |tar| |dc|)) + (DO ((#1=#:G167385 |q| (CDR #1#)) (|mm| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |fun| + (NCONC |fun| + (|findFunctionInDomain1| |mm| |op| |tar| + |args1| |args2| SL)))))) + (SPADLET |r| (REVERSE |r|))) + ((QUOTE T) (SPADLET |r| (CDR |p|)))) + (SPADLET |r| (|allOrMatchingMms| |r| |args1| |tar| |dc|)) + (COND + ((NULL |fun|) + (DO ((#2=#:G167394 |r| (CDR #2#)) (|mm| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |fun| + (NCONC |fun| + (|findFunctionInDomain1| |mm| |op| |tar| + |args1| |args2| SL))))))) + ((QUOTE T) NIL)))) + (COND + ((AND (NULL |fun|) |$reportBottomUpFlag|) + (|sayMSG| + (|concat| + (CONS " -> no appropriate" + (APPEND (|bright| |op|) + (CONS "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 + +(DEFUN |allOrMatchingMms| (|mms| |args1| |tar| |dc|) + (PROG (|sig| |LETTMP#1| |res| |args| |x|) + (RETURN + (SEQ + (COND + ((OR (NULL |mms|) (NULL (CDR |mms|))) |mms|) + ((QUOTE T) + (SPADLET |x| NIL) + (DO ((#0=#:G167437 |mms| (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |sig| (CAR |mm|)) + (SPADLET |LETTMP#1| (MSUBSTQ |dc| (QUOTE $) |sig|)) + (SPADLET |res| (CAR |LETTMP#1|)) + (SPADLET |args| (CDR |LETTMP#1|)) + (COND + ((NEQUAL |args| |args1|) NIL) + ((QUOTE T) (SPADLET |x| (CONS |mm| |x|)))))))) + (COND + (|x| |x|) + ((QUOTE T) |mms|)))))))) + +;isHomogeneousList y == +; y is [x] => true +; y and rest y => +; z := CAR y +; "and"/[x = z for x in CDR y] +; NIL + +(DEFUN |isHomogeneousList| (|y|) + (PROG (|x| |z|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |y|) + (EQ (QCDR |y|) NIL) + (PROGN (SPADLET |x| (QCAR |y|)) (QUOTE T))) + (QUOTE T)) + ((AND |y| (CDR |y|)) + (SPADLET |z| (CAR |y|)) + (PROG (#0=#:G167454) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G167460 NIL (NULL #0#)) + (#2=#:G167461 (CDR |y|) (CDR #2#)) + (|x| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |x| |z|))))))))) + ((QUOTE T) NIL)))))) + +;findFunctionInDomain1(omm,op,tar,args1,args2,SL) == +; dc:= CDR (dollarPair := ASSQ('$,SL)) +; -- need to drop '$ from SL +; mm:= subCopy(omm, SL) +; -- tests whether modemap mm is appropriate for the function +; -- defined by op, target type tar and argument types args +; $RTC:local:= NIL +; -- $RTC is a list of run-time checks to be performed +; [sig,slot,cond,y] := mm +; [osig,:.] := omm +; osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL)) +; if CONTAINED('_#, sig) or CONTAINED('construct, sig) then +; sig := [replaceSharpCalls t for t in sig] +; matchMmCond cond and matchMmSig(mm,tar,args1,args2) and +; EQ(y,'Subsumed) and +; -- hmmmm: do Union check in following because (as in DP) +; -- Unions are subsumed by total modemaps which are in the +; -- mm list in findFunctionInDomain. +; y := 'ELT -- if subsumed fails try it again +; not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and +; (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f +; EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]] +; EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]] +; EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]] +; y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] +; sayKeyedMsg("S2IF0006",[y]) +; NIL + +(DEFUN |findFunctionInDomain1| (|omm| |op| |tar| |args1| |args2| SL) + (PROG ($RTC |dollarPair| |dc| |mm| |slot| |cond| |osig| |sig| |y| + |ISTMP#1| |args| |f|) + (DECLARE (SPECIAL $RTC)) + (RETURN + (SEQ + (PROGN + (SPADLET |dc| (CDR (SPADLET |dollarPair| (ASSQ (QUOTE $) SL)))) + (SPADLET |mm| (|subCopy| |omm| SL)) + (SPADLET $RTC NIL) + (SPADLET |sig| (CAR |mm|)) + (SPADLET |slot| (CADR |mm|)) + (SPADLET |cond| (CADDR |mm|)) + (SPADLET |y| (CADDDR |mm|)) + (SPADLET |osig| (CAR |omm|)) + (SPADLET |osig| + (|subCopy| |osig| (SUBSTQ (CONS (QUOTE $) (QUOTE $)) |dollarPair| SL))) + (COND + ((OR + (CONTAINED (QUOTE |#|) |sig|) + (CONTAINED (QUOTE |construct|) |sig|)) + (SPADLET |sig| + (PROG (#0=#:G167493) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167498 |sig| (CDR #1#)) (|t| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|replaceSharpCalls| |t|) #0#)))))))))) + (AND + (|matchMmCond| |cond|) + (|matchMmSig| |mm| |tar| |args1| |args2|) + (PROGN + (AND + (EQ |y| (QUOTE |Subsumed|)) + (PROGN + (SPADLET |y| (QUOTE ELT)) + (COND + ((AND + (NULL |$SubDom|) + (NULL + (PROGN + (SPADLET |ISTMP#1| (CAR |sig|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE |Union|))))) + (PAIRP |slot|) + (PROGN + (SPADLET |tar| (QCAR |slot|)) + (SPADLET |args| (QCDR |slot|)) + (QUOTE T)) + (SPADLET |f| + (|findFunctionInDomain| |op| |dc| |tar| |args| |args| NIL NIL))) + |f|)))) + (COND + ((EQ |y| (QUOTE ELT)) + (CONS + (CONS (CONS |dc| |sig|) (CONS |osig| (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((EQ |y| (QUOTE CONST)) + (CONS + (CONS (CONS |dc| |sig|) (CONS |osig| (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((EQ |y| (QUOTE ASCONST)) + (CONS + (CONS (CONS |dc| |sig|) (CONS |osig| (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((AND (PAIRP |y|) (EQ (QCAR |y|) (QUOTE XLAM))) + (CONS + (CONS (CONS |dc| |sig|) (CONS |y| (CONS (NREVERSE $RTC) NIL))) + NIL)) + ((QUOTE T) + (|sayKeyedMsg| (QUOTE S2IF0006) (CONS |y| NIL)) NIL))))))))) + +;findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == +; -- looks for a modemap for op with signature args1 -> tar +; -- in the domain of computation dc +; -- tar may be NIL (= unknown) +; dcName:= CAR dc +; not MEMQ(dcName,'(Record Union Enumeration)) => NIL +; fun:= NIL +; -- cat := constructorCategory dc +; makeFunc := GET(dcName,"makeFunctionList") or +; systemErrorHere '"findFunctionInCategory" +; [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) +; -- get list of implementations and remove sharps +; maxargs := -1 +; impls := nil +; for [a,b,d] in funlist repeat +; not EQ(a,op) => nil +; d is ['XLAM,xargs,:.] => +; if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) +; else maxargs := MAX(maxargs,1) +; impls := cons([b,nil,true,d],impls) +; impls := cons([b,d,true,d],impls) +; impls := NREVERSE impls +; if maxargs ^= -1 then +; SL:= NIL +; for i in 1..maxargs repeat +; impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) +; impls and +; SL:= constructSubst dc +; for mm in impls repeat +; fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) +; if not fun and $reportBottomUpFlag then +; sayMSG concat +; ['" -> no appropriate",:bright op,'"found in", +; :bright prefix2String dc] +; fun + +(DEFUN |findFunctionInCategory| + (|op| |dc| |tar| |args1| |args2| |$Coerce| |$SubDom|) + (DECLARE (SPECIAL |$Coerce| |$SubDom|)) + (PROG (|dcName| |makeFunc| |LETTMP#1| |funlist| |a| |b| |d| |ISTMP#1| + |xargs| |maxargs| |impls| SL |fun|) + (RETURN + (SEQ + (PROGN + (SPADLET |dcName| (CAR |dc|)) + (COND + ((NULL (MEMQ |dcName| (QUOTE (|Record| |Union| |Enumeration|)))) NIL) + ((QUOTE T) + (SPADLET |fun| NIL) + (SPADLET |makeFunc| + (OR + (GETL |dcName| (QUOTE |makeFunctionList|)) + (|systemErrorHere| (MAKESTRING "findFunctionInCategory")))) + (SPADLET |LETTMP#1| + (FUNCALL |makeFunc| (QUOTE $) |dc| |$CategoryFrame|)) + (SPADLET |funlist| (CAR |LETTMP#1|)) + (SPADLET |maxargs| (SPADDIFFERENCE 1)) + (SPADLET |impls| NIL) + (DO ((#0=#:G167553 |funlist| (CDR #0#)) (#1=#:G167537 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |a| (CAR #1#)) + (SPADLET |b| (CADR #1#)) + (SPADLET |d| (CADDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NULL (EQ |a| |op|)) NIL) + ((AND (PAIRP |d|) + (EQ (QCAR |d|) (QUOTE XLAM)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |d|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |xargs| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((PAIRP |xargs|) + (SPADLET |maxargs| (MAX |maxargs| (|#| |xargs|)))) + ((QUOTE T) + (SPADLET |maxargs| (MAX |maxargs| 1)))) + (SPADLET |impls| + (CONS + (CONS |b| (CONS NIL (CONS (QUOTE T) (CONS |d| NIL)))) + |impls|))) + ((QUOTE T) + (SPADLET |impls| + (CONS + (CONS |b| (CONS |d| (CONS (QUOTE T) (CONS |d| NIL)))) + |impls|))))))) + (SPADLET |impls| (NREVERSE |impls|)) + (COND + ((NEQUAL |maxargs| (SPADDIFFERENCE 1)) + (SPADLET SL NIL) + (DO ((|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| |maxargs|) NIL) + (SEQ + (EXIT + (SPADLET |impls| + (SUBSTQ (GENSYM) (INTERNL "#" (STRINGIMAGE |i|)) |impls|))))))) + (AND + |impls| + (PROGN + (SPADLET SL (|constructSubst| |dc|)) + (DO ((#2=#:G167569 |impls| (CDR #2#)) (|mm| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |fun| + (NCONC |fun| + (|findFunctionInDomain1| |mm| |op| |tar| + |args1| |args2| SL)))))))) + (COND + ((AND (NULL |fun|) |$reportBottomUpFlag|) + (|sayMSG| + (|concat| + (CONS " -> no appropriate" + (APPEND (|bright| |op|) + (CONS "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"]) + +(DEFUN |matchMmCond| (|cond|) + (PROG (|$domPvar| |conds| |dom| |ISTMP#2| |x| |ISTMP#1| |cond1|) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$domPvar| NIL) + (OR + (ATOM |cond|) + (COND + ((OR + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T))) + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |and|)) + (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T)))) + (PROG (#0=#:G167622) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G167628 NIL (NULL #0#)) + (#2=#:G167629 |conds| (CDR #2#)) + (|c| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |c| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|matchMmCond| |c|))))))))) + ((OR + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T))) + (AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |or|)) + (PROGN (SPADLET |conds| (QCDR |cond|)) (QUOTE T)))) + (PROG (#3=#:G167636) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G167642 NIL #3#) + (#5=#:G167643 |conds| (CDR #5#)) + (|c| NIL)) + ((OR #4# (ATOM #5#) (PROGN (SETQ |c| (CAR #5#)) NIL)) #3#) + (SEQ (EXIT (SETQ #3# (OR #3# (|matchMmCond| |c|))))))))) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (NEQUAL (|hasCaty| |dom| |x| NIL) (QUOTE |failed|))) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |not|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |cond1| (QCAR |ISTMP#1|)) (QUOTE T))))) + (NULL (|matchMmCond| |cond1|))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "matchMmCond" (CONS "unknown form of condition" NIL))))))))))) + +;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) + +(DEFUN |matchMmSig| (|mm| |tar| |args1| |args2|) + (PROG (|sig| |arg| |x1| |x2| |a| |y| |x| |ISTMP#1| |v| |rtc| |b|) + (RETURN + (SEQ + (PROGN + (SPADLET |sig| (CAR |mm|)) + (COND + ((CONTAINED (QUOTE |#|) |sig|) + (SPADLET |sig| + (PROG (#0=#:G167685) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167690 |sig| (CDR #1#)) (|t| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|replaceSharpCalls| (COPY |t|)) #0#)))))))))) + (COND + ((NULL |args1|) (|matchMmSigTar| |tar| (CAR |sig|))) + ((QUOTE T) + (SPADLET |a| (CDR |sig|)) + (SPADLET |arg| NIL) + (DO ((|i| 1 (QSADD1 |i|)) (#2=#:G167719 NIL (NULL |b|))) + ((OR (NULL (AND |args1| |args2| |a|)) #2#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x1| (CAR |args1|)) + (SPADLET |args1| (CDR |args1|)) + (SPADLET |x2| (CAR |args2|)) + (SPADLET |args2| (CDR |args2|)) + (SPADLET |x| (CAR |a|)) + (SPADLET |a| (CDR |a|)) + (SPADLET |rtc| NIL) + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |SubDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |x| |y|))) + (SPADLET |b| + (OR + (|isEqualOrSubDomain| |x1| |x|) + (AND + (STRINGP |x|) + (PAIRP |x1|) + (EQ (QCAR |x1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |v| (QCAR |ISTMP#1|)) (QUOTE T)))) + (BOOT-EQUAL |x| (PNAME |v|))) + (COND + ((AND |$SubDom| (|isSubDomain| |x| |x1|)) + (SPADLET |rtc| (QUOTE T))) + (|$Coerce| + (OR (BOOT-EQUAL |x2| |x|) (|canCoerceFrom| |x1| |x|))) + ((QUOTE T) + (AND (PAIRP |x1|) + (EQ (QCAR |x1|) (QUOTE |Variable|)) + (BOOT-EQUAL |x| (QUOTE (|Symbol|)))))))) + (SPADLET $RTC (CONS |rtc| $RTC)))))) + (AND + (NULL |args1|) + (NULL |a|) + |b| + (|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) + +(DEFUN |matchMmSigTar| (|t1| |t2|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (OR + (NULL |t1|) + (COND + ((|isEqualOrSubDomain| |t2| |t1|) (QUOTE T)) + ((QUOTE T) + (COND + ((AND (PAIRP |t2|) + (EQ (QCAR |t2|) (QUOTE |Union|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((BOOT-EQUAL |a| (MAKESTRING "failed")) + (RETURN (|matchMmSigTar| |t1| |b|)))) + (COND + ((BOOT-EQUAL |b| (MAKESTRING "failed")) + (RETURN (|matchMmSigTar| |t1| |a|))) + ((QUOTE T) NIL)))) + (AND |$Coerce| + (COND + ((|isPartialMode| |t1|) (|resolveTM| |t2| |t1|)) + ((QUOTE T) (|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 + +(DEFUN |constructSubst| (|d|) + (PROG (SL) + (RETURN + (SEQ + (PROGN + (SPADLET SL (LIST (CONS (QUOTE $) |d|))) + (DO ((#0=#:G167778 (CDR |d|) (CDR #0#)) (|x| NIL) (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET SL + (CONS + (CONS (INTERNL (MAKESTRING "#") (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] + +(DEFUN |filterModemapsFromPackages| (|mms| |names| |op|) + (PROG (|mpolys| |mpacks| |type| |name| |found| |good| |bad|) + (RETURN + (SEQ + (PROGN + (SPADLET |good| NIL) + (SPADLET |bad| NIL) + (SPADLET |mpolys| + (QUOTE ("Polynomial" + "MultivariatePolynomial" + "DistributedMultivariatePolynomial" + "HomogeneousDistributedMultivariatePolynomial"))) + (SPADLET |mpacks| (QUOTE ("MFactorize" "MRationalFactorize"))) + (DO ((#0=#:G167795 |mms| (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |mm| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((|isFreeFunctionFromMm| |mm|) (SPADLET |bad| (CONS |mm| |bad|))) + ((QUOTE T) + (SPADLET |type| (|getDomainFromMm| |mm|)) + (COND + ((NULL |type|) (SPADLET |bad| (CONS |mm| |bad|))) + ((QUOTE T) + (COND ((PAIRP |type|) (SPADLET |type| (CAR |type|)))) + (COND + ((BOOT-EQUAL + (GETDATABASE |type| (QUOTE CONSTRUCTORKIND)) + (QUOTE |category|)) + (SPADLET |bad| (CONS |mm| |bad|))) + ((QUOTE T) + (SPADLET |name| (|object2String| |type|)) + (SPADLET |found| NIL) + (DO ((#1=#:G167805 |names| (CDR #1#)) (|n| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |n| (CAR #1#)) NIL) + (NULL (NULL |found|))) + NIL) + (SEQ + (EXIT + (COND + ((STRPOS |n| |name| 0 NIL) (SPADLET |found| (QUOTE T))) + ((AND (BOOT-EQUAL |op| (QUOTE |factor|)) + (|member| |n| |mpolys|) + (|member| |name| |mpacks|)) + (SPADLET |found| (QUOTE T))))))) + (COND + (|found| (SPADLET |good| (CONS |mm| |good|))) + ((QUOTE T) (SPADLET |bad| (CONS |mm| |bad|))))))))))))) + (CONS |good| (CONS |bad| NIL))))))) + +;isTowerWithSubdomain(towerType,elem) == +; not PAIRP towerType => NIL +; dt := deconstructT towerType +; 2 ^= #dt => NIL +; s := underDomainOf(towerType) +; isEqualOrSubDomain(s,elem) and constructM(first dt,[elem]) + +(DEFUN |isTowerWithSubdomain| (|towerType| |elem|) + (PROG (|dt| |s|) + (RETURN + (COND + ((NULL (PAIRP |towerType|)) NIL) + ((QUOTE T) + (SPADLET |dt| (|deconstructT| |towerType|)) + (COND + ((NEQUAL 2 (|#| |dt|)) NIL) + ((QUOTE T) + (SPADLET |s| (|underDomainOf| |towerType|)) + (AND + (|isEqualOrSubDomain| |s| |elem|) + (|constructM| (CAR |dt|) (CONS |elem| NIL)))))))))) + +;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 + +(DEFUN |selectMmsGen,exact?| (|mmS| |tar| |args|) + (PROG (|sig| |mmC| |c| |t| |a| |ok| |ex| |inex|) + (RETURN + (SEQ + (SPADLET |ex| (SPADLET |inex| NIL)) + (DO ((#0=#:G167880 |mmS| (CDR #0#)) (|mm| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |mm| (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR |mm|)) + (SPADLET |mmC| (CAADR |mm|)) + |mm|) + NIL)) + NIL) + (SEQ + (PROGN + (SPADLET |c| (CAR |sig|)) + (SPADLET |t| (CADR |sig|)) + (SPADLET |a| (CDDR |sig|)) + |sig|) + (SPADLET |ok| (QUOTE T)) + (DO ((#1=#:G167892 |a| (CDR #1#)) + (|pat| NIL) + (#2=#:G167893 |args| (CDR #2#)) + (|arg| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |pat| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |arg| (CAR #2#)) NIL) + (NULL |ok|)) + NIL) + (SEQ + (EXIT + (IF (NULL + (CONTAINED + (CONS (QUOTE |isDomain|) (CONS |pat| (CONS |arg| NIL))) + |mmC|)) + (EXIT (SPADLET |ok| NIL)))))) + (IF |ok| (EXIT (SPADLET |ex| (CONS |mm| |ex|)))) + (EXIT (SPADLET |inex| (CONS |mm| |inex|))))) + (EXIT (CONS |ex| (CONS |inex| NIL))))))) + +(DEFUN |selectMmsGen,matchMms| (|mmaps| |op| |tar| |args1| |args2|) + (PROG (|sig| |mmC| |res| |c| |t| |a| |mmS|) + (RETURN + (SEQ + (SPADLET |mmS| NIL) + (DO ((#0=#:G167949 |mmaps| (CDR #0#)) (#1=#:G167936 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |sig| (CAR #1#)) (SPADLET |mmC| (CADR #1#)) #1#) + NIL)) + NIL) + (SEQ + (SPADLET |$Subst| + (SEQ + (IF (AND |tar| (NULL (|isPartialMode| |tar|))) + (EXIT + (SEQ + (SPADLET |res| (CADR |sig|)) + (IF (|member| |res| (CDDR |sig|)) (EXIT NIL)) + (EXIT (CONS (CONS |res| |tar|) NIL))))) + (EXIT NIL))) + (PROGN + (SPADLET |c| (CAR |sig|)) + (SPADLET |t| (CADR |sig|)) + (SPADLET |a| (CDDR |sig|)) |sig|) + (IF |a| (|matchTypes| |a| |args1| |args2|) NIL) + (EXIT + (IF (NULL (EQ |$Subst| (QUOTE |failed|))) + (EXIT + (SPADLET |mmS| (NCONC (|evalMm| |op| |tar| |sig| |mmC|) |mmS|))))))) + (EXIT |mmS|))))) + +(DEFUN |selectMmsGen| (|op| |tar| |args1| |args2|) + (PROG (|$Subst| |$SymbolType| S |ISTMP#1| |ISTMP#2| |ISTMP#3| |elem| |a| + |args| |fa| |conNames| |haves| |havenots| |havesExact| + |havesInexact| |LETTMP#1| |havesNExact| |havesNInexact| |mmS|) + (DECLARE (SPECIAL |$Subst| |$SymbolType|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$Subst| NIL) + (SPADLET |$SymbolType| NIL) + (COND + ((NULL (SPADLET S (|getModemapsFromDatabase| |op| (QLENGTH |args1|)))) + NIL) + ((QUOTE T) + (COND + ((AND + (BOOT-EQUAL |op| (QUOTE |map|)) + (EQL 2 (|#| |args1|)) + (PROGN + (SPADLET |ISTMP#1| (CAR |args1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |elem| (QCAR |ISTMP#3|)) (QUOTE T)))))))) + (SPADLET |a| (|isTowerWithSubdomain| (CADR |args1|) |elem|))) + (SPADLET |args1| (CONS (CAR |args1|) (CONS |a| NIL))))) + (SPADLET |conNames| NIL) + (COND + ((BOOT-EQUAL |op| (QUOTE |reshape|)) + (SPADLET |args| (APPEND (CDR |args1|) (CDR |args2|)))) + ((QUOTE T) (SPADLET |args| (APPEND |args1| |args2|)))) + (COND (|tar| (SPADLET |args| (CONS |tar| |args|)))) + (SEQ + (DO ((#0=#:G167986 (REMDUP |args|) (CDR #0#)) (|a| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |a| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + (|a| + (EXIT + (COND + ((ATOM |a|) NIL) + ((QUOTE T) + (SPADLET |fa| (QCAR |a|)) + (COND + ((|member| |fa| (QUOTE (|Record| |Union|))) NIL) + ((QUOTE T) + (SPADLET |conNames| + (|insert| (STRINGIMAGE |fa|) |conNames|)))))))))))) + (COND + (|conNames| + (SPADLET |LETTMP#1| (|filterModemapsFromPackages| S |conNames| |op|)) + (SPADLET |haves| (CAR |LETTMP#1|)) + (SPADLET |havenots| (CADR |LETTMP#1|)) |LETTMP#1|) + ((QUOTE T) (SPADLET |haves| NIL) (SPADLET |havenots| S))) + (SPADLET |mmS| NIL) + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS (QUOTE |%l|) + (|bright| "Modemaps from Associated Packages"))))) + (COND + (|haves| + (SPADLET |LETTMP#1| (|selectMmsGen,exact?| |haves| |tar| |args1|)) + (SPADLET |havesExact| (CAR |LETTMP#1|)) + (SPADLET |havesInexact| (CADR |LETTMP#1|)) + (COND + (|$reportBottomUpFlag| + (DO ((#1=#:G167996 (APPEND |havesExact| |havesInexact|) (CDR #1#)) + (|mm| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #1#) (PROGN (SETQ |mm| (CAR #1#)) NIL)) NIL) + (SEQ (EXIT (|sayModemapWithNumber| |mm| |i|)))))) + (COND + (|havesExact| + (SPADLET |mmS| + (|selectMmsGen,matchMms| |havesExact| |op| |tar| |args1| |args2|)) + (COND + (|mmS| + (COND + (|$reportBottomUpFlag| + (|sayMSG| (MAKESTRING " found an exact match!")))) + (RETURN |mmS|)) + ((QUOTE T) NIL)))) + (SPADLET |mmS| + (|selectMmsGen,matchMms| |havesInexact| |op| |tar| + |args1| |args2|))) + (|$reportBottomUpFlag| + (|sayMSG| (MAKESTRING " no modemaps"))) ((QUOTE T) NIL)) + (COND (|mmS| (EXIT |mmS|))) + (COND + (|$reportBottomUpFlag| + (|sayMSG| + (CONS (QUOTE |%l|) (|bright| "Remaining General Modemaps"))))) + (COND + (|havenots| + (SPADLET |LETTMP#1| (|selectMmsGen,exact?| |havenots| |tar| |args1|)) + (SPADLET |havesNExact| (CAR |LETTMP#1|)) + (SPADLET |havesNInexact| (CADR |LETTMP#1|)) + (COND + (|$reportBottomUpFlag| + (DO ((#2=#:G168006 + (APPEND |havesNExact| |havesNInexact|) (CDR #2#)) + (|mm| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) + (SEQ (EXIT (|sayModemapWithNumber| |mm| |i|)))))) + (COND + (|havesNExact| + (SPADLET |mmS| + (|selectMmsGen,matchMms| |havesNExact| |op| |tar| + |args1| |args2|)) + (COND + (|mmS| + (COND + (|$reportBottomUpFlag| (|sayMSG| " found an exact match!"))) + (RETURN |mmS|)) + ((QUOTE T) NIL)))) + (SPADLET |mmS| + (|selectMmsGen,matchMms| |havesNInexact| |op| |tar| + |args1| |args2|))) + (|$reportBottomUpFlag| (|sayMSG| (MAKESTRING " no modemaps"))) + ((QUOTE T) NIL)) + (EXIT |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) + +(DEFUN |matchTypes| (|pm| |args1| |args2|) + (PROG (|p| |t3| |q| |t| |t1| |t0|) + (RETURN + (SEQ + (DO ((#0=#:G168059 |pm| (CDR #0#)) + (|v| NIL) + (#1=#:G168060 |args1| (CDR #1#)) + (|t1| NIL) + (#2=#:G168061 |args2| (CDR #2#)) + (|t2| NIL) + (#3=#:G168062 NIL (BOOT-EQUAL |$Subst| (QUOTE |failed|)))) + ((OR (ATOM #0#) + (PROGN (SETQ |v| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |t1| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |t2| (CAR #2#)) NIL) + #3#) + NIL) + (SEQ + (EXIT + (COND + ((SPADLET |p| (ASSQ |v| |$Subst|)) + (SPADLET |t| (CDR |p|)) + (COND + ((BOOT-EQUAL |t| |t1|) + (AND + |$Coerce| + (EQCAR |t1| (QUOTE |Symbol|)) + (SPADLET |q| (ASSQ |v| |$SymbolType|)) + |t2| + (SPADLET |t3| (|resolveTT| (CDR |q|) |t2|)) + (RPLACD |q| |t3|))) + (|$Coerce| + (COND + ((AND + (EQCAR |t| (QUOTE |Symbol|)) + (SPADLET |q| (ASSQ |v| |$SymbolType|))) + (SPADLET |t| (CDR |q|)))) + (COND + ((AND (EQCAR |t1| (QUOTE |Symbol|)) |t2|) (SPADLET |t1| |t2|))) + (COND + ((SPADLET |t0| (|resolveTT| |t| |t1|)) (RPLACD |p| |t0|)) + ((QUOTE T) (SPADLET |$Subst| (QUOTE |failed|))))) + ((QUOTE T) (SPADLET |$Subst| (QUOTE |failed|))))) + ((QUOTE T) + (SPADLET |$Subst| (CONS (CONS |v| |t1|) |$Subst|)) + (COND + ((AND (EQCAR |t1| (QUOTE |Symbol|)) |t2|) + (SPADLET |$SymbolType| (CONS (CONS |v| |t2|) |$SymbolType|))) + ((QUOTE T) NIL))))))))))) + +;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 + +(DEFUN |evalMm| (|op| |tar| |sig| |mmC|) + (PROG (SL |m| |dc| |t| |args| |mS|) + (RETURN + (SEQ + (PROGN + (SPADLET |mS| NIL) + (DO ((#0=#:G168106 (|evalMmStack| |mmC|) (CDR #0#)) (|st| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |st| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET SL (|evalMmCond| |op| |sig| |st|)) + (COND + ((NULL (EQ SL (QUOTE |failed|))) + (PROGN + (SPADLET SL (|fixUpTypeArgs| SL)) + (SPADLET |sig| + (PROG (#1=#:G168116) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G168121 |sig| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) + (NREVERSE0 #1#)) + (SEQ + (EXIT + (SETQ #1# + (CONS + (|subCopy| (|deepSubCopy| |x| SL) |$Subst|) + #1#)))))))) + (COND + ((NULL (|containsVars| |sig|)) + (COND + ((AND + (|isFreeFunctionFromMmCond| |mmC|) + (SPADLET |m| (|evalMmFreeFunction| |op| |tar| |sig| |mmC|))) + (SPADLET |mS| (NCONC |m| |mS|))) + ((PROG (#3=#:G168127) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G168133 NIL #3#) + (#5=#:G168134 |sig| (CDR #5#)) + (|arg| NIL)) + ((OR #4# (ATOM #5#) (PROGN (SETQ |arg| (CAR #5#)) NIL)) + #3#) + (SEQ + (EXIT + (SETQ #3# (OR #3# (NULL (|isValidType| |arg|))))))))) + NIL) + ((QUOTE T) + (SPADLET |dc| (CAR |sig|)) + (SPADLET |t| (CADR |sig|)) + (SPADLET |args| (CDDR |sig|)) + (COND + ((OR |$Coerce| (NULL |tar|) (BOOT-EQUAL |tar| |t|)) + (SPADLET |mS| + (NCONC + (|findFunctionInDomain| |op| |dc| |t| |args| + |args| NIL (QUOTE 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 + +(DEFUN |evalMmFreeFunction| (|op| |tar| |sig| |mmC|) + (PROG (|dc| |t| |args| |nilArgs|) + (RETURN + (SEQ + (PROGN + (SPADLET |dc| (CAR |sig|)) + (SPADLET |t| (CADR |sig|)) + (SPADLET |args| (CDDR |sig|)) + (COND + ((OR |$Coerce| (NULL |tar|) (BOOT-EQUAL |tar| |t|)) + (SPADLET |nilArgs| NIL) + (DO ((#0=#:G168165 |args| (CDR #0#)) (|a| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |a| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (SPADLET |nilArgs| (CONS NIL |nilArgs|))))) + (CONS + (CONS + (CONS (CONS (QUOTE |_FreeFunction_|) |dc|) (CONS |t| |args|)) + (CONS (CONS |t| |args|) (CONS |nilArgs| NIL))) + NIL)) + ((QUOTE T) 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]] + +(DEFUN |evalMmStack| (|mmC|) + (PROG (|a| |mmD| |pvar| |cat| |args| |ISTMP#1| |pat| |ISTMP#2| |x|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE AND)) + (PROGN (SPADLET |a| (QCDR |mmC|)) (QUOTE T))) + (CONS + (PROG (#0=#:G168213) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168218 |a| (CDR #1#)) (|cond| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |cond| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (NCONC #0# (|evalMmStackInner| |cond|)))))))) + NIL)) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE OR)) + (PROGN (SPADLET |args| (QCDR |mmC|)) (QUOTE T))) + (PROG (#2=#:G168224) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G168229 |args| (CDR #3#)) (|a| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) #2#) + (SEQ (EXIT (SETQ #2# (APPEND #2# (|evalMmStack| |a|))))))))) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |partial|)) + (PROGN (SPADLET |mmD| (QCDR |mmC|)) (QUOTE T))) + (|evalMmStack| |mmD|)) + ((AND + (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mmC|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |cat| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE |Join|)) + (PROGN (SPADLET |args| (QCDR |cat|)) (QUOTE T))) + (|evalMmStack| + (CONS + (QUOTE AND) + (PROG (#4=#:G168239) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G168244 |args| (CDR #5#)) (|c| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |c| (CAR #5#)) NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (CONS (QUOTE |ofCategory|) (CONS |pvar| (CONS |c| NIL))) + #4#)))))))))) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) (QUOTE |ofType|))) (CONS NIL NIL)) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mmC|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pat| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((MEMQ |x| (QUOTE (ATTRIBUTE SIGNATURE))) + (CONS + (CONS + (CONS + (QUOTE |ofCategory|) + (CONS |pat| + (CONS + (CONS (QUOTE CATEGORY) (CONS (QUOTE |unknown|) (CONS |x| NIL))) + NIL))) + NIL) + NIL)) + ((QUOTE T) + (CONS (CONS (QUOTE |ofCategory|) (CONS |pat| (CONS |x| NIL))) NIL)))) + ((QUOTE T) (CONS (CONS |mmC| NIL) NIL))))))) + +;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] + +(DEFUN |evalMmStackInner| (|mmC|) + (PROG (|mmD| |pvar| |cat| |args| |ISTMP#1| |pat| |ISTMP#2| |x|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE OR)) + (PROGN (SPADLET |args| (QCDR |mmC|)) (QUOTE T))) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "evalMmStackInner" + (CONS "OR condition nested inside an AND" NIL)))) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |partial|)) + (PROGN (SPADLET |mmD| (QCDR |mmC|)) (QUOTE T))) + (|evalMmStackInner| |mmD|)) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mmC|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |cat| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE |Join|)) + (PROGN (SPADLET |args| (QCDR |cat|)) (QUOTE T))) + (PROG (#0=#:G168306) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168311 |args| (CDR #1#)) (|c| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |c| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS (QUOTE |ofCategory|) (CONS |pvar| (CONS |c| NIL))) + #0#)))))))) + ((AND (PAIRP |mmC|) (EQ (QCAR |mmC|) (QUOTE |ofType|))) NIL) + ((AND (PAIRP |mmC|) + (EQ (QCDR |mmC|) NIL) + (EQ (QCAR |mmC|) (QUOTE |isAsConstant|))) + NIL) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mmC|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pat| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |x| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((MEMQ |x| (QUOTE (ATTRIBUTE SIGNATURE))) + (CONS + (CONS + (QUOTE |ofCategory|) + (CONS |pat| + (CONS + (CONS (QUOTE CATEGORY) (CONS (QUOTE |unknown|) (CONS |x| NIL))) + NIL))) + NIL)) + ((QUOTE T) + (CONS (CONS (QUOTE |ofCategory|) (CONS |pat| (CONS |x| NIL))) NIL)))) + ((QUOTE T) (CONS |mmC| NIL))))))) + +;evalMmCond(op,sig,st) == +; $insideEvalMmCondIfTrue : local := true +; evalMmCond0(op,sig,st) + +(DEFUN |evalMmCond| (|op| |sig| |st|) + (PROG (|$insideEvalMmCondIfTrue|) + (DECLARE (SPECIAL |$insideEvalMmCondIfTrue|)) + (RETURN + (PROGN + (SPADLET |$insideEvalMmCondIfTrue| (QUOTE T)) + (|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) + +(DEFUN |evalMmCond0| (|op| |sig| |st|) + (PROG (SL |p1| |t| |t1| |b|) + (RETURN + (SEQ + (PROGN + (SPADLET SL (|evalMmDom| |st|)) + (COND + ((BOOT-EQUAL SL (QUOTE |failed|)) (QUOTE |failed|)) + ((QUOTE T) + (DO ((#0=#:G168355 SL (CDR #0#)) + (|p| NIL) + (#1=#:G168356 NIL (AND |p1| (NULL |b|)))) + ((OR (ATOM #0#) (PROGN (SETQ |p| (CAR #0#)) NIL) #1#) NIL) + (SEQ + (EXIT + (SPADLET |b| + (PROGN + (SPADLET |p1| (ASSQ (CAR |p|) |$Subst|)) + (AND |p1| + (PROGN + (SPADLET |t1| (CDR |p1|)) + (SPADLET |t| (CDR |p|)) + (OR + (BOOT-EQUAL |t| |t1|) + (COND + ((|containsVars| |t|) + (COND + ((AND |$Coerce| (EQCAR |t1| (QUOTE |Symbol|))) + (SPADLET |t1| (|getSymbolType| (CAR |p|))))) + (|resolveTM1| |t1| |t|)) + ((QUOTE T) + (AND + |$Coerce| + (COND + ((AND + (BOOT-EQUAL |t1| |$AnonymousFunction|) + (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Mapping|))) + |t|) + ((AND + (BOOT-EQUAL (CAR |p|) (CADR |sig|)) + (NULL (|member| (CAR |p|) (CDDR |sig|)))) + (COND + ((|canCoerceFrom| |t| |t1|) (QUOTE T)) + ((QUOTE T) NIL))) + ((|canCoerceFrom| |t1| |t|) (QUOTE T)) + ((|isSubDomain| |t| |t1|) (RPLACD |p| |t1|)) + ((QUOTE T) + (AND + (EQCAR |t1| (QUOTE |Symbol|)) + (|canCoerceFrom| + (|getSymbolType| (CAR |p|)) |t|))))))))))))))) + (OR + (AND SL |p1| (NULL |b|) (QUOTE |failed|)) + (|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 + +(DEFUN |fixUpTypeArgs| (SL) + (PROG (|v| |t2| |t1|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G168383 SL (CDR #0#)) (|p| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |p| (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |v| (CAR |p|)) (SPADLET |t2| (CDR |p|)) |p|) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |t1| (LASSOC |v| |$Subst|)) + (COND + ((NULL |t1|) (RPLACD |p| (|replaceSharpCalls| |t2|))) + ((QUOTE T) (RPLACD |p| (|coerceTypeArgs| |t1| |t2| SL)))))))) + SL))))) + +;replaceSharpCalls t == +; noSharpCallsHere t => t +; doReplaceSharpCalls t + +(DEFUN |replaceSharpCalls| (|t|) + (COND + ((|noSharpCallsHere| |t|) |t|) + ((QUOTE 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]] + +(DEFUN |doReplaceSharpCalls| (|t|) + (PROG (|ISTMP#1| |l|) + (RETURN + (SEQ + (COND + ((ATOM |t|) |t|) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |#|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|#| |l|)) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |construct|)) + (PROGN (SPADLET |l| (QCDR |t|)) (QUOTE T))) + (EVAL (CONS (QUOTE LIST) |l|))) + ((QUOTE T) + (CONS + (CAR |t|) + (PROG (#0=#:G168409) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168414 (CDR |t|) (CDR #1#)) (|u| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |u| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|doReplaceSharpCalls| |u|) #0#)))))))))))))) + +;noSharpCallsHere t == +; t isnt [con, :args] => true +; MEMQ(con,'(construct _#)) => NIL +; and/[noSharpCallsHere u for u in args] + +(DEFUN |noSharpCallsHere| (|t|) + (PROG (|con| |args|) + (RETURN + (SEQ + (COND + ((NULL + (AND + (PAIRP |t|) + (PROGN + (SPADLET |con| (QCAR |t|)) + (SPADLET |args| (QCDR |t|)) + (QUOTE T)))) + (QUOTE T)) + ((MEMQ |con| (QUOTE (|construct| |#|))) NIL) + ((QUOTE T) + (PROG (#0=#:G168431) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G168437 NIL (NULL #0#)) + (#2=#:G168438 |args| (CDR #2#)) + (|u| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |u| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|noSharpCallsHere| |u|)))))))))))))) + +;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]] + +(DEFUN |coerceTypeArgs| (|t1| |t2| SL) + (PROG (|con1| |args1| |con2| |args2| |coSig| |csub1| |csub2| |cs1| |cs2|) + (RETURN + (SEQ + (COND + ((OR + (NULL + (AND + (PAIRP |t1|) + (PROGN + (SPADLET |con1| (QCAR |t1|)) + (SPADLET |args1| (QCDR |t1|)) + (QUOTE T)))) + (NULL + (AND + (PAIRP |t2|) + (PROGN + (SPADLET |con2| (QCAR |t2|)) + (SPADLET |args2| (QCDR |t2|)) + (QUOTE T))))) + |t2|) + ((NEQUAL |con1| |con2|) |t2|) + ((QUOTE T) + (SPADLET |coSig| (CDR (GETDATABASE (CAR |t1|) (QUOTE COSIG)))) + (COND + ((PROG (#0=#:G168459) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G168465 NIL (NULL #0#)) + (#2=#:G168466 |coSig| (CDR #2#)) + (#3=#:G168451 NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ #3# (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# #3#))))))) + |t2|) + ((QUOTE T) + (SPADLET |csub1| (|constructSubst| |t1|)) + (SPADLET |csub2| (|constructSubst| |t2|)) + (SPADLET |cs1| (CDR (|getConstructorSignature| |con1|))) + (SPADLET |cs2| (CDR (|getConstructorSignature| |con2|))) + (CONS |con1| + (PROG (#4=#:G168481) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G168490 |args1| (CDR #5#)) + (|arg1| NIL) + (#6=#:G168491 |args2| (CDR #6#)) + (|arg2| NIL) + (#7=#:G168492 |cs1| (CDR #7#)) + (|c1| NIL) + (#8=#:G168493 |cs2| (CDR #8#)) + (|c2| NIL) + (#9=#:G168494 |coSig| (CDR #9#)) + (|cs| NIL)) + ((OR (ATOM #5#) + (PROGN (SETQ |arg1| (CAR #5#)) NIL) + (ATOM #6#) + (PROGN (SETQ |arg2| (CAR #6#)) NIL) + (ATOM #7#) + (PROGN (SETQ |c1| (CAR #7#)) NIL) + (ATOM #8#) + (PROGN (SETQ |c2| (CAR #8#)) NIL) + (ATOM #9#) + (PROGN (SETQ |cs| (CAR #9#)) NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|makeConstrArg| |arg1| |arg2| + (|constrArg| |c1| |csub1| SL) + (|constrArg| |c2| |csub2| SL) + |cs|) + #4#)))))))))))))))) + +;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 + +(DEFUN |constrArg| (|v| |sl| SL) + (PROG (|x| |y|) + (RETURN + (COND + ((SPADLET |x| (LASSOC |v| |sl|)) + (COND + ((SPADLET |y| (LASSOC |x| SL)) |y|) + ((SPADLET |y| (LASSOC |x| |$Subst|)) |y|) + ((QUOTE T) |x|))) + ((SPADLET |y| (LASSOC |x| |$Subst|)) |y|) + ((QUOTE T) |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 + +(DEFUN |makeConstrArg| (|arg1| |arg2| |t1| |t2| |cs|) + (PROG (|ISTMP#1| |l| |obj1| |obj2|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |arg1|) + (EQ (QCAR |arg1|) (QUOTE |#|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |arg1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |arg1| (|#| |l|)))) + (COND + ((AND (PAIRP |arg2|) + (EQ (QCAR |arg2|) (QUOTE |#|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |arg2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |l| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |arg2| (|#| |l|)))) + (COND + (|cs| |arg2|) + ((BOOT-EQUAL |t1| |t2|) |arg2|) + ((QUOTE T) + (SPADLET |obj1| (|objNewWrap| |arg1| |t1|)) + (SPADLET |obj2| (|coerceInt| |obj1| |t2|)) + (COND + ((NULL |obj2|) + (|throwKeyedMsgCannotCoerceWithValue| (|wrap| |arg1|) |t1| |t2|)) + ((QUOTE T) (|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 + +(DEFUN |evalMmDom| (|st|) + (PROG (|d| |p| |d1| |ISTMP#1| |v| |ISTMP#2| |fun| SL) + (RETURN + (SEQ + (PROGN + (SPADLET SL NIL) + (DO ((#0=#:G168608 |st| (CDR #0#)) + (|mmC| NIL) + (#1=#:G168609 NIL (BOOT-EQUAL SL (QUOTE |failed|)))) + ((OR (ATOM #0#) (PROGN (SETQ |mmC| (CAR #0#)) NIL) #1#) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mmC|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |d| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((STRINGP |d|) (SPADLET SL (QUOTE |failed|))) + ((SPADLET |p| + (AND (ASSQ |v| SL) (NULL (BOOT-EQUAL |d| (CDR |p|))))) + (SPADLET SL (QUOTE |failed|))) + ((QUOTE T) + (SPADLET |d1| (|subCopy| |d| SL)) + (COND + ((AND (CONSP |d1|) (MEMQ |v| |d1|)) + (SPADLET SL (QUOTE |failed|))) + ((QUOTE T) + (SPADLET SL (|augmentSub| |v| |d1| SL))))))) + ((AND (PAIRP |mmC|) + (EQ (QCAR |mmC|) (QUOTE |isFreeFunction|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |mmC|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |fun| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET 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) + +(DEFUN |orderMmCatStack| (|st|) + (PROG (|vars| |cat| |mem| |havevars| |haventvars|) + (RETURN + (SEQ + (COND + ((OR (NULL |st|) (NULL (CDR |st|))) |st|) + ((QUOTE T) + (SPADLET |vars| + (DELETE-DUPLICATES + (PROG (#0=#:G168643) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168649 |st| (CDR #1#)) (|s| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |s| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((|isPatternVar| (CADR |s|)) + (SETQ #0# (CONS (CADR |s|) #0#))))))))))) + (COND + ((NULL |vars|) |st|) + ((QUOTE T) + (SPADLET |havevars| NIL) + (SPADLET |haventvars| NIL) + (DO ((#2=#:G168662 |st| (CDR #2#)) (|s| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |s| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |cat| (CADDR |s|)) + (SPADLET |mem| NIL) + (DO ((#3=#:G168672 |vars| (CDR #3#)) (|v| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |v| (CAR #3#)) NIL) + (NULL (NULL |mem|))) + NIL) + (SEQ + (EXIT + (COND + ((MEMQ |v| |cat|) + (SPADLET |mem| (QUOTE T)) + (SPADLET |havevars| (CONS |s| |havevars|))) + ((QUOTE T) NIL))))) + (COND + ((NULL |mem|) (SPADLET |haventvars| (CONS |s| |haventvars|))) + ((QUOTE T) NIL)))))) + (COND + ((NULL |havevars|) |st|) + ((QUOTE T) + (SPADLET |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 + +(DEFUN |mmCatComp| (|c1| |c2|) + (PROG (|b1| |b2|) + (RETURN + (PROGN + (SPADLET |b1| (ASSQ (CADR |c1|) |$Subst|)) + (SPADLET |b2| (ASSQ (CADR |c2|) |$Subst|)) + (COND ((AND |b1| (NULL |b2|)) (QUOTE T)) ((QUOTE T) NIL)))))) + +;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 + +(DEFUN |evalMmCat| (|op| |sig| |stack| SL) + (PROG (|$hope| |numConds| |st| S |makingProgress|) + (DECLARE (SPECIAL |$hope|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$hope| NIL) + (SPADLET |numConds| (|#| |stack|)) + (SPADLET |stack| + (|orderMmCatStack| + (PROG (#0=#:G168707) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168713 |stack| (CDR #1#)) (|mmC| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |mmC| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((EQCAR |mmC| (QUOTE |ofCategory|)) + (SETQ #0# (CONS |mmC| #0#))))))))))) + (DO ((#2=#:G168731 NIL (NULL |makingProgress|))) + ((OR (NULL |stack|) #2#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |st| |stack|) + (SPADLET |stack| NIL) + (SPADLET |makingProgress| NIL) + (DO ((#3=#:G168743 |st| (CDR #3#)) (|mmC| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |mmC| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET S (|evalMmCat1| |mmC| |op| SL)) + (COND + ((AND (BOOT-EQUAL S (QUOTE |failed|)) |$hope|) + (SPADLET |stack| (CONS |mmC| |stack|))) + ((BOOT-EQUAL S (QUOTE |failed|)) (RETURN S)) + ((NULL (ATOM S)) + (PROGN + (SPADLET |makingProgress| (QUOTE T)) + (SPADLET SL (|mergeSubs| S SL))))))))))))) + (COND + ((OR |stack| (BOOT-EQUAL S (QUOTE |failed|))) (QUOTE |failed|)) + ((QUOTE T) 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 + +(DEFUN |evalMmCat1| (|mmC| |op| SL) + (PROG (|$domPvar| |d| |c| |p| |dom| NSL) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ + (PROGN + (SPADLET |d| (CADR |mmC|)) + (SPADLET |c| (CADDR |mmC|)) + (SPADLET |$domPvar| NIL) + (SPADLET |$hope| NIL) + (SPADLET NSL (|hasCate| |d| |c| SL)) + (COND + ((AND + (BOOT-EQUAL NSL (QUOTE |failed|)) + (|isPatternVar| |d|) + |$Coerce| + (SPADLET |p| (ASSQ |d| |$Subst|)) + (OR + (EQCAR (CDR |p|) (QUOTE |Variable|)) + (EQCAR (CDR |p|) (QUOTE |Symbol|)))) + (RPLACD |p| (|getSymbolType| |d|)) (|hasCate| |d| |c| SL)) + ((AND (BOOT-EQUAL NSL (QUOTE |failed|)) (|isPatternVar| |d|)) + (SPADLET |dom| (|defaultTypeForCategory| |c| SL)) + (SEQ + (COND + ((NULL |dom|) + (EXIT + (COND ((NEQUAL |op| (QUOTE |coerce|)) (EXIT (QUOTE |failed|)))))) + ((NULL (SPADLET |p| (ASSQ |d| |$Subst|))) + (EXIT + (COND + (|dom| (SPADLET NSL (CONS (CONS |d| |dom|) NIL))) + ((NEQUAL |op| (QUOTE |coerce|)) (QUOTE |failed|)))))) + (COND + ((|containsVars| |dom|) + (SPADLET |dom| (|resolveTM| (CDR |p|) |dom|)))) + (COND + ((AND |$Coerce| (|canCoerce| (CDR |p|) |dom|)) + (SPADLET NSL (CONS (CONS |d| |dom|) NIL))) + ((NEQUAL |op| (QUOTE |coerce|)) + (QUOTE |failed|))))) + ((QUOTE T) 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) + +(DEFUN |hasCate| (|dom| |cat| SL) + (PROG (NSL |p| S |v| |d| SL1) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |dom| |$EmptyMode|) NIL) + ((|isPatternVar| |dom|) + (COND + ((AND (SPADLET |p| (ASSQ |dom| SL)) + (NEQUAL + (SPADLET NSL (|hasCate| (CDR |p|) |cat| SL)) + (QUOTE |failed|))) + NSL) + ((OR (SPADLET |p| (ASSQ |dom| |$Subst|)) (SPADLET |p| (ASSQ |dom| SL))) + (SPADLET S (|hasCate1| (CDR |p|) |cat| SL |dom|)) + (COND + ((NULL (BOOT-EQUAL S (QUOTE |failed|))) S) + ((QUOTE T) (|hasCateSpecial| |dom| (CDR |p|) |cat| SL)))) + ((QUOTE T) + (COND ((NEQUAL SL (QUOTE |failed|)) (SPADLET |$hope| (QUOTE T)))) + (QUOTE |failed|)))) + ((QUOTE T) + (SPADLET SL1 + (PROG (#0=#:G168806) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168813 SL (CDR #1#)) (#2=#:G168795 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN (SPADLET |v| (CAR #2#)) (SPADLET |d| (CDR #2#)) #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((NULL (|containsVariables| |d|)) + (SETQ #0# (CONS (CONS |v| |d|) #0#)))))))))) + (COND (SL1 (SPADLET |cat| (|subCopy| |cat| SL1)))) + (|hasCaty| |dom| |cat| SL))))))) + +;hasCate1(dom, cat, SL, domPvar) == +; $domPvar:local := domPvar +; hasCate(dom, cat, SL) + +(DEFUN |hasCate1| (|dom| |cat| SL |domPvar|) + (PROG (|$domPvar|) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (PROGN + (SPADLET |$domPvar| |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) + +(DEFUN |hasCateSpecial| (|v| |dom| |cat| SL) + (PROG (|arg| |ISTMP#1| |d| |dom'| NSL) + (RETURN + (COND + ((AND (PAIRP |dom|) + (EQ (QCAR |dom|) (QUOTE |FactoredForm|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |dom|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |arg| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND ((|isSubDomain| |arg| |$Integer|) (SPADLET |arg| |$Integer|))) + (SPADLET |d| (CONS (QUOTE |FactoredRing|) (CONS |arg| NIL))) + (SPADLET SL (|hasCate| |arg| (QUOTE (|Ring|)) (|augmentSub| |v| |d| SL))) + (COND + ((BOOT-EQUAL SL (QUOTE |failed|)) (QUOTE |failed|)) + ((QUOTE T) (|hasCaty| |d| |cat| SL)))) + ((OR (EQCAR |cat| (QUOTE |Field|)) (EQCAR |cat| (QUOTE |DivisionRing|))) + (COND ((|isSubDomain| |dom| |$Integer|) (SPADLET |dom| |$Integer|))) + (SPADLET |d| (|eqType| (CONS |$QuotientField| (CONS |dom| NIL)))) + (|hasCaty| |dom| (QUOTE (|IntegralDomain|)) (|augmentSub| |v| |d| SL))) + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE |PolynomialCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |d| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |dom'| (CONS (QUOTE |Polynomial|) (CONS |d| NIL))) + (AND + (OR (|containsVars| |d|) (|canCoerceFrom| |dom| |dom'|)) + (|hasCaty| |dom'| |cat| (|augmentSub| |v| |dom'| SL)))) + ((|isSubDomain| |dom| |$Integer|) + (SPADLET NSL + (|hasCate| |$Integer| |cat| (|augmentSub| |v| |$Integer| SL))) + (COND + ((BOOT-EQUAL NSL (QUOTE |failed|)) + (|hasCateSpecialNew| |v| |dom| |cat| SL)) + ((QUOTE T) (|hasCaty| |$Integer| |cat| NSL)))) + ((QUOTE T) (|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) + +(DEFUN |hasCateSpecialNew| (|v| |dom| |cat| SL) + (PROG (|fe| |alg| |fefull| |d| |partialResult|) + (RETURN + (PROGN + (SPADLET |fe| + (|member| (QCAR |cat|) + (QUOTE ( + |ElementaryFunctionCategory| + |TrigonometricFunctionCategory| + |ArcTrigonometricFunctionCategory| + |HyperbolicFunctionCategory| + |ArcHyperbolicFunctionCategory| + |PrimitiveFunctionCategory| + |SpecialFunctionCategory| + |Evalable| + |CombinatorialOpsCategory| + |TranscendentalFunctionCategory| + |AlgebraicallyClosedFunctionSpace| + |ExpressionSpace| + |LiouvillianFunctionCategory| + |FunctionSpace|)))) + (SPADLET |alg| + (|member| (QCAR |cat|) + (QUOTE (|RadicalCategory| |AlgebraicallyClosedField|)))) + (SPADLET |fefull| + (OR |fe| |alg| (EQCAR |cat| (QUOTE |CombinatorialFunctionCategory|)))) + (SPADLET |partialResult| + (COND + ((OR (EQCAR |dom| (QUOTE |Variable|)) (EQCAR |dom| (QUOTE |Symbol|))) + (COND + ((|member| (CAR |cat|) + (QUOTE ( + |SemiGroup| + |AbelianSemiGroup| + |Monoid| + |AbelianGroup| + |AbelianMonoid| + |PartialDifferentialRing| + |Ring| + |InputForm|))) + (SPADLET |d| + (CONS (QUOTE |Polynomial|) + (CONS |$Integer| NIL))) (|augmentSub| |v| |d| SL)) + ((EQCAR |cat| (QUOTE |Group|)) + (SPADLET |d| + (CONS + (QUOTE |Fraction|) + (CONS (CONS (QUOTE |Polynomial|) (CONS |$Integer| NIL)) NIL))) + (|augmentSub| |v| |d| SL)) + (|fefull| + (SPADLET |d| (|defaultTargetFE| |dom|)) (|augmentSub| |v| |d| SL)) + ((QUOTE T) (QUOTE |failed|)))) + ((|isEqualOrSubDomain| |dom| |$Integer|) + (COND + (|fe| + (SPADLET |d| (|defaultTargetFE| |$Integer|)) + (|augmentSub| |v| |d| SL)) + (|alg| + (SPADLET |d| (QUOTE (|AlgebraicNumber|))) + (|augmentSub| |v| |d| SL)) + ((QUOTE T) (QUOTE |failed|)))) + ((BOOT-EQUAL (|underDomainOf| |dom|) |$ComplexInteger|) + (SPADLET |d| (|defaultTargetFE| |$ComplexInteger|)) + (|hasCaty| |d| |cat| (|augmentSub| |v| |d| SL))) + ((AND (BOOT-EQUAL |dom| |$RationalNumber|) |alg|) + (SPADLET |d| (QUOTE (|AlgebraicNumber|))) + (|augmentSub| |v| |d| SL)) + (|fefull| + (SPADLET |d| (|defaultTargetFE| |dom|)) + (|augmentSub| |v| |d| SL)) + ((QUOTE T) (QUOTE |failed|)))) + (COND + ((BOOT-EQUAL |partialResult| (QUOTE |failed|)) (QUOTE |failed|)) + ((QUOTE T) (|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 + +(DEFUN |hasCaty| (|d| |cat| SL) + (PROG (|foo| |sig| |a| |x| |y| S |z| |cond| |p| |S'| |dom| |z'| S1 |ncond| + |ISTMP#1| |ISTMP#2|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE CATEGORY)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |y| (QCDR |ISTMP#1|)) (QUOTE T))))) + (|hasAttSig| |d| (|subCopy| |y| (|constructSubst| |d|)) SL)) + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE SIGNATURE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |foo| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |sig| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasSig| |d| |foo| (|subCopy| |sig| (|constructSubst| |d|)) SL)) + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|hasAtt| |d| (|subCopy| |a| (|constructSubst| |d|)) SL)) + ((SPADLET |x| (|hasCat| (|opOf| |d|) (|opOf| |cat|))) + (COND + ((SPADLET |y| (KDR |cat|)) + (SPADLET S (|constructSubst| |d|)) + (DO ((#0=#:G168962 |x| (CDR #0#)) + (#1=#:G168932 NIL) + (#2=#:G168963 NIL (NULL (BOOT-EQUAL S1 (QUOTE |failed|))))) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |z| (CAR #1#)) + (SPADLET |cond| (CDR #1#)) + #1#) + NIL) + #2#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |S'| + (PROG (#3=#:G168976) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G168982 S (CDR #4#)) (#5=#:G168919 NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN + (PROGN + (SPADLET |p| (CAR #5#)) + (SPADLET |d| (CDR #5#)) + #5#) + NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS (CONS |p| (|mkDomPvar| |p| |d| |z| |y|)) #3#)))))))) + (COND + (|$domPvar| + (SPADLET |dom| + (CONS (CAR |d|) + (PROG (#6=#:G168994) + (SPADLET #6# NIL) + (RETURN + (DO ((|i| 0 (QSADD1 |i|)) + (#7=#:G169000 (CDR |d|) (CDR #7#)) + (|arg| NIL)) + ((OR (ATOM #7#) (PROGN (SETQ |arg| (CAR #7#)) NIL)) + (NREVERSE0 #6#)) + (SEQ + (EXIT + (SETQ #6# (CONS (|domArg| |arg| |i| |z| |y|) #6#))))))))) + (SPADLET SL (|augmentSub| |$domPvar| |dom| (COPY SL))))) + (SPADLET |z'| + (PROG (#8=#:G169010) + (SPADLET #8# NIL) + (RETURN + (DO ((#9=#:G169015 |z| (CDR #9#)) (|a| NIL)) + ((OR (ATOM #9#) (PROGN (SETQ |a| (CAR #9#)) NIL)) + (NREVERSE0 #8#)) + (SEQ (EXIT (SETQ #8# (CONS (|domArg2| |a| S |S'|) #8#)))))))) + (SPADLET S1 (|unifyStruct| |y| |z'| (COPY SL))) + (COND + ((NULL (BOOT-EQUAL S1 (QUOTE |failed|))) + (SPADLET S1 + (COND + ((ATOM |cond|) S1) + ((QUOTE T) + (SPADLET |ncond| (|subCopy| |cond| S)) + (COND + ((AND (PAIRP |ncond|) + (EQ (QCAR |ncond|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |ncond|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |d|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) |cat|)))))) + (QUOTE |failed|)) + ((QUOTE T) (|hasCaty1| |ncond| S1))))))) + ((QUOTE T) NIL)))))) + S1) + ((ATOM |x|) SL) + ((QUOTE T) + (SPADLET |ncond| (|subCopy| |x| (|constructSubst| |d|))) + (COND + ((AND (PAIRP |ncond|) + (EQ (QCAR |ncond|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |ncond|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |d|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) |cat|)))))) + (QUOTE |failed|)) + ((QUOTE T) (|hasCaty1| |ncond| SL)))))) + ((QUOTE T) (QUOTE |failed|))))))) + +;mkDomPvar(p, d, subs, y) == +; l := MEMQ(p, $FormalMapVariableList) => +; domArg(d, #$FormalMapVariableList - #l, subs, y) +; d + +(DEFUN |mkDomPvar| (|p| |d| |subs| |y|) + (PROG (|l|) + (RETURN + (COND + ((SPADLET |l| (MEMQ |p| |$FormalMapVariableList|)) + (|domArg| |d| + (SPADDIFFERENCE (|#| |$FormalMapVariableList|) (|#| |l|)) |subs| |y|)) + ((QUOTE T) |d|))))) + +;domArg(type, i, subs, y) == +; p := MEMQ($FormalMapVariableList.i, subs) => +; y.(#subs - #p) +; type + +(DEFUN |domArg| (|type| |i| |subs| |y|) + (PROG (|p|) + (RETURN + (COND + ((SPADLET |p| (MEMQ (ELT |$FormalMapVariableList| |i|) |subs|)) + (ELT |y| (SPADDIFFERENCE (|#| |subs|) (|#| |p|)))) + ((QUOTE T) |type|))))) + +;domArg2(arg, SL1, SL2) == +; isSharpVar arg => subCopy(arg, SL1) +; arg = '_$ and $domPvar => $domPvar +; subCopy(arg, SL2) + +(DEFUN |domArg2| (|arg| SL1 SL2) + (COND + ((|isSharpVar| |arg|) (|subCopy| |arg| SL1)) + ((AND (BOOT-EQUAL |arg| (QUOTE $)) |$domPvar|) |$domPvar|) + ((QUOTE T) (|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"]) + +(DEFUN |hasCaty1| (|cond| SL) + (PROG (|$domPvar| |args| |ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |b| S) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$domPvar| NIL) + (COND + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| |a| |b| SL)) + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |args| (QCDR |cond|)) (QUOTE T))) + (DO ((#0=#:G169191 |args| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |x| (CAR #0#)) NIL) + (NULL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) + NIL) + (SEQ + (EXIT + (SPADLET S + (COND + ((AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| |a| |b| SL)) + ((AND + (PAIRP |x|) + (EQ (QCDR |x|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (|hasCate| |a| |b| SL)) + ((QUOTE T) (|hasCaty1| |x| SL))))))) + S) + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN (SPADLET |args| (QCDR |cond|)) (QUOTE T))) + (DO ((#1=#:G169218 |args| (CDR #1#)) + (|x| NIL) + (#2=#:G169219 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL) #2#) NIL) + (SEQ + (EXIT + (SPADLET S + (COND + ((AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| |a| |b| (COPY SL))) + ((AND + (PAIRP |x|) + (EQ (QCDR |x|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (|hasCate| |a| |b| (COPY SL))) + ((QUOTE T) (|hasCaty1| |x| (COPY SL)))))))) + S) + ((QUOTE T) + (|keyedSystemError| 'S2GE0016 + (CONS "hasCaty1" + (CONS "unexpected condition from category table" NIL)))))))))) + +;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 + +(DEFUN |hasAttSig| (|d| |x| SL) + (PROG (|a| |ISTMP#1| |foo| |ISTMP#2| |s|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G169295 |x| (CDR #0#)) + (|y| NIL) + (#1=#:G169296 NIL (BOOT-EQUAL SL (QUOTE |failed|)))) + ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL) #1#) NIL) + (SEQ + (EXIT + (SPADLET SL + (COND + ((AND + (PAIRP |y|) + (EQ (QCAR |y|) (QUOTE ATTRIBUTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|hasAtt| |d| |a| SL)) + ((AND + (PAIRP |y|) + (EQ (QCAR |y|) (QUOTE SIGNATURE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |foo| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |s| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasSig| |d| |foo| |s| SL)) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "hasAttSig" + (CONS "unexpected form of unnamed category" NIL))))))))) + 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 + +(DEFUN |hasSigAnd| (|andCls| S0 SL) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| SA |dead|) + (RETURN + (SEQ + (PROGN + (SPADLET |dead| NIL) + (SPADLET SA (QUOTE |failed|)) + (DO ((#0=#:G169345 |andCls| (CDR #0#)) (|cls| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |cls| (CAR #0#)) NIL) + (NULL (NULL |dead|))) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET SA + (COND + ((ATOM |cls|) (COPY SL)) + ((AND + (PAIRP |cls|) + (EQ (QCAR |cls|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cls|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| (|subCopy| |a| S0) (|subCopy| |b| S0) (COPY SL))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "hasSigAnd" + (CONS "unexpected condition for signature" NIL)))))) + (COND + ((BOOT-EQUAL SA (QUOTE |failed|)) (SPADLET |dead| (QUOTE T))) + ((QUOTE T) NIL)))))) + 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 + +(DEFUN |hasSigOr| (|orCls| S0 SL) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |andCls| SA |found|) + (RETURN + (SEQ + (PROGN + (SPADLET |found| NIL) + (SPADLET SA (QUOTE |failed|)) + (DO ((#0=#:G169399 |orCls| (CDR #0#)) + (|cls| NIL) + (#1=#:G169400 NIL |found|)) + ((OR (ATOM #0#) (PROGN (SETQ |cls| (CAR #0#)) NIL) #1#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET SA + (COND + ((ATOM |cls|) (COPY SL)) + ((AND + (PAIRP |cls|) + (EQ (QCAR |cls|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cls|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| (|subCopy| |a| S0) (|subCopy| |b| S0) (COPY SL))) + ((OR + (AND + (PAIRP |cls|) + (EQ (QCAR |cls|) (QUOTE AND)) + (PROGN (SPADLET |andCls| (QCDR |cls|)) (QUOTE T))) + (AND + (PAIRP |cls|) + (EQ (QCAR |cls|) (QUOTE |and|)) + (PROGN (SPADLET |andCls| (QCDR |cls|)) (QUOTE T)))) + (|hasSigAnd| |andCls| S0 SL)) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "hasSigOr" + (CONS "unexpected condition for signature" NIL)))))) + (COND + ((NEQUAL SA (QUOTE |failed|)) (SPADLET |found| (QUOTE T))) + ((QUOTE T) NIL)))))) + 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 + +(DEFUN |hasSig| (|dom| |foo| |sig| SL) + (PROG (|$domPvar| |fun| S0 |p| |x| |cond| |ISTMP#1| |a| |ISTMP#2| |b| + |andCls| |orCls| S) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$domPvar| NIL) + (COND + ((SPADLET |fun| (|constructor?| (CAR |dom|))) + (SPADLET S0 (|constructSubst| |dom|)) + (COND + ((SPADLET |p| + (ASSQ |foo| (|getOperationAlistFromLisplib| (CAR |dom|)))) + (DO ((#0=#:G169467 (CDR |p|) (CDR #0#)) + (#1=#:G169438 NIL) + (#2=#:G169468 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR #1#)) + (SPADLET |cond| (CADDR #1#)) + #1#) + NIL) + #2#) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET S + (COND + ((ATOM |cond|) (COPY SL)) + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| (|subCopy| |a| S0) (|subCopy| |b| S0) (COPY SL))) + ((OR + (AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |andCls| (QCDR |cond|)) (QUOTE T))) + (AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |and|)) + (PROGN (SPADLET |andCls| (QCDR |cond|)) (QUOTE T)))) + (|hasSigAnd| |andCls| S0 SL)) + ((OR + (AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN (SPADLET |orCls| (QCDR |cond|)) (QUOTE T))) + (AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |or|)) + (PROGN (SPADLET |orCls| (QCDR |cond|)) (QUOTE T)))) + (|hasSigOr| |orCls| S0 SL)) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "hasSig" + (CONS "unexpected condition for signature" NIL)))))) + (COND + ((NULL (BOOT-EQUAL S (QUOTE |failed|))) + (SPADLET S (|unifyStruct| (|subCopy| |x| S0) |sig| S)))))))) + S) + ((QUOTE T) (QUOTE |failed|)))) + ((QUOTE T) (QUOTE |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 + +(DEFUN |hasAtt| (|dom| |att| SL) + (PROG (|$domPvar| |fun| |atts| |u| |x| |cond| S) + (DECLARE (SPECIAL |$domPvar|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$domPvar| NIL) + (COND + ((SPADLET |fun| (CAR |dom|)) + (COND + ((SPADLET |atts| + (|subCopy| + (GETDATABASE |fun| (QUOTE ATTRIBUTES)) + (|constructSubst| |dom|))) + (COND + ((PAIRP (SPADLET |u| (|getInfovec| (CAR |dom|)))) + (DO ((#0=#:G169518 |atts| (CDR #0#)) + (#1=#:G169498 NIL) + (#2=#:G169519 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR #1#)) + (SPADLET |cond| (CDR #1#)) + #1#) + NIL) + #2#) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET S (|unifyStruct| |x| |att| (COPY SL))) + (COND + ((AND + (NULL (ATOM |cond|)) + (NULL (BOOT-EQUAL S (QUOTE |failed|)))) + (SPADLET S (|hasCatExpression| |cond| S)))))))) + S) + ((QUOTE T) + (DO ((#3=#:G169534 |atts| (CDR #3#)) + (#4=#:G169504 NIL) + (#5=#:G169535 NIL (NULL (BOOT-EQUAL S (QUOTE |failed|))))) + ((OR (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN + (PROGN + (SPADLET |x| (CAR #4#)) + (SPADLET |cond| (CADR #4#)) + #4#) + NIL) + #5#) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET S (|unifyStruct| |x| |att| (COPY SL))) + (COND + ((AND + (NULL (ATOM |cond|)) + (NULL (BOOT-EQUAL S (QUOTE |failed|)))) + (SPADLET S (|hasCatExpression| |cond| S)))))))) + S))) + ((QUOTE T) (QUOTE |failed|)))) + ((QUOTE T) (QUOTE |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"]) + +(DEFUN |hasCatExpression| (|cond| SL) + (PROG (|y| |l| |ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (SEQ + (COND + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN (SPADLET |l| (QCDR |cond|)) (QUOTE T))) + (COND + ((PROG (#0=#:G169577) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G169583 NIL #0#) (#2=#:G169584 |l| (CDR #2#)) (|x| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (OR #0# + (NEQUAL + (SPADLET |y| (|hasCatExpression| |x| SL)) + (QUOTE |failed|))))))))) + (EXIT |y|)))) + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |l| (QCDR |cond|)) (QUOTE T))) + (COND + ((PROG (#3=#:G169591) + (SPADLET #3# (QUOTE T)) + (RETURN + (DO ((#4=#:G169597 NIL (NULL #3#)) + (#5=#:G169598 |l| (CDR #5#)) + (|x| NIL)) + ((OR #4# (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) #3#) + (SEQ + (EXIT + (SETQ #3# + (AND #3# + (NEQUAL + (SPADLET SL (|hasCatExpression| |x| SL)) + (QUOTE |failed|))))))))) + (EXIT SL)))) + ((AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|hasCate| |a| |b| SL)) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "hasSig" (CONS "unexpected condition for attribute" NIL))))))))) + +;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 + +(DEFUN |unifyStruct| (|s1| |s2| SL) + (PROG (|ISTMP#1| |x| |ISTMP#2|) + (RETURN + (SEQ + (COND + ((BOOT-EQUAL |s1| |s2|) SL) + ((QUOTE T) + (COND + ((AND + (PAIRP |s1|) + (EQ (QCAR |s1|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s1|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (SPADLET |s1| |x|))) + (COND + ((AND + (PAIRP |s2|) + (EQ (QCAR |s2|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |s2|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (SPADLET |s2| |x|))) + (COND + ((AND (NULL (ATOM |s1|)) (BOOT-EQUAL (CAR |s1|) (QUOTE |#|))) + (SPADLET |s1| (LENGTH (CADR |s1|))))) + (COND + ((AND (NULL (ATOM |s2|)) (BOOT-EQUAL (CAR |s2|) (QUOTE |#|))) + (SPADLET |s2| (LENGTH (CADR |s2|))))) + (COND + ((BOOT-EQUAL |s1| |s2|) SL) + ((|isPatternVar| |s1|) (|unifyStructVar| |s1| |s2| SL)) + ((|isPatternVar| |s2|) (|unifyStructVar| |s2| |s1| SL)) + ((OR (ATOM |s1|) (ATOM |s2|)) (QUOTE |failed|)) + ((QUOTE T) + (DO ((#0=#:G169646 NIL + (OR (NULL |s1|) (NULL |s2|) (BOOT-EQUAL SL (QUOTE |failed|))))) + (#0# NIL) + (SEQ + (EXIT + (PROGN + (SPADLET SL (|unifyStruct| (CAR |s1|) (CAR |s2|) SL)) + (SPADLET |s1| (CDR |s1|)) + (SPADLET |s2| (CDR |s2|)))))) + (COND ((OR |s1| |s2|) (QUOTE |failed|)) ((QUOTE T) 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) + +(DEFUN |unifyStructVar| (|v| |s| SL) + (PROG (|ps| |s1| |s0| S |ns0| |ns1| |s3|) + (RETURN + (COND + ((CONTAINED |v| |s|) (QUOTE |failed|)) + ((QUOTE T) + (SPADLET |ps| (LASSOC |s| SL)) + (SPADLET |s1| (COND (|ps| |ps|) ((QUOTE T) |s|))) + (COND + ((OR (SPADLET |s0| (LASSOC |v| SL)) (SPADLET |s0| (LASSOC |v| |$Subst|))) + (SPADLET S (|unifyStruct| |s0| |s1| (COPY SL))) + (COND + ((BOOT-EQUAL S (QUOTE |failed|)) + (COND + ((AND |$Coerce| (NULL (ATOM |s0|)) (|constructor?| (CAR |s0|))) + (COND + ((OR (|containsVars| |s0|) (|containsVars| |s1|)) + (SPADLET |ns0| (|subCopy| |s0| SL)) + (SPADLET |ns1| (|subCopy| |s1| SL)) + (COND + ((OR (|containsVars| |ns0|) (|containsVars| |ns1|)) + (SPADLET |$hope| (QUOTE T)) + (QUOTE |failed|)) + ((QUOTE T) + (COND + ((|canCoerce| |ns0| |ns1|) (SPADLET |s3| |s1|)) + ((|canCoerce| |ns1| |ns0|) (SPADLET |s3| |s0|)) + ((QUOTE T) (SPADLET |s3| NIL))) + (COND + (|s3| + (COND + ((NEQUAL |s3| |s0|) + (SPADLET SL (|augmentSub| |v| |s3| SL)))) + (COND + ((AND (NEQUAL |s3| |s1|) (|isPatternVar| |s|)) + (SPADLET SL (|augmentSub| |s| |s3| SL)))) + SL) + ((QUOTE T) (QUOTE |failed|)))))) + (|$domPvar| + (SPADLET |s3| (|resolveTT| |s0| |s1|)) + (COND + (|s3| + (COND + ((NEQUAL |s3| |s0|) (SPADLET SL (|augmentSub| |v| |s3| SL)))) + (COND + ((AND (NEQUAL |s3| |s1|) (|isPatternVar| |s|)) + (SPADLET SL (|augmentSub| |s| |s3| SL)))) + SL) + ((QUOTE T) (QUOTE |failed|)))) + ((QUOTE T) (QUOTE |failed|)))) + ((QUOTE T) (QUOTE |failed|)))) + ((QUOTE T) (|augmentSub| |v| |s| S)))) + ((QUOTE T) (|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) + +(DEFUN |ofCategory| (|dom| |cat|) + (PROG (|$Subst| |$hope| |cats|) + (DECLARE (SPECIAL |$Subst| |$hope|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$Subst| NIL) + (SPADLET |$hope| NIL) + (COND + ((IDENTP |dom|) NIL) + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE |Join|)) + (PROGN (SPADLET |cats| (QCDR |cat|)) (QUOTE T))) + (PROG (#0=#:G169696) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G169702 NIL (NULL #0#)) + (#2=#:G169703 |cats| (CDR #2#)) + (|c| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |c| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|ofCategory| |dom| |c|))))))))) + ((QUOTE T) (NEQUAL (|hasCaty| |dom| |cat| NIL) (QUOTE |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 '" " + +(DEFUN |printMms| (|mmS|) + (PROG (|sig| |imp| |istr|) + (RETURN + (SEQ + (PROGN + (|sayMSG| (MAKESTRING " ")) + (DO ((#0=#:G169736 |mmS| (CDR #0#)) + (#1=#:G169722 NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN (SPADLET |sig| (CAR #1#)) (SPADLET |imp| (CADR #1#)) #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |istr| + (STRCONC (MAKESTRING "[") (STRINGIMAGE |i|) (MAKESTRING "]"))) + (COND + ((EQL (QCSIZE |istr|) 3) + (SPADLET |istr| (STRCONC |istr| (MAKESTRING " "))))) + (|sayMSG| + (APPEND (|bright| |istr|) + (CONS "signature: " (|formatSignature| (CDR |sig|))))) + (COND + ((BOOT-EQUAL (CAR |sig|) (QUOTE |local|)) + (|sayMSG| + (CONS " implemented: local function " (CONS |imp| NIL)))) + ((AND (PAIRP |imp|) (EQ (QCAR |imp|) (QUOTE XLAM))) + (|sayMSG| + (|concat| " implemented: XLAM from " + (|prefix2String| (CAR |sig|))))) + ((QUOTE T) + (|sayMSG| + (|concat| " implemented: slot " |imp| + " from " (|prefix2String| (CAR |sig|)))))))))) + (|sayMSG| (MAKESTRING " "))))))) + +;containsVars(t) == +; -- tests whether term t contains a * variable +; atom t => isPatternVar t +; containsVars1(t) + +(DEFUN |containsVars| (|t|) + (COND + ((ATOM |t|) (|isPatternVar| |t|)) + ((QUOTE 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) + +(DEFUN |containsVars1| (|t|) + (PROG (|t1| |t2|) + (RETURN + (PROGN + (SPADLET |t1| (CAR |t|)) + (SPADLET |t2| (CDR |t|)) + (COND + ((ATOM |t1|) + (OR + (|isPatternVar| |t1|) + (COND + ((ATOM |t2|) (|isPatternVar| |t2|)) + ((QUOTE T) (|containsVars1| |t2|))))) + ((QUOTE T) + (OR + (|containsVars1| |t1|) + (COND + ((ATOM |t2|) (|isPatternVar| |t2|)) + ((QUOTE T) (|containsVars1| |t2|)))))))))) + +;isPartialMode m == +; CONTAINED($EmptyMode,m) + +(DEFUN |isPartialMode| (|m|) (CONTAINED |$EmptyMode| |m|)) + +;getSymbolType var == +;-- var is a pattern variable +; p:= ASSQ(var,$SymbolType) => CDR p +; t:= '(Polynomial (Integer)) +; $SymbolType:= CONS(CONS(var,t),$SymbolType) +; t + +(DEFUN |getSymbolType| (|var|) + (PROG (|p| |t|) + (RETURN + (COND + ((SPADLET |p| (ASSQ |var| |$SymbolType|)) (CDR |p|)) + ((QUOTE T) + (SPADLET |t| (QUOTE (|Polynomial| (|Integer|)))) + (SPADLET |$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]))) + +(DEFUN |isEqualOrSubDomain| (|d1| |d2|) + (PROG (|ISTMP#1|) + (RETURN + (OR + (BOOT-EQUAL |d1| |d2|) + (|isSubDomain| |d1| |d2|) + (AND + (ATOM |d1|) + (OR + (AND (PAIRP |d2|) + (EQ (QCAR |d2|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |d2|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |d1|)))) + (AND (PAIRP |d2|) (EQ (QCDR |d2|) NIL) (EQUAL (QCAR |d2|) |d1|)))) + (AND + (ATOM |d2|) + (OR + (AND (PAIRP |d1|) + (EQ (QCAR |d1|) (QUOTE |Variable|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |d1|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (EQUAL (QCAR |ISTMP#1|) |d2|)))) + (AND + (PAIRP |d1|) + (EQ (QCDR |d1|) NIL) + (EQUAL (QCAR |d1|) |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 + +(DEFUN |defaultTypeForCategory| (|cat| SL) + (PROG (|c| |p1| |p2| |p3| |ISTMP#1| |d| |ISTMP#2| |ISTMP#3| |ISTMP#4| + |ISTMP#5| |ISTMP#6| |ISTMP#7|) + (RETURN + (PROGN + (SPADLET |cat| (|subCopy| |cat| SL)) + (SPADLET |c| (CAR |cat|)) + (SPADLET |d| (GETDATABASE |c| (QUOTE DEFAULTDOMAIN))) + (COND + (|d| (CONS |d| (CDR |cat|))) + ((AND (PAIRP |cat|) + (EQ (QCDR |cat|) NIL) + (PROGN (SPADLET |c| (QCAR |cat|)) (QUOTE T))) + (COND + ((BOOT-EQUAL |c| (QUOTE |Field|)) |$RationalNumber|) + ((|member| |c| + (QUOTE (|Ring| + |IntegralDomain| + |EuclideanDomain| + |GcdDomain| + |OrderedRing| + |DifferentialRing|))) + (QUOTE (|Integer|))) + ((BOOT-EQUAL |c| (QUOTE |OrderedSet|)) |$Symbol|) + ((BOOT-EQUAL |c| (QUOTE |FloatingPointSystem|)) (QUOTE (|Float|))) + ((QUOTE T) NIL))) + ((AND (PAIRP |cat|) + (PROGN + (SPADLET |c| (QCAR |cat|)) + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |p1| (QCAR |ISTMP#1|)) (QUOTE T))))) + (COND + ((BOOT-EQUAL |c| (QUOTE |FiniteLinearAggregate|)) + (CONS (QUOTE |Vector|) (CONS |p1| NIL))) + ((BOOT-EQUAL |c| (QUOTE |VectorCategory|)) + (CONS (QUOTE |Vector|) (CONS |p1| NIL))) + ((BOOT-EQUAL |c| (QUOTE |SetAggregate|)) + (CONS (QUOTE |Set|) (CONS |p1| NIL))) + ((BOOT-EQUAL |c| (QUOTE |SegmentCategory|)) + (CONS (QUOTE |Segment|) (CONS |p1| NIL))) + ((QUOTE T) NIL))) + ((AND (PAIRP |cat|) + (PROGN + (SPADLET |c| (QCAR |cat|)) + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |p2| (QCAR |ISTMP#2|)) (QUOTE T))))))) + NIL) + ((AND (PAIRP |cat|) + (PROGN + (SPADLET |c| (QCAR |cat|)) + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |p2| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |p3| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (COND + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) (QUOTE |MatrixCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cat|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |d| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) (QUOTE |Vector|)) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (EQUAL (QCAR |ISTMP#4|) |d|))))) + (PROGN + (SPADLET |ISTMP#5| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |ISTMP#6| (QCAR |ISTMP#5|)) + (AND + (PAIRP |ISTMP#6|) + (EQ (QCAR |ISTMP#6|) (QUOTE |Vector|)) + (PROGN + (SPADLET |ISTMP#7| (QCDR |ISTMP#6|)) + (AND + (PAIRP |ISTMP#7|) + (EQ (QCDR |ISTMP#7|) NIL) + (EQUAL (QCAR |ISTMP#7|) |d|)))))))))))) + (CONS (QUOTE |Matrix|) (CONS |d| NIL))) + ((QUOTE T) NIL))) + ((QUOTE T) NIL)))))) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}