From 4edaea6cff2d604009b8f2723a9436b0fc97895d Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 7 Nov 2007 20:54:59 +0000 Subject: remove more pamphlets --- src/interp/i-analy.boot | 782 +++++++++ src/interp/i-analy.boot.pamphlet | 804 ---------- src/interp/i-code.boot | 145 ++ src/interp/i-code.boot.pamphlet | 167 -- src/interp/i-coerce.boot | 1377 ++++++++++++++++ src/interp/i-coerce.boot.pamphlet | 1442 ----------------- src/interp/i-coerfn.boot | 2224 +++++++++++++++++++++++++ src/interp/i-coerfn.boot.pamphlet | 2312 -------------------------- src/interp/i-eval.boot | 453 ++++++ src/interp/i-eval.boot.pamphlet | 475 ------ src/interp/i-funsel.boot | 1769 ++++++++++++++++++++ src/interp/i-funsel.boot.pamphlet | 1822 --------------------- src/interp/i-intern.boot | 455 ++++++ src/interp/i-intern.boot.pamphlet | 478 ------ src/interp/i-map.boot | 1162 ++++++++++++++ src/interp/i-map.boot.pamphlet | 1188 -------------- src/interp/i-resolv.boot | 800 +++++++++ src/interp/i-resolv.boot.pamphlet | 863 ---------- src/interp/i-spec1.boot | 1238 ++++++++++++++ src/interp/i-spec1.boot.pamphlet | 1303 --------------- src/interp/i-spec2.boot | 1150 +++++++++++++ src/interp/i-spec2.boot.pamphlet | 1215 -------------- src/interp/i-syscmd.boot | 3131 ++++++++++++++++++++++++++++++++++++ src/interp/i-syscmd.boot.pamphlet | 3203 ------------------------------------- src/interp/i-toplev.boot | 335 ++++ src/interp/i-toplev.boot.pamphlet | 363 ----- src/interp/i-util.boot | 229 +++ src/interp/i-util.boot.pamphlet | 263 --- 28 files changed, 15250 insertions(+), 15898 deletions(-) create mode 100644 src/interp/i-analy.boot delete mode 100644 src/interp/i-analy.boot.pamphlet create mode 100644 src/interp/i-code.boot delete mode 100644 src/interp/i-code.boot.pamphlet create mode 100644 src/interp/i-coerce.boot delete mode 100644 src/interp/i-coerce.boot.pamphlet create mode 100644 src/interp/i-coerfn.boot delete mode 100644 src/interp/i-coerfn.boot.pamphlet create mode 100644 src/interp/i-eval.boot delete mode 100644 src/interp/i-eval.boot.pamphlet create mode 100644 src/interp/i-funsel.boot delete mode 100644 src/interp/i-funsel.boot.pamphlet create mode 100644 src/interp/i-intern.boot delete mode 100644 src/interp/i-intern.boot.pamphlet create mode 100644 src/interp/i-map.boot delete mode 100644 src/interp/i-map.boot.pamphlet create mode 100644 src/interp/i-resolv.boot delete mode 100644 src/interp/i-resolv.boot.pamphlet create mode 100644 src/interp/i-spec1.boot delete mode 100644 src/interp/i-spec1.boot.pamphlet create mode 100644 src/interp/i-spec2.boot delete mode 100644 src/interp/i-spec2.boot.pamphlet create mode 100644 src/interp/i-syscmd.boot delete mode 100644 src/interp/i-syscmd.boot.pamphlet create mode 100644 src/interp/i-toplev.boot delete mode 100644 src/interp/i-toplev.boot.pamphlet create mode 100644 src/interp/i-util.boot delete mode 100644 src/interp/i-util.boot.pamphlet (limited to 'src') diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot new file mode 100644 index 00000000..5b1997b2 --- /dev/null +++ b/src/interp/i-analy.boot @@ -0,0 +1,782 @@ +-- 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. + + +import '"i-object" +)package "BOOT" + +--% Interpreter Analysis Functions + +getMinimalVariableTower(var,t) == + -- gets the minimal polynomial subtower of t that contains the + -- given variable. Returns NIL if none. + STRINGP(t) or IDENTP(t) => NIL + t = $Symbol => t + t is ['Variable,u] => + (u = var) => t + NIL + t is ['Polynomial,.] => t + t is ['RationalFunction,D] => ['Polynomial,D] + t is [up,t',u,.] and MEMQ(up,$univariateDomains) => + -- power series have one more arg and different ordering + u = var => t + getMinimalVariableTower(var,t') + t is [up,u,t'] and MEMQ(up,$univariateDomains) => + u = var => t + getMinimalVariableTower(var,t') + t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) => + var in u => t + getMinimalVariableTower(var,t') + null (t' := underDomainOf t) => NIL + getMinimalVariableTower(var,t') + +getMinimalVarMode(id,m) == + -- This function finds the minimum polynomial subtower type of the + -- polynomial domain tower m which id to which can be coerced + -- It includes all polys above the found level if they are + -- contiguous. + -- E.g.: x and G P[y] P[x] I ---> P[y] P[x] I + -- x and P[y] G P[x] I ---> P[x] I + m is ['Mapping, :.] => m + defaultMode := + $Symbol + null m => defaultMode + (vl := polyVarlist m) and ((id in vl) or 'all in vl) => + SUBSTQ('(Integer),$EmptyMode,m) + (um := underDomainOf m) => getMinimalVarMode(id,um) + defaultMode + +polyVarlist m == + -- If m is a polynomial type this function returns a list of its + -- top level variables, and nil otherwise + -- ignore any QuotientFields that may separate poly types + m is [=$QuotientField,op] => polyVarlist op + m is [op,a,:.] => + op in '(UnivariateTaylorSeries UnivariateLaurentSeries + UnivariatePuiseuxSeries) => + [., ., a, :.] := m + a := removeQuote a + [a] + op in '(Polynomial RationalFunction Expression) => + '(all) + a := removeQuote a + op in '(UnivariatePolynomial) => + [a] + op in $multivariateDomains => + a + nil + +--% Pushing Down Target Information + +pushDownTargetInfo(op,target,arglist) == + -- put target info on args for certain operations + target = $OutputForm => NIL + target = $Any => NIL + n := LENGTH arglist + pushDownOnArithmeticVariables(op,target,arglist) + (pdArgs := pushDownOp?(op,n)) => + for i in pdArgs repeat + x := arglist.i + if not getTarget(x) then putTarget(x,target) + nargs := #arglist + 1 = nargs => + (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + 2 = nargs => + op = "*" => -- only push down on 1st arg if not immed + if not getTarget CADR arglist then putTarget(CADR arglist,target) + getTarget(x := CAR arglist) => NIL + if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target) + op = "**" or op = "^" => -- push down on base + if not getTarget CAR arglist then putTarget(CAR arglist,target) + (op = 'equation) and (target is ['Equation,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + (op = 'gauss) and (target is ['Gaussian,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + (op = '_/) => + targ := + target is ['Fraction,S] => S + target + for x in arglist repeat + if not getTarget(x) then putTarget(x,targ) + (op = 'SEGMENT) and (target is ['Segment,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + NIL + NIL + +pushDownOnArithmeticVariables(op,target,arglist) == + -- tries to push appropriate target information onto variable + -- occurring in arithmetic expressions + PAIRP(target) and CAR(target) = 'Variable => NIL + not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL + not containsPolynomial(target) => NIL + for x in arglist for i in 1.. repeat + VECP(x) => -- leaf + transferPropsToNode(xn := getUnname(x),x) + getValue(x) or (xn = $immediateDataSymbol) => NIL + t := getMinimalVariableTower(xn,target) or target + if not getTarget(x) then putTarget(x,t) + PAIRP(x) => -- node + [op',:arglist'] := x + pushDownOnArithmeticVariables(getUnname op',target,arglist') + arglist + +pushDownOp?(op,n) == + -- determine if for op with n arguments whether for all modemaps + -- the target type is equal to one or more arguments. If so, a list + -- of the appropriate arguments is returned. + ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)] + null ops => NIL + op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)] + -- each signature has form + -- [domain of implementation, target, arg1, arg2, ...] + -- sameAsTarg is a vector that counts the number of modemaps that + -- have the corresponding argument equal to the target type + sameAsTarg := GETZEROVEC n + numMms := LENGTH ops + for [.,targ,:argl] in ops repeat + for arg in argl for i in 0.. repeat + targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i) + -- now see which args have their count = numMms + ok := NIL + for i in 0..(n-1) repeat + if numMms = sameAsTarg.i then ok := cons(i,ok) + reverse ok + +--% Bottom Up Processing + +-- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for +-- user function processing. + +bottomUp t == + -- bottomUp takes an attributed tree, and returns the modeSet for it. + -- As a side-effect it also evaluates the tree. + t is [op,:argl] => + tar := getTarget op + getUnname(op) ^= $immediateDataSymbol and (v := getValue op) => + om := objMode(v) + null tar => [om] + (r := resolveTM(om,tar)) => [r] + [om] + if atom op then + opName:= getUnname op + if opName in $localVars then + putModeSet(op,bottomUpIdentifier(op,opName)) + else + transferPropsToNode(opName,op) + else + opName := NIL + bottomUp op + + opVal := getValue op + + -- call a special handler if we are not being package called + dol := getAtree(op,'dollar) and (opName ^= 'construct) + + (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u + nargs := #argl + if opName then for x in argl for i in 1.. repeat + putAtree(x,'callingFunction,opName) + putAtree(x,'argumentNumber,i) + putAtree(x,'totalArgs,nargs) + + if tar then pushDownTargetInfo(opName,tar,argl) + + -- see if we are calling a declared user map + -- if so, push down the declared types as targets on the args + if opVal and (objVal opVal is ['MAP,:.]) and + (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then + for m in rest ms for x in argl repeat putTarget(x,m) + + argModeSetList:= [bottomUp x for x in argl] + + if ^tar and opName = "*" and nargs = 2 then + [[t1],[t2]] := argModeSetList + tar := computeTypeWithVariablesTarget(t1, t2) + tar => + pushDownTargetInfo(opName,tar,argl) + argModeSetList:= [bottomUp x for x in argl] + + ms := bottomUpForm(t,op,opName,argl,argModeSetList) + + -- given no target or package calling, force integer constants to + -- belong to tightest possible subdomain + + op := CAR t -- may have changed in bottomUpElt + $useIntegerSubdomain and null tar and null dol and + isEqualOrSubDomain(first ms,$Integer) => + val := objVal getValue op + isWrapped val => -- constant if wrapped + val := unwrap val + bm := getBasicMode val + putValue(op,objNewWrap(val,bm)) + putModeSet(op,[bm]) + ms + ms + m := getBasicMode t => [m] + IDENTP (id := getUnname t) => + putModeSet(t,bottomUpIdentifier(t,id)) + keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"]) + +computeTypeWithVariablesTarget(p, q) == + polyVarlist(p) or polyVarlist(q) => + t := resolveTT(p, q) + polyVarlist(t) => t + NIL + NIL + +bottomUpCompile t == + $genValue:local := false + ms := bottomUp t + COMP_-TRAN_-1 objVal getValue t + ms + +bottomUpUseSubdomain t == + $useIntegerSubdomain : local := true + ms := bottomUp t + ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms + null INTEGERP(num := objValUnwrap getValue t) => ms + o := getBasicObject(num) + putValue(t,o) + ms := [objMode o] + putModeSet(t,ms) + ms + +bottomUpPredicate(pred, name) == + putTarget(pred,$Boolean) + ms := bottomUp pred + $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name]) + ms + +bottomUpCompilePredicate(pred, name) == + $genValue:local := false + bottomUpPredicate(pred,name) + +bottomUpIdentifier(t,id) == + m := isType t => bottomUpType(t, m) + EQ(id,'noMapVal) => throwKeyedMsg('"S2IB0002",NIL) + EQ(id,'noBranch) => + keyedSystemError("S2GE0016", + ['"bottomUpIdentifier",'"trying to evaluate noBranch"]) + transferPropsToNode(id,t) + defaultType := ['Variable,id] + -- This was meant to stop building silly symbols but had some unfortunate + -- side effects, like not being able to say e:=foo in the interpreter. MCD +-- defaultType := +-- getModemapsFromDatabase(id,1) => +-- userError ['"Cannot use operation name as a variable: ", id] +-- ['Variable, id] + u := getValue t => --non-cached values MAY be re-evaluated + tar := getTarget t + expr:= objVal u + om := objMode(u) + (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) => + $genValue or GENSYMP(id) => + null tar => [om] + (r := resolveTM(om,tar)) => [r] + [om] + bottomUpDefault(t,id,defaultType,getTarget t) + interpRewriteRule(t,id,expr) or + (isMapExpr expr and [objMode(u)]) or + keyedSystemError("S2GE0016", + ['"bottomUpIdentifier",'"cannot evaluate identifier"]) + bottomUpDefault(t,id,defaultType,getTarget t) + +bottomUpDefault(t,id,defaultMode,target) == + if $genValue + then bottomUpDefaultEval(t,id,defaultMode,target,nil) + else bottomUpDefaultCompile(t,id,defaultMode,target,nil) + +bottomUpDefaultEval(t,id,defaultMode,target,isSub) == + -- try to get value case. + + -- 1. declared mode but no value case + (m := getMode t) => + m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t]) + + -- hmm, try to treat it like target mode or declared mode + if isPartialMode(m) then m := resolveTM(['Variable,id],m) + -- if there is a target, probably want it to be that way and not + -- declared mode. Like "x" in second line: + -- x : P[x] I + -- y : P[x] I + target and not isSub and + (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=> + putValue(t,val) + [target] + -- Ok, see if we can make it into declared mode from symbolic form + -- For example, (x : P[x] I; x + 1) + not target and not isSub and m and + (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) => + putValue(t,val) + [m] + -- give up + throwKeyedMsg('"S2IB0004",[id,m]) + + -- 2. no value and no mode case + val := objNewWrap(id,defaultMode) + (null target) or (defaultMode = target) => + putValue(t,val) + [defaultMode] + if isPartialMode target then + -- this hackery will go away when Symbol is not the default type + if defaultMode = $Symbol and (target is [D,x,.]) then + (D in $univariateDomains and (x = id)) or + (D in $multivariateDomains and (id in x)) => + dmode := [D,x,$Integer] + (val' := coerceInteractive(objNewWrap(id, + ['Variable,id]),dmode)) => + defaultMode := dmode + val := val' + NIL + target := resolveTM(defaultMode,target) + -- The following is experimental. SCM 10/11/90 + if target and (tm := getMinimalVarMode(id, target)) then + target := tm + (null target) or null (val' := coerceInteractive(val,target)) => + putValue(t,val) + [defaultMode] + putValue(t,val') + [target] + +bottomUpDefaultCompile(t,id,defaultMode,target,isSub) == + tmode := getMode t + tval := getValue t + expr:= + id in $localVars => id + tmode or tval => + envMode := tmode or objMode tval + envMode is ['Variable, :.] => objVal tval + id = $immediateDataSymbol => objVal tval + ['getValueFromEnvironment,MKQ id,MKQ envMode] + wrap id + tmode and tval and (mdv := objMode tval) => + if isPartialMode tmode then + null (tmode := resolveTM(mdv,tmode)) => + keyedMsgCompFailure("S2IB0010",NIL) + putValue(t,objNew(expr,tmode)) + [tmode] + tmode or (tval and (tmode := objMode tval)) => + putValue(t,objNew(expr,tmode)) + [tmode] + obj := objNew(expr,defaultMode) + canCoerceFrom(defaultMode, target) and + (obj' := coerceInteractive(obj, target)) => + putValue(t, obj') + [target] + putValue(t,obj) + [defaultMode] + +interpRewriteRule(t,id,expr) == + null get(id,'isInterpreterRule,$e) => NIL + (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) => + ms + nil + +bottomUpForm(t,op,opName,argl,argModeSetList) == + not($inRetract) => + bottomUpForm3(t,op,opName,argl,argModeSetList) + bottomUpForm2(t,op,opName,argl,argModeSetList) + +bottomUpForm3(t,op,opName,argl,argModeSetList) == + $origArgModeSetList:local := COPY argModeSetList + bottomUpForm2(t,op,opName,argl,argModeSetList) + +bottomUpForm2(t,op,opName,argl,argModeSetList) == + not atom t and EQ(opName,"%%") => bottomUpPercent t + opVal := getValue op + + -- for things with objects in operator position, be careful before + -- we enter general modemap selection + + lookForIt := + getAtree(op,'dollar) => true + not opVal => true + opMode := objMode opVal + not (opModeTop := IFCAR opMode) => true + opModeTop in '(Record Union) => false + opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true + false + + -- get rid of Union($, "failed") except when op is "=" and all + -- modesets are the same + + $genValue and + ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and + (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u + + lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u + + -- opName can change in the call to selectMms + + (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and + (mS := evalForm(op,opName := getUnname op,argl,mmS)) => + putModeSet(op,mS) + bottomUpForm0(t,op,opName,argl,argModeSetList) + +bottomUpFormTuple(t, op, opName, args, argModeSetList) == + getAtree(op,'dollar) => NIL + null (singles := getModemapsFromDatabase(opName, 1)) => NIL + + -- see if any of the modemaps have Tuple arguments + haveTuple := false + for mm in singles while not haveTuple repeat + if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true + not haveTuple => nil + nargs := #args + nargs = 1 and getUnname first args = "Tuple" => NIL + nargs = 1 and (ms := bottomUp first args) and + (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL + + -- now make the args into a tuple + + newArg := [mkAtreeNode "Tuple",:args] + bottomUp [op, newArg] + +removeUnionsAtStart(argl,modeSets) == + null $genValue => modeSets + for arg in argl for ms in modeSets repeat + null (v := getValue arg) => nil + m := objMode(v) + m isnt ['Union,:.] => nil + val := objVal(v) + null isWrapped val => nil + val' := retract v + m' := objMode val' + putValue(arg,val') + putModeSet(arg,[m']) + RPLACA(ms,m') + modeSets + +printableArgModeSetList() == + amsl := nil + for a in reverse $origArgModeSetList repeat + b := prefix2String first a + if ATOM b then b := [b] + amsl := ['%l,:b,:amsl] + if amsl then amsl := rest amsl + amsl + +bottomUpForm0(t,op,opName,argl,argModeSetList) == + op0 := op + opName0 := opName + + m := isType t => + bottomUpType(t, m) + + opName = 'copy and argModeSetList is [[['Record,:rargs]]] => + -- this is a hack until Records go through the normal + -- modemap selection process + rtype := ['Record,:rargs] + code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs]) + + if $genValue then code := wrap timedEVALFUN code + val := objNew(code,rtype) + putValue(t,val) + putModeSet(t,[rtype]) + + m := getModeOrFirstModeSetIfThere op + m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and + member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u + m is ['Union,:.] and argModeSetList is [[['Variable,x]]] => + member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u + not $genValue => + amsl := printableArgModeSetList() + throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) + object := retract getValue op + object = 'failed => + throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) + putModeSet(op,[objMode(object)]) + putValue(op,object) + (u := bottomUpElt t) => u + bottomUpForm0(t,op,opName,argl,argModeSetList) + + (opName ^= "elt") and (opName ^= "apply") and + #argl = 1 and first first argModeSetList is ['Variable, var] + and var in '(first last rest) and + isEltable(op, argl, #argl) and (u := bottomUpElt t) => u + + $genValue and + ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u + + (opName ^= "elt") and (opName ^= "apply") and + isEltable(op, argl, #argl) and (u := bottomUpElt t) => u + + if FIXP $HTCompanionWindowID then + mkCompanionPage('operationError, t) + + amsl := printableArgModeSetList() + opName1 := + opName0 = $immediateDataSymbol => + (o := coerceInteractive(getValue op0,$OutputForm)) => + outputTran objValUnwrap o + NIL + opName0 + + if null(opName1) then + opName1 := + (o := getValue op0) => prefix2String objMode o + '"" + msgKey := + null amsl => "S2IB0013" + "S2IB0012" + else + msgKey := + null amsl => "S2IB0011" + (n := isSharpVarWithNum opName1) => + opName1 := n + "S2IB0008g" + "S2IB0008" + + sayIntelligentMessageAboutOpAvailability(opName1, #argl) + + not $genValue => + keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0) + throwKeyedMsgSP(msgKey,[opName1, amsl], op0) + +sayIntelligentMessageAboutOpAvailability(opName, nArgs) == + -- see if we can give some decent messages about the availability if + -- library messages + + NUMBERP opName => NIL + + oo := object2Identifier opOf opName + if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then + opName := "elt" + + nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL) + nAllMmsWithName := #getAllModemapsFromDatabase(opName, NIL) + + -- first see if there are ANY ops with this name + + if nAllMmsWithName = 0 then + sayKeyedMsg("S2IB0008a", [opName]) + else if nAllExposedMmsWithName = 0 then + nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName]) + sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName]) + else + -- now talk about specific arguments + nAllExposedMmsWithNameAndArgs := #getModemapsFromDatabase(opName, nArgs) + nAllMmsWithNameAndArgs := #getAllModemapsFromDatabase(opName, nArgs) + nAllMmsWithNameAndArgs = 0 => + sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName]) + nAllExposedMmsWithNameAndArgs = 0 => + sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) + sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) + nil + +bottomUpType(t, type) == + mode := + if isPartialMode type then '(Mode) + else if categoryForm?(type) then '(SubDomain (Domain)) + else '(Domain) + val:= objNew(type,mode) + putValue(t,val) + -- have to fix the following + putModeSet(t,[mode]) + +bottomUpPercent(tree is [op,:argl]) == + -- handles a call %%(5), which means the output of step 5 + -- %%() is the same as %%(-1) + null argl => + val:= fetchOutput(-1) + putValue(op,val) + putModeSet(op,[objMode(val)]) + argl is [t] => + i:= getArgValue(t,$Integer) => + val:= fetchOutput i + putValue(op,val) + putModeSet(op,[objMode(val)]) + throwKeyedMsgSP('"S2IB0006",NIL,t) + throwKeyedMsgSP('"S2IB0006",NIL,op) + +bottomUpFormRetract(t,op,opName,argl,amsl) == + -- tries to find one argument, which can be pulled back, and calls + -- bottomUpForm again. We do not retract the first argument to a + -- setelt, because this is presumably a destructive operation and + -- the retract can create a new object. + + -- if no such operation exists in the database, don't bother + $inRetract: local := true + null getAllModemapsFromDatabase(getUnname op,#argl) => NIL + + u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u + + a := NIL + b := NIL + ms := NIL + for x in argl for m in amsl for i in 1.. repeat + -- do not retract first arg of a setelt + (i = 1) and (opName = "setelt") => + a := [x,:a] + ms := [m,:ms] + (i = 1) and (opName = "set!") => + a := [x,:a] + ms := [m,:ms] + if PAIRP(m) and CAR(m) = $EmptyMode then return NIL + object:= retract getValue x + a:= [x,:a] + EQ(object,'failed) => + putAtree(x,'retracted,nil) + ms := [m, :ms] + b:= true + RPLACA(m,objMode(object)) + ms := [COPY_-TREE m, :ms] + putAtree(x,'retracted,true) + putValue(x,object) + putModeSet(x,[objMode(object)]) + --insert pulled-back items + a := nreverse a + ms := nreverse ms + + -- check that we haven't seen these types before + typesHad := getAtree(t, 'typesHad) + if member(ms, typesHad) then b := nil + else putAtree(t, 'typesHad, cons(ms, typesHad)) + + b and bottomUpForm(t,op,opName,a,amsl) + +retractAtree atr == + object:= retract getValue atr + EQ(object,'failed) => + putAtree(atr,'retracted,nil) + nil + putAtree(atr,'retracted,true) + putValue(atr,object) + putModeSet(atr,[objMode(object)]) + true + +bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) == + -- see if we have a Union + + ok := NIL + for m in amsl while not ok repeat + if atom first(m) then return NIL + first m = $Any => ok := true + (first first m = 'Union) => ok := true + not ok => NIL + + a:= NIL + b:= NIL + + for x in argl for m in amsl for i in 0.. repeat + m0 := first m + if ( (m0 = $Any) or (first m0 = 'Union) ) and + ('failed^=(object:=retract getValue x)) then + b := true + RPLACA(m,objMode(object)) + putModeSet(x,[objMode(object)]) + putValue(x,object) + a := cons(x,a) + b and bottomUpForm(t,op,opName,nreverse a,amsl) + +bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) == + -- see if we have a Union with no tags, if so retract all such guys + + ok := NIL + for [m] in amsl while not ok repeat + if atom m then return NIL + if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true + not ok => NIL + + a:= NIL + b:= NIL + + for x in argl for m in amsl for i in 0.. repeat + m0 := first m + if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and + ('failed ^= (object:=retract getValue x)) then + b := true + RPLACA(m,objMode(object)) + putModeSet(x,[objMode(object)]) + putValue(x,object) + a := cons(x,a) + b and bottomUpForm(t,op,opName,nreverse a,amsl) + +bottomUpElt (form:=[op,:argl]) == + -- this transfers expressions that look like function calls into + -- forms with elt or apply. + + ms := bottomUp op + ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) => + RPLAC(CDR form, [op,:argl]) + RPLAC(CAR form, mkAtreeNode "elt") + bottomUp form + + target := getTarget form + + newOps := [mkAtreeNode "elt", mkAtreeNode "apply"] + u := nil + + while ^u for newOp in newOps repeat + newArgs := [op,:argl] + if selectMms(newOp, newArgs, target) then + RPLAC(CDR form, newArgs) + RPLAC(CAR form, newOp) + u := bottomUp form + + while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat + while ^u for newOp in newOps repeat + newArgs := [op,:argl] + if selectMms(newOp, newArgs, target) then + RPLAC(CDR form, newArgs) + RPLAC(CAR form, newOp) + u := bottomUp form + u + +isEltable(op,argl,numArgs) == + -- determines if the object might possible have an elt function + -- we exclude Mapping and Variable types explicitly + v := getValue op => + ZEROP numArgs => true + not(m := objMode(v)) => nil + m is ['Mapping, :.] => nil + objVal(v) is ['MAP, :mapDef] and numMapArgs(mapDef) > 0 => nil + true + m := getMode op => + ZEROP numArgs => true + m is ['Mapping, :.] => nil + true + numArgs ^= 1 => nil + name := getUnname op + name = 'SEQ => nil +--not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil + arg := first argl + (getUnname arg) ^= 'construct => nil + true + diff --git a/src/interp/i-analy.boot.pamphlet b/src/interp/i-analy.boot.pamphlet deleted file mode 100644 index b89b1df8..00000000 --- a/src/interp/i-analy.boot.pamphlet +++ /dev/null @@ -1,804 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-analy.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"i-object" -)package "BOOT" - ---% Interpreter Analysis Functions - -getMinimalVariableTower(var,t) == - -- gets the minimal polynomial subtower of t that contains the - -- given variable. Returns NIL if none. - STRINGP(t) or IDENTP(t) => NIL - t = $Symbol => t - t is ['Variable,u] => - (u = var) => t - NIL - t is ['Polynomial,.] => t - t is ['RationalFunction,D] => ['Polynomial,D] - t is [up,t',u,.] and MEMQ(up,$univariateDomains) => - -- power series have one more arg and different ordering - u = var => t - getMinimalVariableTower(var,t') - t is [up,u,t'] and MEMQ(up,$univariateDomains) => - u = var => t - getMinimalVariableTower(var,t') - t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) => - var in u => t - getMinimalVariableTower(var,t') - null (t' := underDomainOf t) => NIL - getMinimalVariableTower(var,t') - -getMinimalVarMode(id,m) == - -- This function finds the minimum polynomial subtower type of the - -- polynomial domain tower m which id to which can be coerced - -- It includes all polys above the found level if they are - -- contiguous. - -- E.g.: x and G P[y] P[x] I ---> P[y] P[x] I - -- x and P[y] G P[x] I ---> P[x] I - m is ['Mapping, :.] => m - defaultMode := - $Symbol - null m => defaultMode - (vl := polyVarlist m) and ((id in vl) or 'all in vl) => - SUBSTQ('(Integer),$EmptyMode,m) - (um := underDomainOf m) => getMinimalVarMode(id,um) - defaultMode - -polyVarlist m == - -- If m is a polynomial type this function returns a list of its - -- top level variables, and nil otherwise - -- ignore any QuotientFields that may separate poly types - m is [=$QuotientField,op] => polyVarlist op - m is [op,a,:.] => - op in '(UnivariateTaylorSeries UnivariateLaurentSeries - UnivariatePuiseuxSeries) => - [., ., a, :.] := m - a := removeQuote a - [a] - op in '(Polynomial RationalFunction Expression) => - '(all) - a := removeQuote a - op in '(UnivariatePolynomial) => - [a] - op in $multivariateDomains => - a - nil - ---% Pushing Down Target Information - -pushDownTargetInfo(op,target,arglist) == - -- put target info on args for certain operations - target = $OutputForm => NIL - target = $Any => NIL - n := LENGTH arglist - pushDownOnArithmeticVariables(op,target,arglist) - (pdArgs := pushDownOp?(op,n)) => - for i in pdArgs repeat - x := arglist.i - if not getTarget(x) then putTarget(x,target) - nargs := #arglist - 1 = nargs => - (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - 2 = nargs => - op = "*" => -- only push down on 1st arg if not immed - if not getTarget CADR arglist then putTarget(CADR arglist,target) - getTarget(x := CAR arglist) => NIL - if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target) - op = "**" or op = "^" => -- push down on base - if not getTarget CAR arglist then putTarget(CAR arglist,target) - (op = 'equation) and (target is ['Equation,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - (op = 'gauss) and (target is ['Gaussian,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - (op = '_/) => - targ := - target is ['Fraction,S] => S - target - for x in arglist repeat - if not getTarget(x) then putTarget(x,targ) - (op = 'SEGMENT) and (target is ['Segment,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - NIL - NIL - -pushDownOnArithmeticVariables(op,target,arglist) == - -- tries to push appropriate target information onto variable - -- occurring in arithmetic expressions - PAIRP(target) and CAR(target) = 'Variable => NIL - not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL - not containsPolynomial(target) => NIL - for x in arglist for i in 1.. repeat - VECP(x) => -- leaf - transferPropsToNode(xn := getUnname(x),x) - getValue(x) or (xn = $immediateDataSymbol) => NIL - t := getMinimalVariableTower(xn,target) or target - if not getTarget(x) then putTarget(x,t) - PAIRP(x) => -- node - [op',:arglist'] := x - pushDownOnArithmeticVariables(getUnname op',target,arglist') - arglist - -pushDownOp?(op,n) == - -- determine if for op with n arguments whether for all modemaps - -- the target type is equal to one or more arguments. If so, a list - -- of the appropriate arguments is returned. - ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)] - null ops => NIL - op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)] - -- each signature has form - -- [domain of implementation, target, arg1, arg2, ...] - -- sameAsTarg is a vector that counts the number of modemaps that - -- have the corresponding argument equal to the target type - sameAsTarg := GETZEROVEC n - numMms := LENGTH ops - for [.,targ,:argl] in ops repeat - for arg in argl for i in 0.. repeat - targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i) - -- now see which args have their count = numMms - ok := NIL - for i in 0..(n-1) repeat - if numMms = sameAsTarg.i then ok := cons(i,ok) - reverse ok - ---% Bottom Up Processing - --- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for --- user function processing. - -bottomUp t == - -- bottomUp takes an attributed tree, and returns the modeSet for it. - -- As a side-effect it also evaluates the tree. - t is [op,:argl] => - tar := getTarget op - getUnname(op) ^= $immediateDataSymbol and (v := getValue op) => - om := objMode(v) - null tar => [om] - (r := resolveTM(om,tar)) => [r] - [om] - if atom op then - opName:= getUnname op - if opName in $localVars then - putModeSet(op,bottomUpIdentifier(op,opName)) - else - transferPropsToNode(opName,op) - else - opName := NIL - bottomUp op - - opVal := getValue op - - -- call a special handler if we are not being package called - dol := getAtree(op,'dollar) and (opName ^= 'construct) - - (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u - nargs := #argl - if opName then for x in argl for i in 1.. repeat - putAtree(x,'callingFunction,opName) - putAtree(x,'argumentNumber,i) - putAtree(x,'totalArgs,nargs) - - if tar then pushDownTargetInfo(opName,tar,argl) - - -- see if we are calling a declared user map - -- if so, push down the declared types as targets on the args - if opVal and (objVal opVal is ['MAP,:.]) and - (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then - for m in rest ms for x in argl repeat putTarget(x,m) - - argModeSetList:= [bottomUp x for x in argl] - - if ^tar and opName = "*" and nargs = 2 then - [[t1],[t2]] := argModeSetList - tar := computeTypeWithVariablesTarget(t1, t2) - tar => - pushDownTargetInfo(opName,tar,argl) - argModeSetList:= [bottomUp x for x in argl] - - ms := bottomUpForm(t,op,opName,argl,argModeSetList) - - -- given no target or package calling, force integer constants to - -- belong to tightest possible subdomain - - op := CAR t -- may have changed in bottomUpElt - $useIntegerSubdomain and null tar and null dol and - isEqualOrSubDomain(first ms,$Integer) => - val := objVal getValue op - isWrapped val => -- constant if wrapped - val := unwrap val - bm := getBasicMode val - putValue(op,objNewWrap(val,bm)) - putModeSet(op,[bm]) - ms - ms - m := getBasicMode t => [m] - IDENTP (id := getUnname t) => - putModeSet(t,bottomUpIdentifier(t,id)) - keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"]) - -computeTypeWithVariablesTarget(p, q) == - polyVarlist(p) or polyVarlist(q) => - t := resolveTT(p, q) - polyVarlist(t) => t - NIL - NIL - -bottomUpCompile t == - $genValue:local := false - ms := bottomUp t - COMP_-TRAN_-1 objVal getValue t - ms - -bottomUpUseSubdomain t == - $useIntegerSubdomain : local := true - ms := bottomUp t - ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms - null INTEGERP(num := objValUnwrap getValue t) => ms - o := getBasicObject(num) - putValue(t,o) - ms := [objMode o] - putModeSet(t,ms) - ms - -bottomUpPredicate(pred, name) == - putTarget(pred,$Boolean) - ms := bottomUp pred - $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name]) - ms - -bottomUpCompilePredicate(pred, name) == - $genValue:local := false - bottomUpPredicate(pred,name) - -bottomUpIdentifier(t,id) == - m := isType t => bottomUpType(t, m) - EQ(id,'noMapVal) => throwKeyedMsg('"S2IB0002",NIL) - EQ(id,'noBranch) => - keyedSystemError("S2GE0016", - ['"bottomUpIdentifier",'"trying to evaluate noBranch"]) - transferPropsToNode(id,t) - defaultType := ['Variable,id] - -- This was meant to stop building silly symbols but had some unfortunate - -- side effects, like not being able to say e:=foo in the interpreter. MCD --- defaultType := --- getModemapsFromDatabase(id,1) => --- userError ['"Cannot use operation name as a variable: ", id] --- ['Variable, id] - u := getValue t => --non-cached values MAY be re-evaluated - tar := getTarget t - expr:= objVal u - om := objMode(u) - (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) => - $genValue or GENSYMP(id) => - null tar => [om] - (r := resolveTM(om,tar)) => [r] - [om] - bottomUpDefault(t,id,defaultType,getTarget t) - interpRewriteRule(t,id,expr) or - (isMapExpr expr and [objMode(u)]) or - keyedSystemError("S2GE0016", - ['"bottomUpIdentifier",'"cannot evaluate identifier"]) - bottomUpDefault(t,id,defaultType,getTarget t) - -bottomUpDefault(t,id,defaultMode,target) == - if $genValue - then bottomUpDefaultEval(t,id,defaultMode,target,nil) - else bottomUpDefaultCompile(t,id,defaultMode,target,nil) - -bottomUpDefaultEval(t,id,defaultMode,target,isSub) == - -- try to get value case. - - -- 1. declared mode but no value case - (m := getMode t) => - m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t]) - - -- hmm, try to treat it like target mode or declared mode - if isPartialMode(m) then m := resolveTM(['Variable,id],m) - -- if there is a target, probably want it to be that way and not - -- declared mode. Like "x" in second line: - -- x : P[x] I - -- y : P[x] I - target and not isSub and - (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=> - putValue(t,val) - [target] - -- Ok, see if we can make it into declared mode from symbolic form - -- For example, (x : P[x] I; x + 1) - not target and not isSub and m and - (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) => - putValue(t,val) - [m] - -- give up - throwKeyedMsg('"S2IB0004",[id,m]) - - -- 2. no value and no mode case - val := objNewWrap(id,defaultMode) - (null target) or (defaultMode = target) => - putValue(t,val) - [defaultMode] - if isPartialMode target then - -- this hackery will go away when Symbol is not the default type - if defaultMode = $Symbol and (target is [D,x,.]) then - (D in $univariateDomains and (x = id)) or - (D in $multivariateDomains and (id in x)) => - dmode := [D,x,$Integer] - (val' := coerceInteractive(objNewWrap(id, - ['Variable,id]),dmode)) => - defaultMode := dmode - val := val' - NIL - target := resolveTM(defaultMode,target) - -- The following is experimental. SCM 10/11/90 - if target and (tm := getMinimalVarMode(id, target)) then - target := tm - (null target) or null (val' := coerceInteractive(val,target)) => - putValue(t,val) - [defaultMode] - putValue(t,val') - [target] - -bottomUpDefaultCompile(t,id,defaultMode,target,isSub) == - tmode := getMode t - tval := getValue t - expr:= - id in $localVars => id - tmode or tval => - envMode := tmode or objMode tval - envMode is ['Variable, :.] => objVal tval - id = $immediateDataSymbol => objVal tval - ['getValueFromEnvironment,MKQ id,MKQ envMode] - wrap id - tmode and tval and (mdv := objMode tval) => - if isPartialMode tmode then - null (tmode := resolveTM(mdv,tmode)) => - keyedMsgCompFailure("S2IB0010",NIL) - putValue(t,objNew(expr,tmode)) - [tmode] - tmode or (tval and (tmode := objMode tval)) => - putValue(t,objNew(expr,tmode)) - [tmode] - obj := objNew(expr,defaultMode) - canCoerceFrom(defaultMode, target) and - (obj' := coerceInteractive(obj, target)) => - putValue(t, obj') - [target] - putValue(t,obj) - [defaultMode] - -interpRewriteRule(t,id,expr) == - null get(id,'isInterpreterRule,$e) => NIL - (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) => - ms - nil - -bottomUpForm(t,op,opName,argl,argModeSetList) == - not($inRetract) => - bottomUpForm3(t,op,opName,argl,argModeSetList) - bottomUpForm2(t,op,opName,argl,argModeSetList) - -bottomUpForm3(t,op,opName,argl,argModeSetList) == - $origArgModeSetList:local := COPY argModeSetList - bottomUpForm2(t,op,opName,argl,argModeSetList) - -bottomUpForm2(t,op,opName,argl,argModeSetList) == - not atom t and EQ(opName,"%%") => bottomUpPercent t - opVal := getValue op - - -- for things with objects in operator position, be careful before - -- we enter general modemap selection - - lookForIt := - getAtree(op,'dollar) => true - not opVal => true - opMode := objMode opVal - not (opModeTop := IFCAR opMode) => true - opModeTop in '(Record Union) => false - opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true - false - - -- get rid of Union($, "failed") except when op is "=" and all - -- modesets are the same - - $genValue and - ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and - (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u - - lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u - - -- opName can change in the call to selectMms - - (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and - (mS := evalForm(op,opName := getUnname op,argl,mmS)) => - putModeSet(op,mS) - bottomUpForm0(t,op,opName,argl,argModeSetList) - -bottomUpFormTuple(t, op, opName, args, argModeSetList) == - getAtree(op,'dollar) => NIL - null (singles := getModemapsFromDatabase(opName, 1)) => NIL - - -- see if any of the modemaps have Tuple arguments - haveTuple := false - for mm in singles while not haveTuple repeat - if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true - not haveTuple => nil - nargs := #args - nargs = 1 and getUnname first args = "Tuple" => NIL - nargs = 1 and (ms := bottomUp first args) and - (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL - - -- now make the args into a tuple - - newArg := [mkAtreeNode "Tuple",:args] - bottomUp [op, newArg] - -removeUnionsAtStart(argl,modeSets) == - null $genValue => modeSets - for arg in argl for ms in modeSets repeat - null (v := getValue arg) => nil - m := objMode(v) - m isnt ['Union,:.] => nil - val := objVal(v) - null isWrapped val => nil - val' := retract v - m' := objMode val' - putValue(arg,val') - putModeSet(arg,[m']) - RPLACA(ms,m') - modeSets - -printableArgModeSetList() == - amsl := nil - for a in reverse $origArgModeSetList repeat - b := prefix2String first a - if ATOM b then b := [b] - amsl := ['%l,:b,:amsl] - if amsl then amsl := rest amsl - amsl - -bottomUpForm0(t,op,opName,argl,argModeSetList) == - op0 := op - opName0 := opName - - m := isType t => - bottomUpType(t, m) - - opName = 'copy and argModeSetList is [[['Record,:rargs]]] => - -- this is a hack until Records go through the normal - -- modemap selection process - rtype := ['Record,:rargs] - code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs]) - - if $genValue then code := wrap timedEVALFUN code - val := objNew(code,rtype) - putValue(t,val) - putModeSet(t,[rtype]) - - m := getModeOrFirstModeSetIfThere op - m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and - member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u - m is ['Union,:.] and argModeSetList is [[['Variable,x]]] => - member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u - not $genValue => - amsl := printableArgModeSetList() - throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) - object := retract getValue op - object = 'failed => - throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) - putModeSet(op,[objMode(object)]) - putValue(op,object) - (u := bottomUpElt t) => u - bottomUpForm0(t,op,opName,argl,argModeSetList) - - (opName ^= "elt") and (opName ^= "apply") and - #argl = 1 and first first argModeSetList is ['Variable, var] - and var in '(first last rest) and - isEltable(op, argl, #argl) and (u := bottomUpElt t) => u - - $genValue and - ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u - - (opName ^= "elt") and (opName ^= "apply") and - isEltable(op, argl, #argl) and (u := bottomUpElt t) => u - - if FIXP $HTCompanionWindowID then - mkCompanionPage('operationError, t) - - amsl := printableArgModeSetList() - opName1 := - opName0 = $immediateDataSymbol => - (o := coerceInteractive(getValue op0,$OutputForm)) => - outputTran objValUnwrap o - NIL - opName0 - - if null(opName1) then - opName1 := - (o := getValue op0) => prefix2String objMode o - '"" - msgKey := - null amsl => "S2IB0013" - "S2IB0012" - else - msgKey := - null amsl => "S2IB0011" - (n := isSharpVarWithNum opName1) => - opName1 := n - "S2IB0008g" - "S2IB0008" - - sayIntelligentMessageAboutOpAvailability(opName1, #argl) - - not $genValue => - keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0) - throwKeyedMsgSP(msgKey,[opName1, amsl], op0) - -sayIntelligentMessageAboutOpAvailability(opName, nArgs) == - -- see if we can give some decent messages about the availability if - -- library messages - - NUMBERP opName => NIL - - oo := object2Identifier opOf opName - if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then - opName := "elt" - - nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL) - nAllMmsWithName := #getAllModemapsFromDatabase(opName, NIL) - - -- first see if there are ANY ops with this name - - if nAllMmsWithName = 0 then - sayKeyedMsg("S2IB0008a", [opName]) - else if nAllExposedMmsWithName = 0 then - nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName]) - sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName]) - else - -- now talk about specific arguments - nAllExposedMmsWithNameAndArgs := #getModemapsFromDatabase(opName, nArgs) - nAllMmsWithNameAndArgs := #getAllModemapsFromDatabase(opName, nArgs) - nAllMmsWithNameAndArgs = 0 => - sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName]) - nAllExposedMmsWithNameAndArgs = 0 => - sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) - sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) - nil - -bottomUpType(t, type) == - mode := - if isPartialMode type then '(Mode) - else if categoryForm?(type) then '(SubDomain (Domain)) - else '(Domain) - val:= objNew(type,mode) - putValue(t,val) - -- have to fix the following - putModeSet(t,[mode]) - -bottomUpPercent(tree is [op,:argl]) == - -- handles a call %%(5), which means the output of step 5 - -- %%() is the same as %%(-1) - null argl => - val:= fetchOutput(-1) - putValue(op,val) - putModeSet(op,[objMode(val)]) - argl is [t] => - i:= getArgValue(t,$Integer) => - val:= fetchOutput i - putValue(op,val) - putModeSet(op,[objMode(val)]) - throwKeyedMsgSP('"S2IB0006",NIL,t) - throwKeyedMsgSP('"S2IB0006",NIL,op) - -bottomUpFormRetract(t,op,opName,argl,amsl) == - -- tries to find one argument, which can be pulled back, and calls - -- bottomUpForm again. We do not retract the first argument to a - -- setelt, because this is presumably a destructive operation and - -- the retract can create a new object. - - -- if no such operation exists in the database, don't bother - $inRetract: local := true - null getAllModemapsFromDatabase(getUnname op,#argl) => NIL - - u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u - - a := NIL - b := NIL - ms := NIL - for x in argl for m in amsl for i in 1.. repeat - -- do not retract first arg of a setelt - (i = 1) and (opName = "setelt") => - a := [x,:a] - ms := [m,:ms] - (i = 1) and (opName = "set!") => - a := [x,:a] - ms := [m,:ms] - if PAIRP(m) and CAR(m) = $EmptyMode then return NIL - object:= retract getValue x - a:= [x,:a] - EQ(object,'failed) => - putAtree(x,'retracted,nil) - ms := [m, :ms] - b:= true - RPLACA(m,objMode(object)) - ms := [COPY_-TREE m, :ms] - putAtree(x,'retracted,true) - putValue(x,object) - putModeSet(x,[objMode(object)]) - --insert pulled-back items - a := nreverse a - ms := nreverse ms - - -- check that we haven't seen these types before - typesHad := getAtree(t, 'typesHad) - if member(ms, typesHad) then b := nil - else putAtree(t, 'typesHad, cons(ms, typesHad)) - - b and bottomUpForm(t,op,opName,a,amsl) - -retractAtree atr == - object:= retract getValue atr - EQ(object,'failed) => - putAtree(atr,'retracted,nil) - nil - putAtree(atr,'retracted,true) - putValue(atr,object) - putModeSet(atr,[objMode(object)]) - true - -bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) == - -- see if we have a Union - - ok := NIL - for m in amsl while not ok repeat - if atom first(m) then return NIL - first m = $Any => ok := true - (first first m = 'Union) => ok := true - not ok => NIL - - a:= NIL - b:= NIL - - for x in argl for m in amsl for i in 0.. repeat - m0 := first m - if ( (m0 = $Any) or (first m0 = 'Union) ) and - ('failed^=(object:=retract getValue x)) then - b := true - RPLACA(m,objMode(object)) - putModeSet(x,[objMode(object)]) - putValue(x,object) - a := cons(x,a) - b and bottomUpForm(t,op,opName,nreverse a,amsl) - -bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) == - -- see if we have a Union with no tags, if so retract all such guys - - ok := NIL - for [m] in amsl while not ok repeat - if atom m then return NIL - if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true - not ok => NIL - - a:= NIL - b:= NIL - - for x in argl for m in amsl for i in 0.. repeat - m0 := first m - if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and - ('failed ^= (object:=retract getValue x)) then - b := true - RPLACA(m,objMode(object)) - putModeSet(x,[objMode(object)]) - putValue(x,object) - a := cons(x,a) - b and bottomUpForm(t,op,opName,nreverse a,amsl) - -bottomUpElt (form:=[op,:argl]) == - -- this transfers expressions that look like function calls into - -- forms with elt or apply. - - ms := bottomUp op - ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) => - RPLAC(CDR form, [op,:argl]) - RPLAC(CAR form, mkAtreeNode "elt") - bottomUp form - - target := getTarget form - - newOps := [mkAtreeNode "elt", mkAtreeNode "apply"] - u := nil - - while ^u for newOp in newOps repeat - newArgs := [op,:argl] - if selectMms(newOp, newArgs, target) then - RPLAC(CDR form, newArgs) - RPLAC(CAR form, newOp) - u := bottomUp form - - while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat - while ^u for newOp in newOps repeat - newArgs := [op,:argl] - if selectMms(newOp, newArgs, target) then - RPLAC(CDR form, newArgs) - RPLAC(CAR form, newOp) - u := bottomUp form - u - -isEltable(op,argl,numArgs) == - -- determines if the object might possible have an elt function - -- we exclude Mapping and Variable types explicitly - v := getValue op => - ZEROP numArgs => true - not(m := objMode(v)) => nil - m is ['Mapping, :.] => nil - objVal(v) is ['MAP, :mapDef] and numMapArgs(mapDef) > 0 => nil - true - m := getMode op => - ZEROP numArgs => true - m is ['Mapping, :.] => nil - true - numArgs ^= 1 => nil - name := getUnname op - name = 'SEQ => nil ---not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil - arg := first argl - (getUnname arg) ^= 'construct => nil - true - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-code.boot b/src/interp/i-code.boot new file mode 100644 index 00000000..080e0dc0 --- /dev/null +++ b/src/interp/i-code.boot @@ -0,0 +1,145 @@ +-- 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. + + +import '"i-object" +)package "BOOT" + +--% Interpreter Code Generation Routines + +--Modified by JHD 9/9/93 to fix a problem with coerces inside +--interpreter functions being used as mappings. They were being +--handled with $useCoerceOrCroak being NIL, and therefore internal +--coercions were not correctly handled. Fix: remove dependence +--on $useCoerceOrCroak, and test explicitly for Mapping types. + +--% COERCE + +intCodeGenCOERCE(triple,t2) == + -- NOTE: returns a triple + t1 := objMode triple + t1 = $EmptyMode => NIL + t1 = t2 => triple + val := objVal triple + + -- if request is for a coerce to t2 from a coerce from + -- to to t1, and t1 = Void or canCoerce(t0,t2), then optimize + + (val is ['coerceOrCroak,trip,t1', .]) and + (t0 := objCodeMode trip) and ([.,val0] := objCodeVal trip) and + ( (t1 = $Void) or canCoerceFrom(removeQuote t0,t2) ) => + -- just generate code for coercion, don't coerce constants + -- might be too big + intCodeGenCOERCE(objNew(val0, removeQuote t0), t2) + + val is ['THROW,label,code] => + if label is ['QUOTE, l] then label := l + null($compilingMap) or (label ^= mapCatchName($mapName)) => + objNew(['THROW,label,wrapped2Quote objVal + intCodeGenCOERCE(objNew(code,t1),t2)],t2) + -- we have a return statement. just send it back as is + objNew(val,t2) + + val is ['PROGN,:code,lastCode] => + objNew(['PROGN,:code,wrapped2Quote objVal + intCodeGenCOERCE(objNew(lastCode,t1),t2)],t2) + + val is ['COND,:conds] => + objNew(['COND, + :[[p,wrapped2Quote objVal intCodeGenCOERCE(objNew(v,t1),t2)] + for [p,v] in conds]],t2) + + -- specially handle subdomain + absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) + + -- specially handle coerce to Any + t2 = '(Any) => objNew(['CONS,MKQ t1,val],t2) + + -- optimize coerces from Any + (t1 = '(Any)) and (val is [ ='CONS,t1',val']) => + intCodeGenCOERCE(objNew(val',removeQuote t1'),t2) + + -- specially handle coerce from Equation to Boolean + (t1 is ['Equation,:.]) and (t2 = $Boolean) => + coerceByFunction(triple,t2) + + -- next is hack for if-then-elses + (t1 = '$NoValueMode) and (val is ['COND,pred]) => + code := + ['COND,pred, + [MKQ true,['throwKeyedMsg,MKQ "S2IM0016",MKQ $mapName]]] + objNew(code,t2) + + -- optimize coerces to Expression + t2 = $OutputForm => + coerceByFunction(triple,t2) + + isSubDomain(t1, $Integer) => + intCodeGenCOERCE(objNew(val, $Integer), t2) + + -- generate code + -- 1. See if the coercion will go through (absolutely) + -- Must be careful about variables or else things like + -- P I --> P[x] P I might not have the x in the original polynomial + -- put in the correct place + + (not containsVariables(t2)) and canCoerceByFunction(t1,t2) => + -- try coerceByFunction + (not canCoerceByMap(t1,t2)) and + (code := coerceByFunction(triple,t2)) => code + intCodeGenCoerce1(val,t1,t2) + + -- 2. Set up a failure point otherwise + + intCodeGenCoerce1(val,t1,t2) + +intCodeGenCoerce1(val,t1,t2) == + -- Internal function to previous one + -- designed to ensure that we don't use coerceOrCroak on mappings +--(t2 is ['Mapping,:.]) => THROW('coerceOrCroaker, 'croaked) + objNew(['coerceOrCroak,objNewCode(['wrap,val],t1), + MKQ t2, MKQ $mapName],t2) + +--% Map components + +wrapMapBodyWithCatch body == + -- places a CATCH around the map body + -- note that we will someday have to fix up the catch identifier + -- to use the generated internal map name + $mapThrowCount = 0 => body + if body is ['failCheck,['coerceOrFail,trip,targ,mapn]] + then + trip is ['LIST,v,m,e] => + ['failCheck,['coerceOrFail, + ['LIST,['CATCH,MKQ mapCatchName $mapName, v],m,e],targ,mapn]] + keyedSystemError("S2GE0016",['"wrapMapBodyWithCatch", + '"bad CATCH for in function form"]) + else ['CATCH,MKQ mapCatchName $mapName,body] diff --git a/src/interp/i-code.boot.pamphlet b/src/interp/i-code.boot.pamphlet deleted file mode 100644 index e014e55b..00000000 --- a/src/interp/i-code.boot.pamphlet +++ /dev/null @@ -1,167 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-code.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"i-object" -)package "BOOT" - ---% Interpreter Code Generation Routines - ---Modified by JHD 9/9/93 to fix a problem with coerces inside ---interpreter functions being used as mappings. They were being ---handled with $useCoerceOrCroak being NIL, and therefore internal ---coercions were not correctly handled. Fix: remove dependence ---on $useCoerceOrCroak, and test explicitly for Mapping types. - ---% COERCE - -intCodeGenCOERCE(triple,t2) == - -- NOTE: returns a triple - t1 := objMode triple - t1 = $EmptyMode => NIL - t1 = t2 => triple - val := objVal triple - - -- if request is for a coerce to t2 from a coerce from - -- to to t1, and t1 = Void or canCoerce(t0,t2), then optimize - - (val is ['coerceOrCroak,trip,t1', .]) and - (t0 := objCodeMode trip) and ([.,val0] := objCodeVal trip) and - ( (t1 = $Void) or canCoerceFrom(removeQuote t0,t2) ) => - -- just generate code for coercion, don't coerce constants - -- might be too big - intCodeGenCOERCE(objNew(val0, removeQuote t0), t2) - - val is ['THROW,label,code] => - if label is ['QUOTE, l] then label := l - null($compilingMap) or (label ^= mapCatchName($mapName)) => - objNew(['THROW,label,wrapped2Quote objVal - intCodeGenCOERCE(objNew(code,t1),t2)],t2) - -- we have a return statement. just send it back as is - objNew(val,t2) - - val is ['PROGN,:code,lastCode] => - objNew(['PROGN,:code,wrapped2Quote objVal - intCodeGenCOERCE(objNew(lastCode,t1),t2)],t2) - - val is ['COND,:conds] => - objNew(['COND, - :[[p,wrapped2Quote objVal intCodeGenCOERCE(objNew(v,t1),t2)] - for [p,v] in conds]],t2) - - -- specially handle subdomain - absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) - - -- specially handle coerce to Any - t2 = '(Any) => objNew(['CONS,MKQ t1,val],t2) - - -- optimize coerces from Any - (t1 = '(Any)) and (val is [ ='CONS,t1',val']) => - intCodeGenCOERCE(objNew(val',removeQuote t1'),t2) - - -- specially handle coerce from Equation to Boolean - (t1 is ['Equation,:.]) and (t2 = $Boolean) => - coerceByFunction(triple,t2) - - -- next is hack for if-then-elses - (t1 = '$NoValueMode) and (val is ['COND,pred]) => - code := - ['COND,pred, - [MKQ true,['throwKeyedMsg,MKQ "S2IM0016",MKQ $mapName]]] - objNew(code,t2) - - -- optimize coerces to Expression - t2 = $OutputForm => - coerceByFunction(triple,t2) - - isSubDomain(t1, $Integer) => - intCodeGenCOERCE(objNew(val, $Integer), t2) - - -- generate code - -- 1. See if the coercion will go through (absolutely) - -- Must be careful about variables or else things like - -- P I --> P[x] P I might not have the x in the original polynomial - -- put in the correct place - - (not containsVariables(t2)) and canCoerceByFunction(t1,t2) => - -- try coerceByFunction - (not canCoerceByMap(t1,t2)) and - (code := coerceByFunction(triple,t2)) => code - intCodeGenCoerce1(val,t1,t2) - - -- 2. Set up a failure point otherwise - - intCodeGenCoerce1(val,t1,t2) - -intCodeGenCoerce1(val,t1,t2) == - -- Internal function to previous one - -- designed to ensure that we don't use coerceOrCroak on mappings ---(t2 is ['Mapping,:.]) => THROW('coerceOrCroaker, 'croaked) - objNew(['coerceOrCroak,objNewCode(['wrap,val],t1), - MKQ t2, MKQ $mapName],t2) - ---% Map components - -wrapMapBodyWithCatch body == - -- places a CATCH around the map body - -- note that we will someday have to fix up the catch identifier - -- to use the generated internal map name - $mapThrowCount = 0 => body - if body is ['failCheck,['coerceOrFail,trip,targ,mapn]] - then - trip is ['LIST,v,m,e] => - ['failCheck,['coerceOrFail, - ['LIST,['CATCH,MKQ mapCatchName $mapName, v],m,e],targ,mapn]] - keyedSystemError("S2GE0016",['"wrapMapBodyWithCatch", - '"bad CATCH for in function form"]) - else ['CATCH,MKQ mapCatchName $mapName,body] -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-coerce.boot b/src/interp/i-coerce.boot new file mode 100644 index 00000000..9a44c578 --- /dev/null +++ b/src/interp/i-coerce.boot @@ -0,0 +1,1377 @@ +-- 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. + + +import '"i-analy" +import '"i-resolv" +)package "BOOT" + +--% Algebraic coercions using interactive code + +algCoerceInteractive(p,source,target) == + -- now called in some groebner code + $useConvertForCoercions : local := true + source := devaluate source + target := devaluate target + u := coerceInteractive(objNewWrap(p,source),target) + u => objValUnwrap(u) + error ['"can't convert",p,'"of mode",source,'"to mode",target] + +spad2BootCoerce(x,source,target) == + -- x : source and we wish to coerce to target + -- used in spad code for Any + null isValidType source => throwKeyedMsg("S2IE0004",[source]) + null isValidType target => throwKeyedMsg("S2IE0004",[target]) + x' := coerceInteractive(objNewWrap(x,source),target) => + objValUnwrap(x') + throwKeyedMsgCannotCoerceWithValue(wrap x,source,target) + +--% Functions for Coercion or Else We'll Get Rough + +coerceOrFail(triple,t,mapName) == + -- some code generated for this is in coerceInt0 + t = $NoValueMode => triple + t' := coerceInteractive(triple,t) + t' => objValUnwrap(t') + sayKeyedMsg("S2IC0004",[mapName,objMode triple,t]) + '"failed" + +coerceOrCroak(triple, t, mapName) == + -- this does the coercion and returns the value or dies + t = $NoValueMode => triple + t' := coerceOrConvertOrRetract(triple,t) + t' => objValUnwrap(t') + mapName = 'noMapName => + throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) + sayKeyedMsg("S2IC0005",[mapName]) + throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) + +coerceOrThrowFailure(value, t1, t2) == + (result := coerceOrRetract(objNewWrap(value, t1), t2)) or + coercionFailure() + objValUnwrap(result) + +--% Retraction functions + +retract object == + type := objMode object + STRINGP type => 'failed + type = $EmptyMode => 'failed + val := objVal object + not isWrapped val and val isnt ['MAP,:.] => 'failed + type' := equiType(type) + (ans := retract1 objNew(val,equiType(type))) = 'failed => ans + objNew(objVal ans,eqType objMode ans) + +retract1 object == + -- this function is the new version of the old "pullback" + -- it first tries to change the datatype of an object to that of + -- largest contained type. Examples: P RN -> RN, RN -> I + -- This is mostly for cases such as constant polynomials or + -- quotients with 1 in the denominator. + type := objMode object + STRINGP type => 'failed + val := objVal object + type = $PositiveInteger => objNew(val,$NonNegativeInteger) + type = $NonNegativeInteger => objNew(val,$Integer) + type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger) + type' := equiType(type) + if not EQ(type,type') then object := objNew(val,type') + (1 = #type') or (type' is ['Union,:.]) or + (type' is ['FunctionCalled,.]) + or (type' is ['OrderedVariableList,.]) or (type is ['Variable,.]) => + (object' := retract2Specialization(object)) => object' + 'failed + null (underDomain := underDomainOf type') => 'failed + -- try to retract the "coefficients" + -- think of P RN -> P I or M RN -> M I + object' := retractUnderDomain(object,type,underDomain) + object' ^= 'failed => object' + -- see if we can use the retract functions + (object' := coerceRetract(object,underDomain)) => object' + -- see if we have a special case here + (object' := retract2Specialization(object)) => object' + 'failed + +retractUnderDomain(object,type,underDomain) == + null (ud := underDomainOf underDomain) => 'failed + [c,:args] := deconstructT type + 1 ^= #args => 'failed + 1 ^= #c => 'failed + type'' := constructT(c,[ud]) + (object' := coerceInt(object,type'')) => object' + 'failed + +retract2Specialization object == + -- handles some specialization retraction cases, like matrices + val := objVal object + val' := unwrap val + type := objMode object + + type = $Any => + [dom,:obj] := val' + objNewWrap(obj,dom) + type is ['Union,:unionDoms] => coerceUnion2Branch object + type = $Symbol => + objNewWrap(1,['OrderedVariableList,[val']]) + type is ['OrderedVariableList,var] => + coerceInt(objNewWrap(var.(val'-1),$Symbol), '(Polynomial (Integer))) +-- !! following retract seems wrong and breaks ug13.input +-- type is ['Variable,var] => +-- coerceInt(object,$Symbol) + type is ['Polynomial,D] => + val' is [ =1,x,:.] => + vl := REMDUP reverse varsInPoly val' + 1 = #vl => coerceInt(object,['UnivariatePolynomial,x,D]) + NIL + val' is [ =0,:.] => coerceInt(object, D) + NIL + type is ['Matrix,D] => + n := # val' + m := # val'.0 + n = m => objNew(val,['SquareMatrix,n,D]) + objNew(val,['RectangularMatrix,n,m,D]) + type is ['RectangularMatrix,n,m,D] => + n = m => objNew(val,['SquareMatrix,n,D]) + NIL + (type is [agg,D]) and (agg in '(Vector Segment UniversalSegment)) => + D = $PositiveInteger => objNew(val,[agg,$NonNegativeInteger]) + D = $NonNegativeInteger => objNew(val,[agg,$Integer]) + NIL + type is ['Array,bds,D] => + D = $PositiveInteger => objNew(val,['Array,bds,$NonNegativeInteger]) + D = $NonNegativeInteger => objNew(val,['Array,bds,$Integer]) + NIL + type is ['List,D] => + D isnt ['List,D'] => + -- try to retract elements + D = $PositiveInteger => objNew(val,['List,$NonNegativeInteger]) + D = $NonNegativeInteger => objNew(val,['List,$Integer]) + null val' => nil +-- null (um := underDomainOf D) => nil +-- objNewWrap(nil,['List,um]) + vl := nil + tl := nil + bad := nil + for e in val' while not bad repeat + (e' := retract objNewWrap(e,D)) = 'failed => bad := true + vl := [objValUnwrap e',:vl] + tl := [objMode e',:tl] + bad => NIL + (m := resolveTypeListAny tl) = D => NIL + D = equiType(m) => NIL + vl' := nil + for e in vl for t in tl repeat + t = m => vl' := [e,:vl'] + e' := coerceInt(objNewWrap(e,t),m) + null e' => return NIL + vl' := [objValUnwrap e',:vl'] + objNewWrap(vl',['List,m]) + D' = $PositiveInteger => + objNew(val,['List,['List,$NonNegativeInteger]]) + D' = $NonNegativeInteger => + objNew(val,['List,['List,$Integer]]) + D' is ['Variable,.] or D' is ['OrderedVariableList,.] => + coerceInt(object,['List,['List,$Symbol]]) + + n := # val' + m := # val'.0 + null isRectangularList(val',n,m) => NIL + coerceInt(object,['Matrix,D']) + type is ['Expression,D] => + [num,:den] := val' + -- coerceRetract already handles case where den = 1 + num isnt [0,:num] => NIL + den isnt [0,:den] => NIL + objNewWrap([num,:den],[$QuotientField, D]) + type is ['SimpleAlgebraicExtension,k,rep,.] => + -- try to retract as an element of rep and see if we can get an + -- element of k + val' := retract objNew(val,rep) + while (val' ^= 'failed) and + (equiType(objMode val') ^= k) repeat + val' := retract val' + val' = 'failed => NIL + val' + + type is ['UnivariatePuiseuxSeries, coef, var, cen] => + coerceInt(object, ['UnivariateLaurentSeries, coef, var, cen]) + type is ['UnivariateLaurentSeries, coef, var, cen] => + coerceInt(object, ['UnivariateTaylorSeries, coef, var, cen]) + + type is ['FunctionCalled,name] => + null (m := get(name,'mode,$e)) => NIL + isPartialMode m => NIL + objNew(val,m) + NIL + +coerceOrConvertOrRetract(T,m) == + $useConvertForCoercions : local := true + coerceOrRetract(T,m) + +coerceOrRetract(T,m) == + (t' := coerceInteractive(T,m)) => t' + t := T + ans := nil + repeat + ans => return ans + t := retract t -- retract is new name for pullback + t = 'failed => return ans + ans := coerceInteractive(t,m) + ans + +coerceRetract(object,t2) == + -- tries to handle cases such as P I -> I + (val := objValUnwrap(object)) = "$fromCoerceable$" => NIL + t1 := objMode object + t2 = $OutputForm => NIL + isEqualOrSubDomain(t1,$Integer) and typeIsASmallInteger(t2) and SMINTP(val) => + objNewWrap(val,t2) + t1 = $Integer => NIL + t1 = $Symbol => NIL + t1 = $OutputForm => NIL + (c := retractByFunction(object, t2)) => c + t1 is [D,:.] => + fun := GETL(D,'retract) or + INTERN STRCONC('"retract",STRINGIMAGE D) + functionp fun => + PUT(D,'retract,fun) + c := CATCH('coerceFailure,FUNCALL(fun,object,t2)) + (c = $coerceFailure) => NIL + c + NIL + NIL + +retractByFunction(object,u) == + -- tries to retract by using function "retractIfCan" + -- if the type belongs to the correct category. + $reportBottomUpFlag: local := NIL + t := objMode object + -- JHD/CRF not ofCategory(t,['RetractableTo,u]) => NIL + val := objValUnwrap object + + -- try to get and apply the function "retractable?" + target := ['Union,u,'"failed"] + funName := 'retractIfCan + if $reportBottomUpFlag then + sayFunctionSelection(funName,[t],target,NIL, + '"coercion facility (retraction)") + -- JHD/CRF if (mms := findFunctionInDomain(funName,t,target,[t],[t],'T,'T)) + -- MCD: changed penultimate variable to NIL. + if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],NIL,'T), + findFunctionInDomain(funName,u,target,[t],[t],NIL,'T))) +-- The above two lines were: (RDJ/BMT 6/95) +-- if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],'T,'T), +-- findFunctionInDomain(funName,u,target,[t],[t],'T,'T))) + then mms := orderMms(funName,mms,[t],[t],target) + if $reportBottomUpFlag then + sayFunctionSelectionResult(funName,[t],mms) + null mms => NIL + + -- [[dc,:.],slot,.]:= CAR mms + dc := CAAAR mms + slot := CADAR mms + dcVector:= evalDomain dc + fun := +--+ + compiledLookup(funName,[target,t],dcVector) + NULL fun => NIL + CAR(fun) = function Undef => NIL +--+ + $: fluid := dcVector + object' := coerceUnion2Branch objNewWrap(SPADCALL(val,fun),target) + u' := objMode object' + u = u' => object' + NIL + +--% Coercion utilities + +-- The next function extracts the structural definition of constants +-- from a given domain. For example, getConstantFromDomain('(One),S) +-- returns the representation of 1 in the domain S. + +constantInDomain?(form,domainForm) == + opAlist := getOperationAlistFromLisplib first domainForm + key := opOf form + entryList := LASSOC(key,opAlist) + entryList is [[., ., ., type]] and type in '(CONST ASCONST) => true + key = "One" => constantInDomain?(["1"], domainForm) + key = "Zero" => constantInDomain?(["0"], domainForm) + false + +getConstantFromDomain(form,domainForm) == + isPartialMode domainForm => NIL + opAlist := getOperationAlistFromLisplib first domainForm + key := opOf form + entryList := LASSOC(key,opAlist) + entryList isnt [[sig, ., ., .]] => + key = "One" => getConstantFromDomain(["1"], domainForm) + key = "Zero" => getConstantFromDomain(["0"], domainForm) + throwKeyedMsg("S2IC0008",[form,domainForm]) + -- i.e., there should be exactly one item under this key of that form + domain := evalDomain domainForm + SPADCALL compiledLookupCheck(key,sig,domain) + + +domainOne(domain) == getConstantFromDomain('(One),domain) + +domainZero(domain) == getConstantFromDomain('(Zero),domain) + +equalOne(object, domain) == + -- tries using constant One and "=" from domain + -- object should not be wrapped + algEqual(object, getConstantFromDomain('(One),domain), domain) + +equalZero(object, domain) == + -- tries using constant Zero and "=" from domain + -- object should not be wrapped + algEqual(object, getConstantFromDomain('(Zero),domain), domain) + +algEqual(object1, object2, domain) == + -- sees if 2 objects of the same domain are equal by using the + -- "=" from the domain + -- objects should not be wrapped +-- eqfunc := getFunctionFromDomain("=",domain,[domain,domain]) + eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain) + SPADCALL(object1,object2, eqfunc) + +--% main algorithms for canCoerceFrom and coerceInteractive + +-- coerceInteractive and canCoerceFrom are the two coercion functions +-- for $InteractiveMode. They translate RN, RF and RR to QF I, QF P +-- and RE RN, respectively, and call coerceInt or canCoerce, which +-- both work in the same way (e.g. coercion from t1 to t2): + +-- 1. they try to coerce t1 to t2 directly (tower coercion), and, if +-- this fails, to coerce t1 to the last argument of t2 and embed +-- this last argument into t2. These embedding functions are now only +-- defined in the algebra code. (RSS 2-27-87) + +-- 2. the tower coercion looks whether there is any applicable local +-- coercion, which means, one defined in boot or in algebra code. +-- If there is an applicable function from a constructor, which is +-- inside the type tower of t1, to the top level constructor of t2, +-- then this constructor is bubbled up inside t1. This means, +-- special coercion functions (defined in boot) are called, which +-- commute two constructors in a tower. Then the local coercion is +-- called on these constructors, which both are on top level now. + +-- example: +-- let t1 = A B C D E (short for (A (B (C (D (E))))), where A ... E are +-- type constructors), and t2 = F D G H I J +-- there is no coercion from t1 to t2 directly, so we try to coerce +-- t1 to s1 = D G H I J, the last argument of t2 +-- we create the type s2 = A D B C E and call a local coercion A2A +-- from t1 to s2, which, by recursively calling coerce, bubbles up +-- the constructor D +-- then we call a commute coerce from s2 to s3 = D A B C E and a local +-- coerce D2D from s3 to s1 +-- finally we embed s1 into t2, which completes the coercion t1 to t2 + +-- the result of canCoerceFrom is TRUE or NIL +-- the result of coerceInteractive is a object or NIL (=failed) +-- all boot coercion functions have the following result: +-- 1. if u=$fromCoerceable$, then TRUE or NIL +-- 2. if the coercion succeeds, the coerced value (this may be NIL) +-- 3. if the coercion fails, they throw to a catch point in +-- coerceByFunction + +--% Interpreter Coercion Query Functions + +canCoerce1(t1,t2) == + -- general test for coercion + -- the result is NIL if it fails + t1 = t2 => true + absolutelyCanCoerceByCheating(t1,t2) or t1 = '(None) or t2 = '(Any) or + t1 in '((Mode) (Domain) (SubDomain (Domain))) => + t2 = $OutputForm => true + NIL + -- next is for tagged union selectors for the time being + t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => true + STRINGP t1 => + t2 = $String => true + t2 = $OutputForm => true + t2 is ['Union,:.] => canCoerceUnion(t1,t2) + t2 is ['Variable,v] and (t1 = PNAME(v)) => true + NIL + STRINGP t2 => + t1 is ['Variable,v] and (t2 = PNAME(v)) => true + NIL + atom t1 or atom t2 => NIL + null isValidType(t2) => NIL + + absolutelyCannotCoerce(t1,t2) => NIL + + nt1 := CAR t1 + nt2 := CAR t2 + + EQ(nt1,'Mapping) => EQ(nt2,'Any) + EQ(nt2,'Mapping) => + EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) => + canCoerceExplicit2Mapping(t1,t2) + NIL + EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2) + + -- efficiency hack + t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and + (isEqualOrSubDomain(s1, s2) or canCoerce(s1, s2)) => true + + t1 is ['Tuple,S] and t2 ^= '(OutputForm) => canCoerce(['List, S], t2) + + isRingT2 := ofCategory(t2,'(Ring)) + isRingT2 and isEqualOrSubDomain(t1,$Integer) => true + (ans := canCoerceTopMatching(t1,t2,nt1,nt2)) ^= 'maybe => ans + t2 = $Integer => canCoerceLocal(t1,t2) -- is true + ans := canCoerceTower(t1,t2) or + [.,:arg]:= deconstructT t2 + arg and + t:= last arg + canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T + ans or (t1 in '((PositiveInteger) (NonNegativeInteger)) + and canCoerce($Integer,t2)) + +canCoerceFrom0(t1,t2) == +-- top level test for coercion, which transfers all RN, RF and RR into +-- equivalent types + startTimingProcess 'querycoerce + q := + isEqualOrSubDomain(t1,t2) or t1 = '(None) or t2 = '(Any) or + if t2 = $OutputForm then (s1 := t1; s2 := t2) + else (s1:= equiType(t1); s2:= equiType(t2)) + + -- make sure we are trying to coerce to a legal type + -- in particular, polynomials are repeated, etc. + null isValidType(t2) => NIL + null isLegitimateMode(t2,nil,nil) => NIL + + t1 = $RationalNumber => + isEqualOrSubDomain(t2,$Integer) => NIL + canCoerce(t1,t2) or canCoerce(s1,s2) + canCoerce(s1,s2) + stopTimingProcess 'querycoerce + q + +isSubTowerOf(t1,t2) == + -- assumes RF and RN stuff has been expanded + -- tests whether t1 is somewhere inside t2 + isEqualOrSubDomain(t1,t2) => true + null (u := underDomainOf t2) => nil + isSubTowerOf(t1,u) + +canCoerceTopMatching(t1,t2,tt1,tt2) == + -- returns true, nil or maybe + -- for example, if t1 = P[x] D1 and t2 = P[y] D2 and x = y then + -- canCoerce will only be true if D1 = D2 + not EQ(tt1,tt2) => 'maybe + doms := '(Polynomial List Matrix FiniteSet Vector Stream Gaussian) + MEMQ(tt1,doms) => canCoerce(CADR t1, CADR t2) + not (MEMQ(tt1,$univariateDomains) or MEMQ(tt2,$multivariateDomains)) => + 'maybe + u2 := deconstructT t2 + 1 = #u2 => NIL + u1 := deconstructT t1 + 1 = #u1 => NIL -- no under domain + first(u1) ^= first(u2) => 'maybe + canCoerce(underDomainOf t1, underDomainOf t2) + +canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) == + -- determines if there a mapping called var with the given args + -- and target + $useCoerceOrCroak: local := nil + t1 is ['Variable,var] => + null (mms :=selectMms1(var,target,argl,[NIL for a in argl],true)) => NIL + mm := CAAR mms + mm is [., targ, :.] => + targ = target => true + false + false + t1 is ['FunctionCalled,fun] => + funNode := mkAtreeNode fun + transferPropsToNode(fun,funNode) + mms := CATCH('coerceOrCroaker, selectLocalMms(funNode,fun,argl,target)) + CONSP mms => + mms is [[['interpOnly,:.],:.]] => nil + mm := CAAR mms + mm is [., targ, :.] => + targ = target => true + false + false + NIL + NIL + +canCoerceUnion(t1,t2) == + -- sees if one can coerce to or from a Union Domain + -- assumes one of t1 and t2 is one + + -- get the domains in the union, checking for tagged unions + if (isUnion1 := t1 is ['Union,:uds1]) then + unionDoms1 := + uds1 and first uds1 is [":",:.] => [t for [.,.,t] in uds1] + uds1 + if (isUnion2 := t2 is ['Union,:uds2]) then + unionDoms2 := + uds2 and first uds2 is [":",:.] => [t for [.,.,t] in uds2] + uds2 + + isUnion2 => + member(t1,unionDoms2) => true + isUnion1 => + and/[or/[canCoerce(ud1,ud2) for ud2 in unionDoms2] + for ud1 in unionDoms1] + or/[canCoerce(t1,ud) for ud in unionDoms2] + -- next, a little lie + t1 is ['Union,d1, ='"failed"] and t2 = d1 => true + isUnion1 => + and/[canCoerce(ud,t2) for ud in unionDoms1] + keyedSystemError("S2GE0016",['"canCoerceUnion", + '"called with 2 non-Unions"]) + +canCoerceByMap(t1,t2) == + -- idea is this: if t1 is D U1 and t2 is D U2, then look for + -- map: (U1 -> U2, D U1) -> D U2. If it exists, then answer true + -- if canCoerceFrom(t1,t2). + u2 := deconstructT t2 + 1 = #u2 => NIL + u1 := deconstructT t1 + 1 = #u1 => NIL -- no under domain + CAR(u1) ^= CAR(u2) => NIL + top := CAAR u1 + u1 := underDomainOf t1 + u2 := underDomainOf t2 + + absolutelyCannotCoerce(u1,u2) => NIL + + -- save some time for those we know about + know := '(List Vector Segment Stream UniversalSegment Array + Polynomial UnivariatePolynomial SquareMatrix Matrix) + top in know => canCoerce(u1,u2) + + null selectMms1('map,t2,[['Mapping,u2,u1],t1], + [['Mapping,u2,u1],u1],NIL) => NIL + -- don't bother checking for Undef, so avoid instantiation + canCoerce(u1,u2) + +canCoerceTower(t1,t2) == +-- tries to find a coercion between top level t2 and somewhere inside t1 +-- builds new bubbled type, for which coercion is called recursively + canCoerceByMap(t1,t2) or newCanCoerceCommute(t1,t2) or + canCoerceLocal(t1,t2) or canCoercePermute(t1,t2) or + [c1,:arg1]:= deconstructT t1 + arg1 and + TL:= NIL + arg:= arg1 + until x or not arg repeat x:= + t:= last arg + [c,:arg]:= deconstructT t + TL:= [c,arg,:TL] + arg and coerceIntTest(t,t2) and + CDDR TL => + s:= constructT(c1,replaceLast(arg1,bubbleConstructor TL)) + canCoerceLocal(t1,s) and + [c2,:arg2]:= deconstructT last s + s1:= bubbleConstructor [c2,arg2,c1,arg1] + canCoerceCommute(s,s1) and canCoerceLocal(s1,t2) + s:= bubbleConstructor [c,arg,c1,arg1] + newCanCoerceCommute(t1,s) and canCoerceLocal(s,t2) + x + +canCoerceLocal(t1,t2) == + -- test for coercion on top level + p:= ASSQ(CAR t1,$CoerceTable) + p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => + tag='partial => NIL + tag='total => true + (functionp(fun) and + (v:=CATCH('coerceFailure,FUNCALL(fun,'_$fromCoerceable_$,t1,t2))) + and v ^= $coerceFailure) or canCoerceByFunction(t1,t2) + canCoerceByFunction(t1,t2) + +canCoerceCommute(t1,t2) == +-- THIS IS OUT-MODED AND WILL GO AWAY SOON RSS 2-87 +-- t1 is t2 with the two top level constructors commuted +-- looks for the existence of a commuting function + CAR(t1) in (l := [$QuotientField, 'Gaussian]) and + CAR(t2) in l => true + p:= ASSQ(CAR t1,$CommuteTable) + p and ASSQ(CAR t2,CDR p) is [.,:['commute,.]] + +newCanCoerceCommute(t1,t2) == + coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2) + +canCoercePermute(t1,t2) == + -- try to generate a sequence of transpositions that will convert + -- t1 into t2 + t2 in '((Integer) (OutputForm)) => NIL + towers := computeTTTranspositions(t1,t2) + -- at this point, CAR towers = t1 and last towers should be similar + -- to t2 in the sense that the components of t1 are in the same order + -- as in t2. If length towers = 2 and t2 = last towers, we quit to + -- avoid an infinte loop. + NULL towers or NULL CDR towers => NIL + NULL CDDR towers and t2 = CADR towers => NIL + -- do the coercions successively, quitting if any fail + ok := true + for t in CDR towers while ok repeat + ok := canCoerce(t1,t) + if ok then t1 := t + ok + +canConvertByFunction(m1,m2) == + null $useConvertForCoercions => NIL + canCoerceByFunction1(m1,m2,'convert) + +canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce) + +canCoerceByFunction1(m1,m2,fun) == + -- calls selectMms with $Coerce=NIL and tests for required target=m2 + $declaredMode:local:= NIL + $reportBottomUpFlag:local:= NIL + -- have to handle cases where we might have changed from RN to QF I + -- make 2 lists of expanded and unexpanded types + l1 := REMDUP [m1,eqType m1] + l2 := REMDUP [m2,eqType m2] + ans := NIL + for t1 in l1 while not ans repeat + for t2 in l2 while not ans repeat + l := selectMms1(fun,t2,[t1],[t1],NIL) + ans := [x for x in l | x is [sig,:.] and CADR sig=t2 and + CADDR sig=t1 and + CAR(sig) isnt ['TypeEquivalence,:.]] and true + ans + +absolutelyCanCoerceByCheating(t1,t2) == + -- this typically involves subdomains and towers where the only + -- difference is a subdomain + isEqualOrSubDomain(t1,t2) => true + typeIsASmallInteger(t1) and t2 = $Integer => true + ATOM(t1) or ATOM(t2) => false + [tl1,:u1] := deconstructT t1 + [tl2,:u2] := deconstructT t2 + tl1 = '(Stream) and tl2 = '(InfiniteTuple) => + #u1 ^= #u2 => false + "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2] + tl1 ^= tl2 => false + #u1 ^= #u2 => false + "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2] + +absolutelyCannotCoerce(t1,t2) == + -- response of true means "definitely cannot coerce" + -- this is largely an efficiency hack + ATOM(t1) or ATOM(t2) => NIL + t2 = '(None) => true + n1 := CAR t1 + n2 := CAR t2 + QFI := [$QuotientField, $Integer] + int2 := isEqualOrSubDomain(t2,$Integer) + scalars := '(BigFloat NewFloat Float DoubleFloat RationalNumber) + + MEMQ(n1,scalars) and int2 => true + (t1 = QFI) and int2 => true + + num2 := int2 or MEMQ(n2,scalars) or (t2 = QFI) + isVar1 := MEMQ(n1,'(Variable Symbol)) + + num2 and isVar1 => true + num2 and MEMQ(n1,$univariateDomains) => true + num2 and MEMQ(n1,$multivariateDomains) => true + miscpols := '(Polynomial ElementaryFunction SimpleAlgebraicExtension) + num2 and MEMQ(n1,miscpols) => true + + aggs := '( + Matrix List Vector Stream Array RectangularMatrix FiniteSet + ) + u1 := underDomainOf t1 + u2 := underDomainOf t2 + MEMQ(n1,aggs) and (u1 = t2) => true + MEMQ(n2,aggs) and (u2 = t1) => true + + algs := '( + SquareMatrix Gaussian RectangularMatrix Quaternion + ) + nonpols := append(aggs,algs) + num2 and MEMQ(n1,nonpols) => true + isVar1 and MEMQ(n2,nonpols) and + absolutelyCannotCoerce(t1,u2) => true + + (MEMQ(n1,scalars) or (t1 = QFI)) and (t2 = '(Polynomial (Integer))) => + true + + v2 := deconstructT t2 + 1 = #v2 => NIL + v1 := deconstructT t1 + 1 = #v1 => NIL + CAR(v1) ^= CAR(v2) => NIL + absolutelyCannotCoerce(u1,u2) + +typeIsASmallInteger x == (x = $SingleInteger) + + +--% Interpreter Coercion Functions + +coerceInteractive(triple,t2) == + -- bind flag for recording/reporting instantiations + -- (see recordInstantiation) + t1 := objMode triple + val := objVal triple + null(t2) or t2 = $EmptyMode => NIL + t2 = t1 => triple + t2 = '$NoValueMode => objNew(val,t2) + if t2 is ['SubDomain,x,.] then t2:= x + -- JHD added category Aug 1996 for BasicMath + t1 in '((Category) (Mode) (Domain) (SubDomain (Domain))) => + t2 = $OutputForm => objNew(val,t2) + NIL + t1 = '$NoValueMode => + if $compilingMap then clearDependentMaps($mapName,nil) + throwKeyedMsg("S2IC0009",[t2,$mapName]) + $insideCoerceInteractive: local := true + expr2 := EQUAL(t2,$OutputForm) + if expr2 then startTimingProcess 'print + else startTimingProcess 'coercion + -- next 2 lines handle cases like '"failed" + result := + expr2 and (t1 = val) => objNew(val,$OutputForm) + expr2 and t1 is ['Variable,var] => objNewWrap(var,$OutputForm) + coerceInt0(triple,t2) + if expr2 then stopTimingProcess 'print + else stopTimingProcess 'coercion + result + +coerceInt0(triple,t2) == + -- top level interactive coercion, which transfers all RN, RF and RR + -- into equivalent types + val := objVal triple + t1 := objMode triple + + val='_$fromCoerceable_$ => canCoerceFrom(t1,t2) + t1 = t2 => triple + if t2 = $OutputForm then + s1 := t1 + s2 := t2 + else + s1 := equiType(t1) + s2 := equiType(t2) + s1 = s2 => return objNew(val,t2) + -- t1 is ['Mapping,:.] and t2 ^= '(Any) => NIL + -- note: may be able to coerce TO mapping + -- treat Exit like Any + -- handle case where we must generate code + null(isWrapped val) and + (t1 isnt ['FunctionCalled,:.] or not $genValue)=> + intCodeGenCOERCE(triple,t2) + t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and + (ans := coerceInt0(objNewWrap(val',t1'),t2)) => ans + if not EQ(s1,t1) then triple := objNew(val,s1) + x := coerceInt(triple,s2) => + EQ(s2,t2) => x + objSetMode(x,t2) + x + NIL + +coerceInt(triple, t2) == + val := coerceInt1(triple, t2) => val + t1 := objMode triple + t1 is ['Variable, :.] => + newMode := getMinimalVarMode(unwrap objVal triple, nil) + newVal := coerceInt(triple, newMode) + coerceInt(newVal, t2) + nil + +coerceInt1(triple,t2) == + -- general interactive coercion + -- the result is a new triple with type m2 or NIL (= failed) + $useCoerceOrCroak: local := true + t2 = $EmptyMode => NIL + t1 := objMode triple + t1=t2 => triple + val := objVal triple + absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) + isSubDomain(t2, t1) => coerceSubDomain(val, t1, t2) + + if typeIsASmallInteger(t1) then + (t2 = $Integer) or typeIsASmallInteger(t2) => return objNew(val,t2) + sintp := SINTP val + sintp and (t2 = $PositiveInteger) and val > 0 => return objNew(val,t2) + sintp and (t2 = $NonNegativeInteger) and val >= 0 => return objNew(val,t2) + + typeIsASmallInteger(t2) and isEqualOrSubDomain(t1, $Integer) and INTP val => + SINTP val => objNew(val,t2) + NIL + + t2 = $Void => objNew(voidValue(),$Void) + t2 = $Any => objNewWrap([t1,:unwrap val],'(Any)) + + t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and + (ans := coerceInt(objNewWrap(val',t1'),t2)) => ans + + -- next is for tagged union selectors for the time being + t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => objNew(val,t2) + + STRINGP t2 => + t1 is ['Variable,v] and (t2 = PNAME(v)) => objNewWrap(t2,t2) + val' := unwrap val + (t2 = val') and ((val' = t1) or (t1 = $String)) => objNew(val,t2) + NIL + -- t1 is ['Tuple,S] and t2 ^= '(OutputForm) => + t1 is ['Tuple,S] => + coerceInt1(objNewWrap(asTupleAsList unwrap val, ['List, S]), t2) + t1 is ['Union,:.] => coerceIntFromUnion(triple,t2) + t2 is ['Union,:.] => coerceInt2Union(triple,t2) + (STRINGP t1) and (t2 = $String) => objNew(val,$String) + (STRINGP t1) and (t2 is ['Variable,v]) => + t1 = PNAME(v) => objNewWrap(v,t2) + NIL + (STRINGP t1) and (t1 = unwrap val) => + t2 = $OutputForm => objNew(t1,$OutputForm) + NIL + atom t1 => NIL + + if t1 = $AnonymousFunction and (t2 is ['Mapping,target,:margl]) then + $useCoerceOrCroak := nil + [.,vars,:body] := unwrap val + vars := + atom vars => [vars] + vars is ['Tuple,:.] => rest vars + vars + #margl ^= #vars => 'continue + tree := mkAtree ['ADEF,vars,[target,:margl],[NIL for x in rest t2],:body] + CATCH('coerceOrCroaker, bottomUp tree) = 'croaked => nil + return getValue tree + + (t1 = $Symbol) and (t2 is ['Mapping,target,:margl]) => + null (mms := selectMms1(unwrap val,nil,margl,margl,target)) => NIL + [dc,targ,:argl] := CAAR mms + targ ^= target => NIL + $genValue => + fun := getFunctionFromDomain(unwrap val,dc,argl) + objNewWrap(fun,t2) + val := NRTcompileEvalForm(unwrap val, CDR CAAR mms, evalDomain dc) + objNew(val, t2) + (t1 is ['Variable,sym]) and (t2 is ['Mapping,target,:margl]) => + null (mms := selectMms1(sym,target,margl,margl,NIL)) => + null (mms := selectMms1(sym,target,margl,margl,true)) => NIL + [dc,targ,:argl] := CAAR mms + targ ^= target => NIL + dc is ["__FreeFunction__",:freeFun] => objNew( freeFun, t2 ) + $genValue => objNewWrap( getFunctionFromDomain(sym,dc,argl), t2 ) + val := NRTcompileEvalForm(sym, CDR CAAR mms, evalDomain dc) + objNew(val, t2) + (t1 is ['FunctionCalled,sym]) and (t2 is ['Mapping,target,:margl]) => + symNode := mkAtreeNode sym + transferPropsToNode(sym,symNode) + null (mms := selectLocalMms(symNode,sym,margl,target)) => NIL + [dc,targ,:argl] := CAAR mms + targ ^= target => NIL + ml := [target,:margl] + intName := + or/[mm for mm in mms | (mm is [[., :ml1],oldName,:.] + and compareTypeLists(ml1,ml))] => [oldName] + NIL + null intName => NIL + objNewWrap(intName,t2) + (t1 is ['FunctionCalled,sym]) => + (t3 := get(sym,'mode,$e)) and t3 is ['Mapping,:.] => + (triple' := coerceInt(triple,t3)) => coerceInt(triple',t2) + NIL + NIL + + EQ(CAR(t1),'Variable) and PAIRP(t2) and + (isEqualOrSubDomain(t2,$Integer) or + (t2 = [$QuotientField, $Integer]) or MEMQ(CAR(t2), + '(RationalNumber BigFloat NewFloat Float DoubleFloat))) => NIL + + ans := coerceRetract(triple,t2) or coerceIntTower(triple,t2) or + [.,:arg]:= deconstructT t2 + arg and + t:= coerceInt(triple,last arg) + t and coerceByFunction(t,t2) + ans or (isSubDomain(t1,$Integer) and + coerceInt(objNew(val,$Integer),t2)) or + coerceIntAlgebraicConstant(triple,t2) or + coerceIntX(val,t1,t2) + +coerceSubDomain(val, tSuper, tSub) == + -- Try to coerce from a sub domain to a super domain + val = '_$fromCoerceable_$ => nil + super := GETDATABASE(first tSub, 'SUPERDOMAIN) + superDomain := first super + superDomain = tSuper => + coerceImmediateSubDomain(val, tSuper, tSub, CADR super) + coerceSubDomain(val, tSuper, superDomain) => + coerceImmediateSubDomain(val, superDomain, tSub, CADR super) + nil + +coerceImmediateSubDomain(val, tSuper, tSub, pred) == + predfn := getSubDomainPredicate(tSuper, tSub, pred) + FUNCALL(predfn, val, nil) => objNew(val, tSub) + nil + +getSubDomainPredicate(tSuper, tSub, pred) == + $env: local := $InteractiveFrame + predfn := HGET($superHash, CONS(tSuper, tSub)) => predfn + name := GENSYM() + decl := ['_:, name, ['Mapping, $Boolean, tSuper]] + interpret(decl, nil) + arg := GENSYM() + pred' := SUBST(arg, "#1", pred) + defn := ['DEF, [name, arg], '(NIL NIL), '(NIL NIL), removeZeroOne pred'] + interpret(defn, nil) + op := mkAtree name + transferPropsToNode(name, op) + predfn := CADAR selectLocalMms(op, name, [tSuper],$Boolean) + HPUT($superHash, CONS(tSuper, tSub), predfn) + predfn + +coerceIntX(val,t1, t2) == + -- some experimental things + t1 = '(List (None)) => + -- this will almost always be an empty list + null unwrap val => + -- try getting a better flavor of List + null (t0 := underDomainOf(t2)) => NIL + coerceInt(objNewWrap(val,['List,t0]),t2) + NIL + NIL + +compareTypeLists(tl1,tl2) == + -- returns true if every type in tl1 is = or is a subdomain of + -- the corresponding type in tl2 + for t1 in tl1 for t2 in tl2 repeat + null isEqualOrSubDomain(t1,t2) => return NIL + true + +coerceIntAlgebraicConstant(object,t2) == + -- should use = from domain, but have to check on defaults code + t1 := objMode object + val := objValUnwrap object + ofCategory(t1,'(Monoid)) and ofCategory(t2,'(Monoid)) and + val = getConstantFromDomain('(One),t1) => + objNewWrap(getConstantFromDomain('(One),t2),t2) + ofCategory(t1,'(AbelianMonoid)) and ofCategory(t2,'(AbelianMonoid)) and + val = getConstantFromDomain('(Zero),t1) => + objNewWrap(getConstantFromDomain('(Zero),t2),t2) + NIL + +coerceUnion2Branch(object) == + [.,:unionDoms] := objMode object + doms := orderUnionEntries unionDoms + predList:= mkPredList doms + doms := stripUnionTags doms + val' := objValUnwrap object + predicate := NIL + targetType:= NIL + for typ in doms for pred in predList while ^targetType repeat + evalSharpOne(pred,val') => + predicate := pred + targetType := typ + null targetType => keyedSystemError("S2IC0013",NIL) + predicate is ['EQCAR,.,p] => objNewWrap(CDR val',targetType) + objNew(objVal object,targetType) + +coerceBranch2Union(object,union) == + -- assumes type is a member of unionDoms + unionDoms := CDR union + doms := orderUnionEntries unionDoms + predList:= mkPredList doms + doms := stripUnionTags doms + p := position(objMode object,doms) + p = -1 => keyedSystemError("S2IC0014",[objMode object,union]) + val := objVal object + predList.p is ['EQCAR,.,tag] => + objNewWrap([removeQuote tag,:unwrap val],union) + objNew(val,union) + +coerceInt2Union(object,union) == + -- coerces to a Union type, adding numeric tags + -- first cut + unionDoms := stripUnionTags CDR union + t1 := objMode object + member(t1,unionDoms) => coerceBranch2Union(object,union) + val := objVal object + val' := unwrap val + (t1 = $String) and member(val',unionDoms) => + coerceBranch2Union(objNew(val,val'),union) + noCoerce := true + val' := nil + for d in unionDoms while noCoerce repeat + (val' := coerceInt(object,d)) => noCoerce := nil + val' => coerceBranch2Union(val',union) + NIL + +coerceIntFromUnion(object,t2) == + -- coerces from a Union type to something else + coerceInt(coerceUnion2Branch object,t2) + +coerceIntByMap(triple,t2) == + -- idea is this: if t1 is D U1 and t2 is D U2, then look for + -- map: (U1 -> U2, D U1) -> D U2. If it exists, then create a + -- function to do the coercion on the element level and call the + -- map function. + t1 := objMode triple + t2 = t1 => triple + u2 := deconstructT t2 -- compute t2 first because of Expression + 1 = #u2 => NIL -- no under domain + u1 := deconstructT t1 + 1 = #u1 => NIL + CAAR u1 ^= CAAR u2 => nil -- constructors not equal + ^valueArgsEqual?(t1, t2) => NIL +-- CAR u1 ^= CAR u2 => NIL + top := CAAR u1 + u1 := underDomainOf t1 + u2 := underDomainOf t2 + + -- handle a couple of special cases for subdomains of Integer + top in '(List Vector Segment Stream UniversalSegment Array) + and isSubDomain(u1,u2) => objNew(objVal triple, t2) + + args := [['Mapping,u2,u1],t1] + if $reportBottomUpFlag then + sayFunctionSelection('map,args,t2,NIL, + '"coercion facility (map)") + mms := selectMms1('map,t2,args,args,NIL) + if $reportBottomUpFlag then + sayFunctionSelectionResult('map,args,mms) + null mms => NIL + + [[dc,:sig],slot,.]:= CAR mms + fun := compiledLookup('map,sig,evalDomain(dc)) + NULL fun => NIL + [fn,:d]:= fun + fn = function Undef => NIL + -- now compile a function to do the coercion + code := ['SPADCALL,['CONS,["function","coerceIntByMapInner"],MKQ [u1,:u2]], + wrapped2Quote objVal triple,MKQ fun] + -- and apply the function + val := CATCH('coerceFailure,timedEvaluate code) + (val = $coerceFailure) => NIL + objNewWrap(val,t2) + +coerceIntByMapInner(arg,[u1,:u2]) == coerceOrThrowFailure(arg,u1,u2) +-- [u1,:u2] gets passed as the "environment", which is why we have this +-- slightly clumsy locution JHD 31.July,1990 + +valueArgsEqual?(t1, t2) == + -- returns true if the object-valued arguments to t1 and t2 are the same + -- under coercion + coSig := CDR GETDATABASE(CAR t1, 'COSIG) + constrSig := CDR getConstructorSignature CAR t1 + tl1 := replaceSharps(constrSig, t1) + tl2 := replaceSharps(constrSig, t2) + not MEMQ(NIL, coSig) => true + done := false + value := true + for a1 in CDR t1 for a2 in CDR t2 for cs in coSig + for m1 in tl1 for m2 in tl2 while not done repeat + ^cs => + trip := objNewWrap(a1, m1) + newVal := coerceInt(trip, m2) + null newVal => (done := true; value := false) + ^algEqual(a2, objValUnwrap newVal, m2) => + (done := true; value := false) + value + +coerceIntTower(triple,t2) == + -- tries to find a coercion from top level t2 to somewhere inside t1 + -- builds new argument type, for which coercion is called recursively + x := coerceIntByMap(triple,t2) => x + x := coerceIntCommute(triple,t2) => x + x := coerceIntPermute(triple,t2) => x + x := coerceIntSpecial(triple,t2) => x + x := coerceIntTableOrFunction(triple,t2) => x + t1 := objMode triple + [c1,:arg1]:= deconstructT t1 + arg1 and + TL:= NIL + arg:= arg1 + until x or not arg repeat + t:= last arg + [c,:arg]:= deconstructT t + TL:= [c,arg,:TL] + x := arg and coerceIntTest(t,t2) => + CDDR TL => + s := constructT(c1,replaceLast(arg1,bubbleConstructor TL)) + (null isValidType(s)) => (x := NIL) + x := (coerceIntByMap(triple,s) or + coerceIntTableOrFunction(triple,s)) => + [c2,:arg2]:= deconstructT last s + s:= bubbleConstructor [c2,arg2,c1,arg1] + (null isValidType(s)) => (x := NIL) + x:= coerceIntCommute(x,s) => + x := (coerceIntByMap(x,t2) or + coerceIntTableOrFunction(x,t2)) + s:= bubbleConstructor [c,arg,c1,arg1] + (null isValidType(s)) => (x := NIL) + x:= coerceIntCommute(triple,s) => + x:= (coerceIntByMap(x,t2) or + coerceIntTableOrFunction(x,t2)) + x + +coerceIntSpecial(triple,t2) == + t1 := objMode triple + t2 is ['SimpleAlgebraicExtension,R,U,.] and t1 = R => + null (x := coerceInt(triple,U)) => NIL + coerceInt(x,t2) + NIL + +coerceIntTableOrFunction(triple,t2) == + -- this function does the actual coercion to t2, but not to an + -- argument type of t2 + null isValidType t2 => NIL -- added 9-18-85 by RSS + null isLegitimateMode(t2,NIL,NIL) => NIL -- added 6-28-87 by RSS + t1 := objMode triple + p:= ASSQ(CAR t1,$CoerceTable) + p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => + val := objVal triple + fun='Identity => objNew(val,t2) + tag='total => + coerceByTable(fun,val,t1,t2,'T) or coerceByFunction(triple,t2) + coerceByTable(fun,val,t1,t2,NIL) or coerceByFunction(triple,t2) + coerceByFunction(triple,t2) + +coerceCommuteTest(t1,t2) == + null isLegitimateMode(t2,NIL,NIL) => NIL + + -- sees whether t1 = D1 D2 R and t2 = D2 D1 S + null (u1 := underDomainOf t1) => NIL + null (u2 := underDomainOf t2) => NIL + + -- must have underdomains (ie, R and S must be there) + + null (v1 := underDomainOf u1) => NIL + null (v2 := underDomainOf u2) => NIL + + -- now check that cross of constructors is correct + (CAR(deconstructT t1) = CAR(deconstructT u2)) and + (CAR(deconstructT t2) = CAR(deconstructT u1)) + +coerceIntCommute(obj,target) == + -- note that the value in obj may be $fromCoerceable$, for canCoerce + source := objMode obj + null coerceCommuteTest(source,target) => NIL + S := underDomainOf source + T := underDomainOf target + source = T => NIL -- handle in other ways + + source is [D,:.] => + fun := GETL(D,'coerceCommute) or + INTERN STRCONC('"commute",STRINGIMAGE D) + functionp fun => + PUT(D,'coerceCommute,fun) + u := objValUnwrap obj + c := CATCH('coerceFailure,FUNCALL(fun,u,source,S,target,T)) + (c = $coerceFailure) => NIL + u = "$fromCoerceable$" => c + objNewWrap(c,target) + NIL + NIL + +coerceIntPermute(object,t2) == + t2 in '((Integer) (OutputForm)) => NIL + t1 := objMode object + towers := computeTTTranspositions(t1,t2) + -- at this point, CAR towers = t1 and last towers should be similar + -- to t2 in the sense that the components of t1 are in the same order + -- as in t2. If length towers = 2 and t2 = last towers, we quit to + -- avoid an infinte loop. + NULL towers or NULL CDR towers => NIL + NULL CDDR towers and t2 = CADR towers => NIL + -- do the coercions successively, quitting if any fail + ok := true + for t in CDR towers while ok repeat + null (object := coerceInt(object,t)) => ok := NIL + ok => object + NIL + +computeTTTranspositions(t1,t2) == + -- decompose t1 into its tower parts + tl1 := decomposeTypeIntoTower t1 + tl2 := decomposeTypeIntoTower t2 + -- if not at least 2 parts, don't bother working here + null (rest tl1 and rest tl2) => NIL + -- determine the relative order of the parts of t1 in t2 + p2 := [position(d1,tl2) for d1 in tl1] + member(-1,p2) => NIL -- something not present + -- if they are all ascending, this function will do nothing + p2' := MSORT p2 + p2 = p2' => NIL + -- if anything is repeated twice, leave + p2' ^= MSORT REMDUP p2' => NIL + -- create a list of permutations that transform the tower parts + -- of t1 into the order they are in in t2 + n1 := #tl1 + p2 := LIST2VEC compress(p2,0,# REMDUP tl1) where + compress(l,start,len) == + start >= len => l + member(start,l) => compress(l,start+1,len) + compress([(i < start => i; i - 1) for i in l],start,len) + -- p2 now has the same position numbers as p1, we need to determine + -- a list of permutations that takes p1 into p2. + -- them + perms := permuteToOrder(p2,n1-1,0) + towers := [tl1] + tower := LIST2VEC tl1 + for perm in perms repeat + t := tower.(CAR perm) + tower.(CAR perm) := tower.(CDR perm) + tower.(CDR perm) := t + towers := CONS(VEC2LIST tower,towers) + towers := [reassembleTowerIntoType tower for tower in towers] + if CAR(towers) ^= t2 then towers := cons(t2,towers) + NREVERSE towers + +decomposeTypeIntoTower t == + ATOM t => [t] + d := deconstructT t + NULL rest d => [t] + rd := REVERSE t + [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd] + +reassembleTowerIntoType tower == + ATOM tower => tower + NULL rest tower => CAR tower + [:top,t,s] := tower + reassembleTowerIntoType [:top,[:t,s]] + +permuteToOrder(p,n,start) == + -- p is a vector of the numbers 0..n. This function returns a list + -- of swaps of adjacent elements so that p will be in order. We only + -- begin looking at index start + r := n - start + r <= 0 => NIL + r = 1 => + p.r < p.(r+1) => NIL + [[r,:(r+1)]] + p.start = start => permuteToOrder(p,n,start+1) + -- bubble up element start to the top. Find out where it is + stpos := NIL + for i in start+1..n while not stpos repeat + if p.i = start then stpos := i + perms := NIL + while stpos ^= start repeat + x := stpos - 1 + perms := [[x,:stpos],:perms] + t := p.stpos + p.stpos := p.x + p.x := t + stpos := x + APPEND(NREVERSE perms,permuteToOrder(p,n,start+1)) + +coerceIntTest(t1,t2) == + -- looks whether there exists a table entry or a coercion function + -- thus the type can be bubbled before coerceIntTableOrFunction is called + t1=t2 or + b:= + p:= ASSQ(CAR t1,$CoerceTable) + p and ASSQ(CAR t2,CDR p) + b or coerceConvertMmSelection('coerce,t1,t2) or + ($useConvertForCoercions and + coerceConvertMmSelection('convert,t1,t2)) + +coerceByTable(fn,x,t1,t2,isTotalCoerce) == + -- catch point for 'failure in boot coercions + t2 = $OutputForm and ^(newType? t1) => NIL + isWrapped x => + x:= unwrap x + c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2)) + c=$coerceFailure => NIL + objNewWrap(c,t2) + isTotalCoerce => objNew([fn,x,MKQ t1,MKQ t2],t2) + objNew(['catchCoerceFailure,MKQ fn,x,MKQ t1,MKQ t2],t2) + +catchCoerceFailure(fn,x,t1,t2) == + -- compiles a catchpoint for compiling boot coercions + c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2)) + c = $coerceFailure => + throwKeyedMsgCannotCoerceWithValue(wrap unwrap x,t1,t2) + c + +coercionFailure() == + -- does the throw on coercion failure + THROW('coerceFailure,$coerceFailure) + +coerceByFunction(T,m2) == + -- using the new modemap selection without coercions + -- should not be called by canCoerceFrom + x := objVal T + x = '_$fromCoerceable_$ => NIL + m2 is ['Union,:.] => NIL + m1 := objMode T + m2 is ['Boolean,:.] and m1 is ['Equation,ud] => + dcVector := evalDomain ud + fun := + isWrapped x => + NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector) + NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector) + [fn,:d]:= fun + isWrapped x => + x:= unwrap x + objNewWrap(SPADCALL(CAR x,CDR x,fun),m2) + x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL) + code := ['SPADCALL, a, b, fun] + objNew(code,$Boolean) + -- If more than one function is found, any should suffice, I think -scm + if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then + mm := coerceConvertMmSelection(funName := 'convert,m1,m2) + mm => + [[dc,tar,:args],slot,.]:= mm + dcVector := evalDomain(dc) + fun:= +--+ + isWrapped x => + NRTcompiledLookup(funName,slot,dcVector) + NRTcompileEvalForm(funName,slot,dcVector) + [fn,:d]:= fun + fn = function Undef => NIL + isWrapped x => +--+ + $: fluid := dcVector + val := CATCH('coerceFailure, SPADCALL(unwrap x,fun)) + (val = $coerceFailure) => NIL + objNewWrap(val,m2) + env := fun + code := ['failCheck, ['SPADCALL, x, env]] +-- tar is ['Union,:.] => objNew(['failCheck,code],m2) + objNew(code,m2) + -- try going back to types like RN instead of QF I + m1' := eqType m1 + m2' := eqType m2 + (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2') + NIL + +hasCorrectTarget(m,sig is [dc,tar,:.]) == + -- tests whether the target of signature sig is either m or a union + -- containing m. It also discards TEQ as it is not meant to be + -- used at top-level + dc is ['TypeEquivalence,:.] => NIL + m=tar => 'T + tar is ['Union,t,'failed] => t=m + tar is ['Union,'failed,t] and t=m + diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet deleted file mode 100644 index b488ce9d..00000000 --- a/src/interp/i-coerce.boot.pamphlet +++ /dev/null @@ -1,1442 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-coerce.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{Coercion conventions} - -\begin{verbatim} -Coercion conventions - -Coercion involves the changing of the datatype of an object. This - can be done for conformality of operations or, for example, to - change the structure of an object into one that is understood by - the printing routines. - -The actual coercion is controlled by the function "coerce" which - takes and delivers wrapped operands. Also see the functions - interpCoerce and coerceInteractive. - -Sometimes one does not want to actually change the datatype but - rather wants to determine whether it is possible to do so. The - controlling function to do this is "canCoerceFrom". The value - passed to specific coercion routines in this case is - "$fromCoerceable$". The value returned is true or false. See - specific examples for more info. - -The special routines that do the coercions typically involve a "2" - in their names. For example, G2E converts type "Gaussian" to - type "Expression". These special routines take and deliver - unwrapped operands. The determination of which special routine - to use is often made by consulting the list $CoerceTable - (currently in COT BOOT) and this is controlled by coerceByTable. - Note that the special routines are in the file COERCEFN BOOT. -\end{verbatim} -\section{Function getConstantFromDomain} -[[getConstantFromDomain]] is used to look up the constants $0$ and $1$ -from the given [[domainForm]]. -\begin{enumerate} -\item if [[isPartialMode]] (see i-funsel.boot) returns true then the -domain modemap contains the constant [[$EmptyMode]] which indicates -that the domain is not fully formed. In this case we return [[NIL]]. -\end{enumerate} -<>= -getConstantFromDomain(form,domainForm) == - isPartialMode domainForm => NIL - opAlist := getOperationAlistFromLisplib first domainForm - key := opOf form - entryList := LASSOC(key,opAlist) - entryList isnt [[sig, ., ., .]] => - key = "One" => getConstantFromDomain(["1"], domainForm) - key = "Zero" => getConstantFromDomain(["0"], domainForm) - throwKeyedMsg("S2IC0008",[form,domainForm]) - -- i.e., there should be exactly one item under this key of that form - domain := evalDomain domainForm - SPADCALL compiledLookupCheck(key,sig,domain) - -@ -\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. - -@ -<<*>>= -<> - -import '"i-analy" -import '"i-resolv" -)package "BOOT" - ---% Algebraic coercions using interactive code - -algCoerceInteractive(p,source,target) == - -- now called in some groebner code - $useConvertForCoercions : local := true - source := devaluate source - target := devaluate target - u := coerceInteractive(objNewWrap(p,source),target) - u => objValUnwrap(u) - error ['"can't convert",p,'"of mode",source,'"to mode",target] - -spad2BootCoerce(x,source,target) == - -- x : source and we wish to coerce to target - -- used in spad code for Any - null isValidType source => throwKeyedMsg("S2IE0004",[source]) - null isValidType target => throwKeyedMsg("S2IE0004",[target]) - x' := coerceInteractive(objNewWrap(x,source),target) => - objValUnwrap(x') - throwKeyedMsgCannotCoerceWithValue(wrap x,source,target) - ---% Functions for Coercion or Else We'll Get Rough - -coerceOrFail(triple,t,mapName) == - -- some code generated for this is in coerceInt0 - t = $NoValueMode => triple - t' := coerceInteractive(triple,t) - t' => objValUnwrap(t') - sayKeyedMsg("S2IC0004",[mapName,objMode triple,t]) - '"failed" - -coerceOrCroak(triple, t, mapName) == - -- this does the coercion and returns the value or dies - t = $NoValueMode => triple - t' := coerceOrConvertOrRetract(triple,t) - t' => objValUnwrap(t') - mapName = 'noMapName => - throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) - sayKeyedMsg("S2IC0005",[mapName]) - throwKeyedMsgCannotCoerceWithValue(objVal triple,objMode triple, t) - -coerceOrThrowFailure(value, t1, t2) == - (result := coerceOrRetract(objNewWrap(value, t1), t2)) or - coercionFailure() - objValUnwrap(result) - ---% Retraction functions - -retract object == - type := objMode object - STRINGP type => 'failed - type = $EmptyMode => 'failed - val := objVal object - not isWrapped val and val isnt ['MAP,:.] => 'failed - type' := equiType(type) - (ans := retract1 objNew(val,equiType(type))) = 'failed => ans - objNew(objVal ans,eqType objMode ans) - -retract1 object == - -- this function is the new version of the old "pullback" - -- it first tries to change the datatype of an object to that of - -- largest contained type. Examples: P RN -> RN, RN -> I - -- This is mostly for cases such as constant polynomials or - -- quotients with 1 in the denominator. - type := objMode object - STRINGP type => 'failed - val := objVal object - type = $PositiveInteger => objNew(val,$NonNegativeInteger) - type = $NonNegativeInteger => objNew(val,$Integer) - type = $Integer and SINTP unwrap val => objNew(val, $SingleInteger) - type' := equiType(type) - if not EQ(type,type') then object := objNew(val,type') - (1 = #type') or (type' is ['Union,:.]) or - (type' is ['FunctionCalled,.]) - or (type' is ['OrderedVariableList,.]) or (type is ['Variable,.]) => - (object' := retract2Specialization(object)) => object' - 'failed - null (underDomain := underDomainOf type') => 'failed - -- try to retract the "coefficients" - -- think of P RN -> P I or M RN -> M I - object' := retractUnderDomain(object,type,underDomain) - object' ^= 'failed => object' - -- see if we can use the retract functions - (object' := coerceRetract(object,underDomain)) => object' - -- see if we have a special case here - (object' := retract2Specialization(object)) => object' - 'failed - -retractUnderDomain(object,type,underDomain) == - null (ud := underDomainOf underDomain) => 'failed - [c,:args] := deconstructT type - 1 ^= #args => 'failed - 1 ^= #c => 'failed - type'' := constructT(c,[ud]) - (object' := coerceInt(object,type'')) => object' - 'failed - -retract2Specialization object == - -- handles some specialization retraction cases, like matrices - val := objVal object - val' := unwrap val - type := objMode object - - type = $Any => - [dom,:obj] := val' - objNewWrap(obj,dom) - type is ['Union,:unionDoms] => coerceUnion2Branch object - type = $Symbol => - objNewWrap(1,['OrderedVariableList,[val']]) - type is ['OrderedVariableList,var] => - coerceInt(objNewWrap(var.(val'-1),$Symbol), '(Polynomial (Integer))) --- !! following retract seems wrong and breaks ug13.input --- type is ['Variable,var] => --- coerceInt(object,$Symbol) - type is ['Polynomial,D] => - val' is [ =1,x,:.] => - vl := REMDUP reverse varsInPoly val' - 1 = #vl => coerceInt(object,['UnivariatePolynomial,x,D]) - NIL - val' is [ =0,:.] => coerceInt(object, D) - NIL - type is ['Matrix,D] => - n := # val' - m := # val'.0 - n = m => objNew(val,['SquareMatrix,n,D]) - objNew(val,['RectangularMatrix,n,m,D]) - type is ['RectangularMatrix,n,m,D] => - n = m => objNew(val,['SquareMatrix,n,D]) - NIL - (type is [agg,D]) and (agg in '(Vector Segment UniversalSegment)) => - D = $PositiveInteger => objNew(val,[agg,$NonNegativeInteger]) - D = $NonNegativeInteger => objNew(val,[agg,$Integer]) - NIL - type is ['Array,bds,D] => - D = $PositiveInteger => objNew(val,['Array,bds,$NonNegativeInteger]) - D = $NonNegativeInteger => objNew(val,['Array,bds,$Integer]) - NIL - type is ['List,D] => - D isnt ['List,D'] => - -- try to retract elements - D = $PositiveInteger => objNew(val,['List,$NonNegativeInteger]) - D = $NonNegativeInteger => objNew(val,['List,$Integer]) - null val' => nil --- null (um := underDomainOf D) => nil --- objNewWrap(nil,['List,um]) - vl := nil - tl := nil - bad := nil - for e in val' while not bad repeat - (e' := retract objNewWrap(e,D)) = 'failed => bad := true - vl := [objValUnwrap e',:vl] - tl := [objMode e',:tl] - bad => NIL - (m := resolveTypeListAny tl) = D => NIL - D = equiType(m) => NIL - vl' := nil - for e in vl for t in tl repeat - t = m => vl' := [e,:vl'] - e' := coerceInt(objNewWrap(e,t),m) - null e' => return NIL - vl' := [objValUnwrap e',:vl'] - objNewWrap(vl',['List,m]) - D' = $PositiveInteger => - objNew(val,['List,['List,$NonNegativeInteger]]) - D' = $NonNegativeInteger => - objNew(val,['List,['List,$Integer]]) - D' is ['Variable,.] or D' is ['OrderedVariableList,.] => - coerceInt(object,['List,['List,$Symbol]]) - - n := # val' - m := # val'.0 - null isRectangularList(val',n,m) => NIL - coerceInt(object,['Matrix,D']) - type is ['Expression,D] => - [num,:den] := val' - -- coerceRetract already handles case where den = 1 - num isnt [0,:num] => NIL - den isnt [0,:den] => NIL - objNewWrap([num,:den],[$QuotientField, D]) - type is ['SimpleAlgebraicExtension,k,rep,.] => - -- try to retract as an element of rep and see if we can get an - -- element of k - val' := retract objNew(val,rep) - while (val' ^= 'failed) and - (equiType(objMode val') ^= k) repeat - val' := retract val' - val' = 'failed => NIL - val' - - type is ['UnivariatePuiseuxSeries, coef, var, cen] => - coerceInt(object, ['UnivariateLaurentSeries, coef, var, cen]) - type is ['UnivariateLaurentSeries, coef, var, cen] => - coerceInt(object, ['UnivariateTaylorSeries, coef, var, cen]) - - type is ['FunctionCalled,name] => - null (m := get(name,'mode,$e)) => NIL - isPartialMode m => NIL - objNew(val,m) - NIL - -coerceOrConvertOrRetract(T,m) == - $useConvertForCoercions : local := true - coerceOrRetract(T,m) - -coerceOrRetract(T,m) == - (t' := coerceInteractive(T,m)) => t' - t := T - ans := nil - repeat - ans => return ans - t := retract t -- retract is new name for pullback - t = 'failed => return ans - ans := coerceInteractive(t,m) - ans - -coerceRetract(object,t2) == - -- tries to handle cases such as P I -> I - (val := objValUnwrap(object)) = "$fromCoerceable$" => NIL - t1 := objMode object - t2 = $OutputForm => NIL - isEqualOrSubDomain(t1,$Integer) and typeIsASmallInteger(t2) and SMINTP(val) => - objNewWrap(val,t2) - t1 = $Integer => NIL - t1 = $Symbol => NIL - t1 = $OutputForm => NIL - (c := retractByFunction(object, t2)) => c - t1 is [D,:.] => - fun := GETL(D,'retract) or - INTERN STRCONC('"retract",STRINGIMAGE D) - functionp fun => - PUT(D,'retract,fun) - c := CATCH('coerceFailure,FUNCALL(fun,object,t2)) - (c = $coerceFailure) => NIL - c - NIL - NIL - -retractByFunction(object,u) == - -- tries to retract by using function "retractIfCan" - -- if the type belongs to the correct category. - $reportBottomUpFlag: local := NIL - t := objMode object - -- JHD/CRF not ofCategory(t,['RetractableTo,u]) => NIL - val := objValUnwrap object - - -- try to get and apply the function "retractable?" - target := ['Union,u,'"failed"] - funName := 'retractIfCan - if $reportBottomUpFlag then - sayFunctionSelection(funName,[t],target,NIL, - '"coercion facility (retraction)") - -- JHD/CRF if (mms := findFunctionInDomain(funName,t,target,[t],[t],'T,'T)) - -- MCD: changed penultimate variable to NIL. - if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],NIL,'T), - findFunctionInDomain(funName,u,target,[t],[t],NIL,'T))) --- The above two lines were: (RDJ/BMT 6/95) --- if (mms := append(findFunctionInDomain(funName,t,target,[t],[t],'T,'T), --- findFunctionInDomain(funName,u,target,[t],[t],'T,'T))) - then mms := orderMms(funName,mms,[t],[t],target) - if $reportBottomUpFlag then - sayFunctionSelectionResult(funName,[t],mms) - null mms => NIL - - -- [[dc,:.],slot,.]:= CAR mms - dc := CAAAR mms - slot := CADAR mms - dcVector:= evalDomain dc - fun := ---+ - compiledLookup(funName,[target,t],dcVector) - NULL fun => NIL - CAR(fun) = function Undef => NIL ---+ - $: fluid := dcVector - object' := coerceUnion2Branch objNewWrap(SPADCALL(val,fun),target) - u' := objMode object' - u = u' => object' - NIL - ---% Coercion utilities - --- The next function extracts the structural definition of constants --- from a given domain. For example, getConstantFromDomain('(One),S) --- returns the representation of 1 in the domain S. - -constantInDomain?(form,domainForm) == - opAlist := getOperationAlistFromLisplib first domainForm - key := opOf form - entryList := LASSOC(key,opAlist) - entryList is [[., ., ., type]] and type in '(CONST ASCONST) => true - key = "One" => constantInDomain?(["1"], domainForm) - key = "Zero" => constantInDomain?(["0"], domainForm) - false - -<> - -domainOne(domain) == getConstantFromDomain('(One),domain) - -domainZero(domain) == getConstantFromDomain('(Zero),domain) - -equalOne(object, domain) == - -- tries using constant One and "=" from domain - -- object should not be wrapped - algEqual(object, getConstantFromDomain('(One),domain), domain) - -equalZero(object, domain) == - -- tries using constant Zero and "=" from domain - -- object should not be wrapped - algEqual(object, getConstantFromDomain('(Zero),domain), domain) - -algEqual(object1, object2, domain) == - -- sees if 2 objects of the same domain are equal by using the - -- "=" from the domain - -- objects should not be wrapped --- eqfunc := getFunctionFromDomain("=",domain,[domain,domain]) - eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain) - SPADCALL(object1,object2, eqfunc) - ---% main algorithms for canCoerceFrom and coerceInteractive - --- coerceInteractive and canCoerceFrom are the two coercion functions --- for $InteractiveMode. They translate RN, RF and RR to QF I, QF P --- and RE RN, respectively, and call coerceInt or canCoerce, which --- both work in the same way (e.g. coercion from t1 to t2): - --- 1. they try to coerce t1 to t2 directly (tower coercion), and, if --- this fails, to coerce t1 to the last argument of t2 and embed --- this last argument into t2. These embedding functions are now only --- defined in the algebra code. (RSS 2-27-87) - --- 2. the tower coercion looks whether there is any applicable local --- coercion, which means, one defined in boot or in algebra code. --- If there is an applicable function from a constructor, which is --- inside the type tower of t1, to the top level constructor of t2, --- then this constructor is bubbled up inside t1. This means, --- special coercion functions (defined in boot) are called, which --- commute two constructors in a tower. Then the local coercion is --- called on these constructors, which both are on top level now. - --- example: --- let t1 = A B C D E (short for (A (B (C (D (E))))), where A ... E are --- type constructors), and t2 = F D G H I J --- there is no coercion from t1 to t2 directly, so we try to coerce --- t1 to s1 = D G H I J, the last argument of t2 --- we create the type s2 = A D B C E and call a local coercion A2A --- from t1 to s2, which, by recursively calling coerce, bubbles up --- the constructor D --- then we call a commute coerce from s2 to s3 = D A B C E and a local --- coerce D2D from s3 to s1 --- finally we embed s1 into t2, which completes the coercion t1 to t2 - --- the result of canCoerceFrom is TRUE or NIL --- the result of coerceInteractive is a object or NIL (=failed) --- all boot coercion functions have the following result: --- 1. if u=$fromCoerceable$, then TRUE or NIL --- 2. if the coercion succeeds, the coerced value (this may be NIL) --- 3. if the coercion fails, they throw to a catch point in --- coerceByFunction - ---% Interpreter Coercion Query Functions - -canCoerce1(t1,t2) == - -- general test for coercion - -- the result is NIL if it fails - t1 = t2 => true - absolutelyCanCoerceByCheating(t1,t2) or t1 = '(None) or t2 = '(Any) or - t1 in '((Mode) (Domain) (SubDomain (Domain))) => - t2 = $OutputForm => true - NIL - -- next is for tagged union selectors for the time being - t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => true - STRINGP t1 => - t2 = $String => true - t2 = $OutputForm => true - t2 is ['Union,:.] => canCoerceUnion(t1,t2) - t2 is ['Variable,v] and (t1 = PNAME(v)) => true - NIL - STRINGP t2 => - t1 is ['Variable,v] and (t2 = PNAME(v)) => true - NIL - atom t1 or atom t2 => NIL - null isValidType(t2) => NIL - - absolutelyCannotCoerce(t1,t2) => NIL - - nt1 := CAR t1 - nt2 := CAR t2 - - EQ(nt1,'Mapping) => EQ(nt2,'Any) - EQ(nt2,'Mapping) => - EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) => - canCoerceExplicit2Mapping(t1,t2) - NIL - EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2) - - -- efficiency hack - t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and - (isEqualOrSubDomain(s1, s2) or canCoerce(s1, s2)) => true - - t1 is ['Tuple,S] and t2 ^= '(OutputForm) => canCoerce(['List, S], t2) - - isRingT2 := ofCategory(t2,'(Ring)) - isRingT2 and isEqualOrSubDomain(t1,$Integer) => true - (ans := canCoerceTopMatching(t1,t2,nt1,nt2)) ^= 'maybe => ans - t2 = $Integer => canCoerceLocal(t1,t2) -- is true - ans := canCoerceTower(t1,t2) or - [.,:arg]:= deconstructT t2 - arg and - t:= last arg - canCoerce(t1,t) and canCoerceByFunction(t,t2) and 'T - ans or (t1 in '((PositiveInteger) (NonNegativeInteger)) - and canCoerce($Integer,t2)) - -canCoerceFrom0(t1,t2) == --- top level test for coercion, which transfers all RN, RF and RR into --- equivalent types - startTimingProcess 'querycoerce - q := - isEqualOrSubDomain(t1,t2) or t1 = '(None) or t2 = '(Any) or - if t2 = $OutputForm then (s1 := t1; s2 := t2) - else (s1:= equiType(t1); s2:= equiType(t2)) - - -- make sure we are trying to coerce to a legal type - -- in particular, polynomials are repeated, etc. - null isValidType(t2) => NIL - null isLegitimateMode(t2,nil,nil) => NIL - - t1 = $RationalNumber => - isEqualOrSubDomain(t2,$Integer) => NIL - canCoerce(t1,t2) or canCoerce(s1,s2) - canCoerce(s1,s2) - stopTimingProcess 'querycoerce - q - -isSubTowerOf(t1,t2) == - -- assumes RF and RN stuff has been expanded - -- tests whether t1 is somewhere inside t2 - isEqualOrSubDomain(t1,t2) => true - null (u := underDomainOf t2) => nil - isSubTowerOf(t1,u) - -canCoerceTopMatching(t1,t2,tt1,tt2) == - -- returns true, nil or maybe - -- for example, if t1 = P[x] D1 and t2 = P[y] D2 and x = y then - -- canCoerce will only be true if D1 = D2 - not EQ(tt1,tt2) => 'maybe - doms := '(Polynomial List Matrix FiniteSet Vector Stream Gaussian) - MEMQ(tt1,doms) => canCoerce(CADR t1, CADR t2) - not (MEMQ(tt1,$univariateDomains) or MEMQ(tt2,$multivariateDomains)) => - 'maybe - u2 := deconstructT t2 - 1 = #u2 => NIL - u1 := deconstructT t1 - 1 = #u1 => NIL -- no under domain - first(u1) ^= first(u2) => 'maybe - canCoerce(underDomainOf t1, underDomainOf t2) - -canCoerceExplicit2Mapping(t1,t is ['Mapping,target,:argl]) == - -- determines if there a mapping called var with the given args - -- and target - $useCoerceOrCroak: local := nil - t1 is ['Variable,var] => - null (mms :=selectMms1(var,target,argl,[NIL for a in argl],true)) => NIL - mm := CAAR mms - mm is [., targ, :.] => - targ = target => true - false - false - t1 is ['FunctionCalled,fun] => - funNode := mkAtreeNode fun - transferPropsToNode(fun,funNode) - mms := CATCH('coerceOrCroaker, selectLocalMms(funNode,fun,argl,target)) - CONSP mms => - mms is [[['interpOnly,:.],:.]] => nil - mm := CAAR mms - mm is [., targ, :.] => - targ = target => true - false - false - NIL - NIL - -canCoerceUnion(t1,t2) == - -- sees if one can coerce to or from a Union Domain - -- assumes one of t1 and t2 is one - - -- get the domains in the union, checking for tagged unions - if (isUnion1 := t1 is ['Union,:uds1]) then - unionDoms1 := - uds1 and first uds1 is [":",:.] => [t for [.,.,t] in uds1] - uds1 - if (isUnion2 := t2 is ['Union,:uds2]) then - unionDoms2 := - uds2 and first uds2 is [":",:.] => [t for [.,.,t] in uds2] - uds2 - - isUnion2 => - member(t1,unionDoms2) => true - isUnion1 => - and/[or/[canCoerce(ud1,ud2) for ud2 in unionDoms2] - for ud1 in unionDoms1] - or/[canCoerce(t1,ud) for ud in unionDoms2] - -- next, a little lie - t1 is ['Union,d1, ='"failed"] and t2 = d1 => true - isUnion1 => - and/[canCoerce(ud,t2) for ud in unionDoms1] - keyedSystemError("S2GE0016",['"canCoerceUnion", - '"called with 2 non-Unions"]) - -canCoerceByMap(t1,t2) == - -- idea is this: if t1 is D U1 and t2 is D U2, then look for - -- map: (U1 -> U2, D U1) -> D U2. If it exists, then answer true - -- if canCoerceFrom(t1,t2). - u2 := deconstructT t2 - 1 = #u2 => NIL - u1 := deconstructT t1 - 1 = #u1 => NIL -- no under domain - CAR(u1) ^= CAR(u2) => NIL - top := CAAR u1 - u1 := underDomainOf t1 - u2 := underDomainOf t2 - - absolutelyCannotCoerce(u1,u2) => NIL - - -- save some time for those we know about - know := '(List Vector Segment Stream UniversalSegment Array - Polynomial UnivariatePolynomial SquareMatrix Matrix) - top in know => canCoerce(u1,u2) - - null selectMms1('map,t2,[['Mapping,u2,u1],t1], - [['Mapping,u2,u1],u1],NIL) => NIL - -- don't bother checking for Undef, so avoid instantiation - canCoerce(u1,u2) - -canCoerceTower(t1,t2) == --- tries to find a coercion between top level t2 and somewhere inside t1 --- builds new bubbled type, for which coercion is called recursively - canCoerceByMap(t1,t2) or newCanCoerceCommute(t1,t2) or - canCoerceLocal(t1,t2) or canCoercePermute(t1,t2) or - [c1,:arg1]:= deconstructT t1 - arg1 and - TL:= NIL - arg:= arg1 - until x or not arg repeat x:= - t:= last arg - [c,:arg]:= deconstructT t - TL:= [c,arg,:TL] - arg and coerceIntTest(t,t2) and - CDDR TL => - s:= constructT(c1,replaceLast(arg1,bubbleConstructor TL)) - canCoerceLocal(t1,s) and - [c2,:arg2]:= deconstructT last s - s1:= bubbleConstructor [c2,arg2,c1,arg1] - canCoerceCommute(s,s1) and canCoerceLocal(s1,t2) - s:= bubbleConstructor [c,arg,c1,arg1] - newCanCoerceCommute(t1,s) and canCoerceLocal(s,t2) - x - -canCoerceLocal(t1,t2) == - -- test for coercion on top level - p:= ASSQ(CAR t1,$CoerceTable) - p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => - tag='partial => NIL - tag='total => true - (functionp(fun) and - (v:=CATCH('coerceFailure,FUNCALL(fun,'_$fromCoerceable_$,t1,t2))) - and v ^= $coerceFailure) or canCoerceByFunction(t1,t2) - canCoerceByFunction(t1,t2) - -canCoerceCommute(t1,t2) == --- THIS IS OUT-MODED AND WILL GO AWAY SOON RSS 2-87 --- t1 is t2 with the two top level constructors commuted --- looks for the existence of a commuting function - CAR(t1) in (l := [$QuotientField, 'Gaussian]) and - CAR(t2) in l => true - p:= ASSQ(CAR t1,$CommuteTable) - p and ASSQ(CAR t2,CDR p) is [.,:['commute,.]] - -newCanCoerceCommute(t1,t2) == - coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2) - -canCoercePermute(t1,t2) == - -- try to generate a sequence of transpositions that will convert - -- t1 into t2 - t2 in '((Integer) (OutputForm)) => NIL - towers := computeTTTranspositions(t1,t2) - -- at this point, CAR towers = t1 and last towers should be similar - -- to t2 in the sense that the components of t1 are in the same order - -- as in t2. If length towers = 2 and t2 = last towers, we quit to - -- avoid an infinte loop. - NULL towers or NULL CDR towers => NIL - NULL CDDR towers and t2 = CADR towers => NIL - -- do the coercions successively, quitting if any fail - ok := true - for t in CDR towers while ok repeat - ok := canCoerce(t1,t) - if ok then t1 := t - ok - -canConvertByFunction(m1,m2) == - null $useConvertForCoercions => NIL - canCoerceByFunction1(m1,m2,'convert) - -canCoerceByFunction(m1,m2) == canCoerceByFunction1(m1,m2,'coerce) - -canCoerceByFunction1(m1,m2,fun) == - -- calls selectMms with $Coerce=NIL and tests for required target=m2 - $declaredMode:local:= NIL - $reportBottomUpFlag:local:= NIL - -- have to handle cases where we might have changed from RN to QF I - -- make 2 lists of expanded and unexpanded types - l1 := REMDUP [m1,eqType m1] - l2 := REMDUP [m2,eqType m2] - ans := NIL - for t1 in l1 while not ans repeat - for t2 in l2 while not ans repeat - l := selectMms1(fun,t2,[t1],[t1],NIL) - ans := [x for x in l | x is [sig,:.] and CADR sig=t2 and - CADDR sig=t1 and - CAR(sig) isnt ['TypeEquivalence,:.]] and true - ans - -absolutelyCanCoerceByCheating(t1,t2) == - -- this typically involves subdomains and towers where the only - -- difference is a subdomain - isEqualOrSubDomain(t1,t2) => true - typeIsASmallInteger(t1) and t2 = $Integer => true - ATOM(t1) or ATOM(t2) => false - [tl1,:u1] := deconstructT t1 - [tl2,:u2] := deconstructT t2 - tl1 = '(Stream) and tl2 = '(InfiniteTuple) => - #u1 ^= #u2 => false - "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2] - tl1 ^= tl2 => false - #u1 ^= #u2 => false - "and"/[absolutelyCanCoerceByCheating(x1,x2) for x1 in u1 for x2 in u2] - -absolutelyCannotCoerce(t1,t2) == - -- response of true means "definitely cannot coerce" - -- this is largely an efficiency hack - ATOM(t1) or ATOM(t2) => NIL - t2 = '(None) => true - n1 := CAR t1 - n2 := CAR t2 - QFI := [$QuotientField, $Integer] - int2 := isEqualOrSubDomain(t2,$Integer) - scalars := '(BigFloat NewFloat Float DoubleFloat RationalNumber) - - MEMQ(n1,scalars) and int2 => true - (t1 = QFI) and int2 => true - - num2 := int2 or MEMQ(n2,scalars) or (t2 = QFI) - isVar1 := MEMQ(n1,'(Variable Symbol)) - - num2 and isVar1 => true - num2 and MEMQ(n1,$univariateDomains) => true - num2 and MEMQ(n1,$multivariateDomains) => true - miscpols := '(Polynomial ElementaryFunction SimpleAlgebraicExtension) - num2 and MEMQ(n1,miscpols) => true - - aggs := '( - Matrix List Vector Stream Array RectangularMatrix FiniteSet - ) - u1 := underDomainOf t1 - u2 := underDomainOf t2 - MEMQ(n1,aggs) and (u1 = t2) => true - MEMQ(n2,aggs) and (u2 = t1) => true - - algs := '( - SquareMatrix Gaussian RectangularMatrix Quaternion - ) - nonpols := append(aggs,algs) - num2 and MEMQ(n1,nonpols) => true - isVar1 and MEMQ(n2,nonpols) and - absolutelyCannotCoerce(t1,u2) => true - - (MEMQ(n1,scalars) or (t1 = QFI)) and (t2 = '(Polynomial (Integer))) => - true - - v2 := deconstructT t2 - 1 = #v2 => NIL - v1 := deconstructT t1 - 1 = #v1 => NIL - CAR(v1) ^= CAR(v2) => NIL - absolutelyCannotCoerce(u1,u2) - -typeIsASmallInteger x == (x = $SingleInteger) - - ---% Interpreter Coercion Functions - -coerceInteractive(triple,t2) == - -- bind flag for recording/reporting instantiations - -- (see recordInstantiation) - t1 := objMode triple - val := objVal triple - null(t2) or t2 = $EmptyMode => NIL - t2 = t1 => triple - t2 = '$NoValueMode => objNew(val,t2) - if t2 is ['SubDomain,x,.] then t2:= x - -- JHD added category Aug 1996 for BasicMath - t1 in '((Category) (Mode) (Domain) (SubDomain (Domain))) => - t2 = $OutputForm => objNew(val,t2) - NIL - t1 = '$NoValueMode => - if $compilingMap then clearDependentMaps($mapName,nil) - throwKeyedMsg("S2IC0009",[t2,$mapName]) - $insideCoerceInteractive: local := true - expr2 := EQUAL(t2,$OutputForm) - if expr2 then startTimingProcess 'print - else startTimingProcess 'coercion - -- next 2 lines handle cases like '"failed" - result := - expr2 and (t1 = val) => objNew(val,$OutputForm) - expr2 and t1 is ['Variable,var] => objNewWrap(var,$OutputForm) - coerceInt0(triple,t2) - if expr2 then stopTimingProcess 'print - else stopTimingProcess 'coercion - result - -coerceInt0(triple,t2) == - -- top level interactive coercion, which transfers all RN, RF and RR - -- into equivalent types - val := objVal triple - t1 := objMode triple - - val='_$fromCoerceable_$ => canCoerceFrom(t1,t2) - t1 = t2 => triple - if t2 = $OutputForm then - s1 := t1 - s2 := t2 - else - s1 := equiType(t1) - s2 := equiType(t2) - s1 = s2 => return objNew(val,t2) - -- t1 is ['Mapping,:.] and t2 ^= '(Any) => NIL - -- note: may be able to coerce TO mapping - -- treat Exit like Any - -- handle case where we must generate code - null(isWrapped val) and - (t1 isnt ['FunctionCalled,:.] or not $genValue)=> - intCodeGenCOERCE(triple,t2) - t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and - (ans := coerceInt0(objNewWrap(val',t1'),t2)) => ans - if not EQ(s1,t1) then triple := objNew(val,s1) - x := coerceInt(triple,s2) => - EQ(s2,t2) => x - objSetMode(x,t2) - x - NIL - -coerceInt(triple, t2) == - val := coerceInt1(triple, t2) => val - t1 := objMode triple - t1 is ['Variable, :.] => - newMode := getMinimalVarMode(unwrap objVal triple, nil) - newVal := coerceInt(triple, newMode) - coerceInt(newVal, t2) - nil - -coerceInt1(triple,t2) == - -- general interactive coercion - -- the result is a new triple with type m2 or NIL (= failed) - $useCoerceOrCroak: local := true - t2 = $EmptyMode => NIL - t1 := objMode triple - t1=t2 => triple - val := objVal triple - absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) - isSubDomain(t2, t1) => coerceSubDomain(val, t1, t2) - - if typeIsASmallInteger(t1) then - (t2 = $Integer) or typeIsASmallInteger(t2) => return objNew(val,t2) - sintp := SINTP val - sintp and (t2 = $PositiveInteger) and val > 0 => return objNew(val,t2) - sintp and (t2 = $NonNegativeInteger) and val >= 0 => return objNew(val,t2) - - typeIsASmallInteger(t2) and isEqualOrSubDomain(t1, $Integer) and INTP val => - SINTP val => objNew(val,t2) - NIL - - t2 = $Void => objNew(voidValue(),$Void) - t2 = $Any => objNewWrap([t1,:unwrap val],'(Any)) - - t1 = $Any and t2 ^= $OutputForm and ([t1',:val'] := unwrap val) and - (ans := coerceInt(objNewWrap(val',t1'),t2)) => ans - - -- next is for tagged union selectors for the time being - t1 is ['Variable,=t2] or t2 is ['Variable,=t1] => objNew(val,t2) - - STRINGP t2 => - t1 is ['Variable,v] and (t2 = PNAME(v)) => objNewWrap(t2,t2) - val' := unwrap val - (t2 = val') and ((val' = t1) or (t1 = $String)) => objNew(val,t2) - NIL - -- t1 is ['Tuple,S] and t2 ^= '(OutputForm) => - t1 is ['Tuple,S] => - coerceInt1(objNewWrap(asTupleAsList unwrap val, ['List, S]), t2) - t1 is ['Union,:.] => coerceIntFromUnion(triple,t2) - t2 is ['Union,:.] => coerceInt2Union(triple,t2) - (STRINGP t1) and (t2 = $String) => objNew(val,$String) - (STRINGP t1) and (t2 is ['Variable,v]) => - t1 = PNAME(v) => objNewWrap(v,t2) - NIL - (STRINGP t1) and (t1 = unwrap val) => - t2 = $OutputForm => objNew(t1,$OutputForm) - NIL - atom t1 => NIL - - if t1 = $AnonymousFunction and (t2 is ['Mapping,target,:margl]) then - $useCoerceOrCroak := nil - [.,vars,:body] := unwrap val - vars := - atom vars => [vars] - vars is ['Tuple,:.] => rest vars - vars - #margl ^= #vars => 'continue - tree := mkAtree ['ADEF,vars,[target,:margl],[NIL for x in rest t2],:body] - CATCH('coerceOrCroaker, bottomUp tree) = 'croaked => nil - return getValue tree - - (t1 = $Symbol) and (t2 is ['Mapping,target,:margl]) => - null (mms := selectMms1(unwrap val,nil,margl,margl,target)) => NIL - [dc,targ,:argl] := CAAR mms - targ ^= target => NIL - $genValue => - fun := getFunctionFromDomain(unwrap val,dc,argl) - objNewWrap(fun,t2) - val := NRTcompileEvalForm(unwrap val, CDR CAAR mms, evalDomain dc) - objNew(val, t2) - (t1 is ['Variable,sym]) and (t2 is ['Mapping,target,:margl]) => - null (mms := selectMms1(sym,target,margl,margl,NIL)) => - null (mms := selectMms1(sym,target,margl,margl,true)) => NIL - [dc,targ,:argl] := CAAR mms - targ ^= target => NIL - dc is ["__FreeFunction__",:freeFun] => objNew( freeFun, t2 ) - $genValue => objNewWrap( getFunctionFromDomain(sym,dc,argl), t2 ) - val := NRTcompileEvalForm(sym, CDR CAAR mms, evalDomain dc) - objNew(val, t2) - (t1 is ['FunctionCalled,sym]) and (t2 is ['Mapping,target,:margl]) => - symNode := mkAtreeNode sym - transferPropsToNode(sym,symNode) - null (mms := selectLocalMms(symNode,sym,margl,target)) => NIL - [dc,targ,:argl] := CAAR mms - targ ^= target => NIL - ml := [target,:margl] - intName := - or/[mm for mm in mms | (mm is [[., :ml1],oldName,:.] - and compareTypeLists(ml1,ml))] => [oldName] - NIL - null intName => NIL - objNewWrap(intName,t2) - (t1 is ['FunctionCalled,sym]) => - (t3 := get(sym,'mode,$e)) and t3 is ['Mapping,:.] => - (triple' := coerceInt(triple,t3)) => coerceInt(triple',t2) - NIL - NIL - - EQ(CAR(t1),'Variable) and PAIRP(t2) and - (isEqualOrSubDomain(t2,$Integer) or - (t2 = [$QuotientField, $Integer]) or MEMQ(CAR(t2), - '(RationalNumber BigFloat NewFloat Float DoubleFloat))) => NIL - - ans := coerceRetract(triple,t2) or coerceIntTower(triple,t2) or - [.,:arg]:= deconstructT t2 - arg and - t:= coerceInt(triple,last arg) - t and coerceByFunction(t,t2) - ans or (isSubDomain(t1,$Integer) and - coerceInt(objNew(val,$Integer),t2)) or - coerceIntAlgebraicConstant(triple,t2) or - coerceIntX(val,t1,t2) - -coerceSubDomain(val, tSuper, tSub) == - -- Try to coerce from a sub domain to a super domain - val = '_$fromCoerceable_$ => nil - super := GETDATABASE(first tSub, 'SUPERDOMAIN) - superDomain := first super - superDomain = tSuper => - coerceImmediateSubDomain(val, tSuper, tSub, CADR super) - coerceSubDomain(val, tSuper, superDomain) => - coerceImmediateSubDomain(val, superDomain, tSub, CADR super) - nil - -coerceImmediateSubDomain(val, tSuper, tSub, pred) == - predfn := getSubDomainPredicate(tSuper, tSub, pred) - FUNCALL(predfn, val, nil) => objNew(val, tSub) - nil - -getSubDomainPredicate(tSuper, tSub, pred) == - $env: local := $InteractiveFrame - predfn := HGET($superHash, CONS(tSuper, tSub)) => predfn - name := GENSYM() - decl := ['_:, name, ['Mapping, $Boolean, tSuper]] - interpret(decl, nil) - arg := GENSYM() - pred' := SUBST(arg, "#1", pred) - defn := ['DEF, [name, arg], '(NIL NIL), '(NIL NIL), removeZeroOne pred'] - interpret(defn, nil) - op := mkAtree name - transferPropsToNode(name, op) - predfn := CADAR selectLocalMms(op, name, [tSuper],$Boolean) - HPUT($superHash, CONS(tSuper, tSub), predfn) - predfn - -coerceIntX(val,t1, t2) == - -- some experimental things - t1 = '(List (None)) => - -- this will almost always be an empty list - null unwrap val => - -- try getting a better flavor of List - null (t0 := underDomainOf(t2)) => NIL - coerceInt(objNewWrap(val,['List,t0]),t2) - NIL - NIL - -compareTypeLists(tl1,tl2) == - -- returns true if every type in tl1 is = or is a subdomain of - -- the corresponding type in tl2 - for t1 in tl1 for t2 in tl2 repeat - null isEqualOrSubDomain(t1,t2) => return NIL - true - -coerceIntAlgebraicConstant(object,t2) == - -- should use = from domain, but have to check on defaults code - t1 := objMode object - val := objValUnwrap object - ofCategory(t1,'(Monoid)) and ofCategory(t2,'(Monoid)) and - val = getConstantFromDomain('(One),t1) => - objNewWrap(getConstantFromDomain('(One),t2),t2) - ofCategory(t1,'(AbelianMonoid)) and ofCategory(t2,'(AbelianMonoid)) and - val = getConstantFromDomain('(Zero),t1) => - objNewWrap(getConstantFromDomain('(Zero),t2),t2) - NIL - -coerceUnion2Branch(object) == - [.,:unionDoms] := objMode object - doms := orderUnionEntries unionDoms - predList:= mkPredList doms - doms := stripUnionTags doms - val' := objValUnwrap object - predicate := NIL - targetType:= NIL - for typ in doms for pred in predList while ^targetType repeat - evalSharpOne(pred,val') => - predicate := pred - targetType := typ - null targetType => keyedSystemError("S2IC0013",NIL) - predicate is ['EQCAR,.,p] => objNewWrap(CDR val',targetType) - objNew(objVal object,targetType) - -coerceBranch2Union(object,union) == - -- assumes type is a member of unionDoms - unionDoms := CDR union - doms := orderUnionEntries unionDoms - predList:= mkPredList doms - doms := stripUnionTags doms - p := position(objMode object,doms) - p = -1 => keyedSystemError("S2IC0014",[objMode object,union]) - val := objVal object - predList.p is ['EQCAR,.,tag] => - objNewWrap([removeQuote tag,:unwrap val],union) - objNew(val,union) - -coerceInt2Union(object,union) == - -- coerces to a Union type, adding numeric tags - -- first cut - unionDoms := stripUnionTags CDR union - t1 := objMode object - member(t1,unionDoms) => coerceBranch2Union(object,union) - val := objVal object - val' := unwrap val - (t1 = $String) and member(val',unionDoms) => - coerceBranch2Union(objNew(val,val'),union) - noCoerce := true - val' := nil - for d in unionDoms while noCoerce repeat - (val' := coerceInt(object,d)) => noCoerce := nil - val' => coerceBranch2Union(val',union) - NIL - -coerceIntFromUnion(object,t2) == - -- coerces from a Union type to something else - coerceInt(coerceUnion2Branch object,t2) - -coerceIntByMap(triple,t2) == - -- idea is this: if t1 is D U1 and t2 is D U2, then look for - -- map: (U1 -> U2, D U1) -> D U2. If it exists, then create a - -- function to do the coercion on the element level and call the - -- map function. - t1 := objMode triple - t2 = t1 => triple - u2 := deconstructT t2 -- compute t2 first because of Expression - 1 = #u2 => NIL -- no under domain - u1 := deconstructT t1 - 1 = #u1 => NIL - CAAR u1 ^= CAAR u2 => nil -- constructors not equal - ^valueArgsEqual?(t1, t2) => NIL --- CAR u1 ^= CAR u2 => NIL - top := CAAR u1 - u1 := underDomainOf t1 - u2 := underDomainOf t2 - - -- handle a couple of special cases for subdomains of Integer - top in '(List Vector Segment Stream UniversalSegment Array) - and isSubDomain(u1,u2) => objNew(objVal triple, t2) - - args := [['Mapping,u2,u1],t1] - if $reportBottomUpFlag then - sayFunctionSelection('map,args,t2,NIL, - '"coercion facility (map)") - mms := selectMms1('map,t2,args,args,NIL) - if $reportBottomUpFlag then - sayFunctionSelectionResult('map,args,mms) - null mms => NIL - - [[dc,:sig],slot,.]:= CAR mms - fun := compiledLookup('map,sig,evalDomain(dc)) - NULL fun => NIL - [fn,:d]:= fun - fn = function Undef => NIL - -- now compile a function to do the coercion - code := ['SPADCALL,['CONS,["function","coerceIntByMapInner"],MKQ [u1,:u2]], - wrapped2Quote objVal triple,MKQ fun] - -- and apply the function - val := CATCH('coerceFailure,timedEvaluate code) - (val = $coerceFailure) => NIL - objNewWrap(val,t2) - -coerceIntByMapInner(arg,[u1,:u2]) == coerceOrThrowFailure(arg,u1,u2) --- [u1,:u2] gets passed as the "environment", which is why we have this --- slightly clumsy locution JHD 31.July,1990 - -valueArgsEqual?(t1, t2) == - -- returns true if the object-valued arguments to t1 and t2 are the same - -- under coercion - coSig := CDR GETDATABASE(CAR t1, 'COSIG) - constrSig := CDR getConstructorSignature CAR t1 - tl1 := replaceSharps(constrSig, t1) - tl2 := replaceSharps(constrSig, t2) - not MEMQ(NIL, coSig) => true - done := false - value := true - for a1 in CDR t1 for a2 in CDR t2 for cs in coSig - for m1 in tl1 for m2 in tl2 while not done repeat - ^cs => - trip := objNewWrap(a1, m1) - newVal := coerceInt(trip, m2) - null newVal => (done := true; value := false) - ^algEqual(a2, objValUnwrap newVal, m2) => - (done := true; value := false) - value - -coerceIntTower(triple,t2) == - -- tries to find a coercion from top level t2 to somewhere inside t1 - -- builds new argument type, for which coercion is called recursively - x := coerceIntByMap(triple,t2) => x - x := coerceIntCommute(triple,t2) => x - x := coerceIntPermute(triple,t2) => x - x := coerceIntSpecial(triple,t2) => x - x := coerceIntTableOrFunction(triple,t2) => x - t1 := objMode triple - [c1,:arg1]:= deconstructT t1 - arg1 and - TL:= NIL - arg:= arg1 - until x or not arg repeat - t:= last arg - [c,:arg]:= deconstructT t - TL:= [c,arg,:TL] - x := arg and coerceIntTest(t,t2) => - CDDR TL => - s := constructT(c1,replaceLast(arg1,bubbleConstructor TL)) - (null isValidType(s)) => (x := NIL) - x := (coerceIntByMap(triple,s) or - coerceIntTableOrFunction(triple,s)) => - [c2,:arg2]:= deconstructT last s - s:= bubbleConstructor [c2,arg2,c1,arg1] - (null isValidType(s)) => (x := NIL) - x:= coerceIntCommute(x,s) => - x := (coerceIntByMap(x,t2) or - coerceIntTableOrFunction(x,t2)) - s:= bubbleConstructor [c,arg,c1,arg1] - (null isValidType(s)) => (x := NIL) - x:= coerceIntCommute(triple,s) => - x:= (coerceIntByMap(x,t2) or - coerceIntTableOrFunction(x,t2)) - x - -coerceIntSpecial(triple,t2) == - t1 := objMode triple - t2 is ['SimpleAlgebraicExtension,R,U,.] and t1 = R => - null (x := coerceInt(triple,U)) => NIL - coerceInt(x,t2) - NIL - -coerceIntTableOrFunction(triple,t2) == - -- this function does the actual coercion to t2, but not to an - -- argument type of t2 - null isValidType t2 => NIL -- added 9-18-85 by RSS - null isLegitimateMode(t2,NIL,NIL) => NIL -- added 6-28-87 by RSS - t1 := objMode triple - p:= ASSQ(CAR t1,$CoerceTable) - p and ASSQ(CAR t2,CDR p) is [.,:[tag,fun]] => - val := objVal triple - fun='Identity => objNew(val,t2) - tag='total => - coerceByTable(fun,val,t1,t2,'T) or coerceByFunction(triple,t2) - coerceByTable(fun,val,t1,t2,NIL) or coerceByFunction(triple,t2) - coerceByFunction(triple,t2) - -coerceCommuteTest(t1,t2) == - null isLegitimateMode(t2,NIL,NIL) => NIL - - -- sees whether t1 = D1 D2 R and t2 = D2 D1 S - null (u1 := underDomainOf t1) => NIL - null (u2 := underDomainOf t2) => NIL - - -- must have underdomains (ie, R and S must be there) - - null (v1 := underDomainOf u1) => NIL - null (v2 := underDomainOf u2) => NIL - - -- now check that cross of constructors is correct - (CAR(deconstructT t1) = CAR(deconstructT u2)) and - (CAR(deconstructT t2) = CAR(deconstructT u1)) - -coerceIntCommute(obj,target) == - -- note that the value in obj may be $fromCoerceable$, for canCoerce - source := objMode obj - null coerceCommuteTest(source,target) => NIL - S := underDomainOf source - T := underDomainOf target - source = T => NIL -- handle in other ways - - source is [D,:.] => - fun := GETL(D,'coerceCommute) or - INTERN STRCONC('"commute",STRINGIMAGE D) - functionp fun => - PUT(D,'coerceCommute,fun) - u := objValUnwrap obj - c := CATCH('coerceFailure,FUNCALL(fun,u,source,S,target,T)) - (c = $coerceFailure) => NIL - u = "$fromCoerceable$" => c - objNewWrap(c,target) - NIL - NIL - -coerceIntPermute(object,t2) == - t2 in '((Integer) (OutputForm)) => NIL - t1 := objMode object - towers := computeTTTranspositions(t1,t2) - -- at this point, CAR towers = t1 and last towers should be similar - -- to t2 in the sense that the components of t1 are in the same order - -- as in t2. If length towers = 2 and t2 = last towers, we quit to - -- avoid an infinte loop. - NULL towers or NULL CDR towers => NIL - NULL CDDR towers and t2 = CADR towers => NIL - -- do the coercions successively, quitting if any fail - ok := true - for t in CDR towers while ok repeat - null (object := coerceInt(object,t)) => ok := NIL - ok => object - NIL - -computeTTTranspositions(t1,t2) == - -- decompose t1 into its tower parts - tl1 := decomposeTypeIntoTower t1 - tl2 := decomposeTypeIntoTower t2 - -- if not at least 2 parts, don't bother working here - null (rest tl1 and rest tl2) => NIL - -- determine the relative order of the parts of t1 in t2 - p2 := [position(d1,tl2) for d1 in tl1] - member(-1,p2) => NIL -- something not present - -- if they are all ascending, this function will do nothing - p2' := MSORT p2 - p2 = p2' => NIL - -- if anything is repeated twice, leave - p2' ^= MSORT REMDUP p2' => NIL - -- create a list of permutations that transform the tower parts - -- of t1 into the order they are in in t2 - n1 := #tl1 - p2 := LIST2VEC compress(p2,0,# REMDUP tl1) where - compress(l,start,len) == - start >= len => l - member(start,l) => compress(l,start+1,len) - compress([(i < start => i; i - 1) for i in l],start,len) - -- p2 now has the same position numbers as p1, we need to determine - -- a list of permutations that takes p1 into p2. - -- them - perms := permuteToOrder(p2,n1-1,0) - towers := [tl1] - tower := LIST2VEC tl1 - for perm in perms repeat - t := tower.(CAR perm) - tower.(CAR perm) := tower.(CDR perm) - tower.(CDR perm) := t - towers := CONS(VEC2LIST tower,towers) - towers := [reassembleTowerIntoType tower for tower in towers] - if CAR(towers) ^= t2 then towers := cons(t2,towers) - NREVERSE towers - -decomposeTypeIntoTower t == - ATOM t => [t] - d := deconstructT t - NULL rest d => [t] - rd := REVERSE t - [reverse QCDR rd,:decomposeTypeIntoTower QCAR rd] - -reassembleTowerIntoType tower == - ATOM tower => tower - NULL rest tower => CAR tower - [:top,t,s] := tower - reassembleTowerIntoType [:top,[:t,s]] - -permuteToOrder(p,n,start) == - -- p is a vector of the numbers 0..n. This function returns a list - -- of swaps of adjacent elements so that p will be in order. We only - -- begin looking at index start - r := n - start - r <= 0 => NIL - r = 1 => - p.r < p.(r+1) => NIL - [[r,:(r+1)]] - p.start = start => permuteToOrder(p,n,start+1) - -- bubble up element start to the top. Find out where it is - stpos := NIL - for i in start+1..n while not stpos repeat - if p.i = start then stpos := i - perms := NIL - while stpos ^= start repeat - x := stpos - 1 - perms := [[x,:stpos],:perms] - t := p.stpos - p.stpos := p.x - p.x := t - stpos := x - APPEND(NREVERSE perms,permuteToOrder(p,n,start+1)) - -coerceIntTest(t1,t2) == - -- looks whether there exists a table entry or a coercion function - -- thus the type can be bubbled before coerceIntTableOrFunction is called - t1=t2 or - b:= - p:= ASSQ(CAR t1,$CoerceTable) - p and ASSQ(CAR t2,CDR p) - b or coerceConvertMmSelection('coerce,t1,t2) or - ($useConvertForCoercions and - coerceConvertMmSelection('convert,t1,t2)) - -coerceByTable(fn,x,t1,t2,isTotalCoerce) == - -- catch point for 'failure in boot coercions - t2 = $OutputForm and ^(newType? t1) => NIL - isWrapped x => - x:= unwrap x - c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2)) - c=$coerceFailure => NIL - objNewWrap(c,t2) - isTotalCoerce => objNew([fn,x,MKQ t1,MKQ t2],t2) - objNew(['catchCoerceFailure,MKQ fn,x,MKQ t1,MKQ t2],t2) - -catchCoerceFailure(fn,x,t1,t2) == - -- compiles a catchpoint for compiling boot coercions - c:= CATCH('coerceFailure,FUNCALL(fn,x,t1,t2)) - c = $coerceFailure => - throwKeyedMsgCannotCoerceWithValue(wrap unwrap x,t1,t2) - c - -coercionFailure() == - -- does the throw on coercion failure - THROW('coerceFailure,$coerceFailure) - -coerceByFunction(T,m2) == - -- using the new modemap selection without coercions - -- should not be called by canCoerceFrom - x := objVal T - x = '_$fromCoerceable_$ => NIL - m2 is ['Union,:.] => NIL - m1 := objMode T - m2 is ['Boolean,:.] and m1 is ['Equation,ud] => - dcVector := evalDomain ud - fun := - isWrapped x => - NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector) - NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector) - [fn,:d]:= fun - isWrapped x => - x:= unwrap x - objNewWrap(SPADCALL(CAR x,CDR x,fun),m2) - x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL) - code := ['SPADCALL, a, b, fun] - objNew(code,$Boolean) - -- If more than one function is found, any should suffice, I think -scm - if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then - mm := coerceConvertMmSelection(funName := 'convert,m1,m2) - mm => - [[dc,tar,:args],slot,.]:= mm - dcVector := evalDomain(dc) - fun:= ---+ - isWrapped x => - NRTcompiledLookup(funName,slot,dcVector) - NRTcompileEvalForm(funName,slot,dcVector) - [fn,:d]:= fun - fn = function Undef => NIL - isWrapped x => ---+ - $: fluid := dcVector - val := CATCH('coerceFailure, SPADCALL(unwrap x,fun)) - (val = $coerceFailure) => NIL - objNewWrap(val,m2) - env := fun - code := ['failCheck, ['SPADCALL, x, env]] --- tar is ['Union,:.] => objNew(['failCheck,code],m2) - objNew(code,m2) - -- try going back to types like RN instead of QF I - m1' := eqType m1 - m2' := eqType m2 - (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2') - NIL - -hasCorrectTarget(m,sig is [dc,tar,:.]) == - -- tests whether the target of signature sig is either m or a union - -- containing m. It also discards TEQ as it is not meant to be - -- used at top-level - dc is ['TypeEquivalence,:.] => NIL - m=tar => 'T - tar is ['Union,t,'failed] => t=m - tar is ['Union,'failed,t] and t=m - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-coerfn.boot b/src/interp/i-coerfn.boot new file mode 100644 index 00000000..47e8ddf7 --- /dev/null +++ b/src/interp/i-coerfn.boot @@ -0,0 +1,2224 @@ +-- 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. + + +import '"i-coerce" +)package "BOOT" + +$coerceFailure := GENSYM() + +position1(x,y) == + -- this is used where we want to assume a 1-based index + 1 + position(x,y) + +--% Direct Product, New and Old + +DP2DP(u,source is [.,n,S],target is [.,m,T]) == + n ^= m => nil + u = '_$fromCoerceable_$ => canCoerce(S,T) + null (u' := coerceInt(objNewWrap(u,['Vector,S]),['Vector,T])) => + coercionFailure() + objValUnwrap u' + +--% Distributed Multivariate Polynomials, New and Old + +Dmp2Dmp(u,source is [dmp,v1,S], target is [.,v2,T]) == + -- the variable lists must share some variables, or u is a constant + u = '_$fromCoerceable_$ => + v:= intersection(v1,v2) + v and + w2:= SETDIFFERENCE(v2,v) + t1:= if w1 then [dmp,w1,S] else S + t2:= if w2 then [dmp,w2,T] else T + canCoerce(t1,t2) + null u => domainZero(target) + u is [[e,:c]] and e=LIST2VEC [0 for v in v1] => + z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) + coercionFailure() + v:= intersection(v1,v2) => + w1:= SETDIFFERENCE(v1,v) => + coerceDmp1(u,source,target,v,w1) + coerceDmp2(u,source,target) + coercionFailure() + +coerceDmp1(u,source is [.,v1,S],target is [.,v2,T],v,w) == + -- coerces one Dmp to another, where v1 is not a subset of v2 + -- v is the intersection, w the complement of v1 and v2 + t:= ['DistributedMultivariatePolynomial,w,S] + x:= domainZero(target) + one:= domainOne(T) + plusfunc:= getFunctionFromDomain('_+,target,[target,target]) + multfunc:= getFunctionFromDomain('_*,target,[target,target]) + pat1:= [member(x,v) for x in v1] + pat2:= [member(x,w) for x in v1] + pat3:= [member(x,v) and POSN1(x,v) for x in v2] + for [e,:c] in u until not z repeat + exp:= LIST2VEC [y for x in pat2 for y in VEC2LIST e | x] + z:= coerceInt(objNewWrap([CONS(exp,c)],t),target) => + li:= [y for x in pat1 for y in VEC2LIST e | x] + a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat3],one)] + x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) + z => x + coercionFailure() + +coerceDmp2(u,source is [.,v1,S],target is [.,v2,T]) == + -- coerces one Dmp to another, where v1 is included in v2 + x:= domainZero(target) + one:= domainOne(T) + plusfunc:= getFunctionFromDomain('_+,target,[target,target]) + multfunc:= getFunctionFromDomain('_*,target,[target,target]) + pat:= [member(x,v1) and POSN1(x,v1) for x in v2] + for [e,:c] in u until not z repeat + z:= coerceInt(objNewWrap(c,S),target) => + li:= VEC2LIST e + a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat],one)] + x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) + NIL + z => x + coercionFailure() + +Dmp2Expr(u,source is [dmp,vars,S], target is [Expr,T]) == + u = '_$fromCoerceable_$ => canCoerce(S, target) + + null vars => + [[., :c]] := u + not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() + objValUnwrap(c) + + syms := [objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) for + var in vars] + sum := domainZero(target) + + plus := getFunctionFromDomain("+", target, [target, target]) + mult := getFunctionFromDomain("*", target, [target, target]) + expn := getFunctionFromDomain("**", target, [target, $Integer]) + + for [e, :c] in u repeat + not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() + c := objValUnwrap(c) + term := domainOne(target) + for i in 0.. for sym in syms repeat + exp := e.i + e.i > 0 => term := SPADCALL(term, SPADCALL(sym, e.i, expn), mult) + sum := SPADCALL(sum, SPADCALL(c, term, mult), plus) + + sum + +Dmp2Mp(u, source is [dmp, x, S], target is [mp, y, T]) == + source' := [dmp,y,T] + u = '_$fromCoerceable_$ => + x = y => canCoerce(S,T) + canCoerce(source',target) + null u => domainZero(target) -- 0 dmp is = nil + x ^= y => + (u' := coerceInt(objNewWrap(u,source),source')) or coercionFailure() + (u' := coerceInt(u',target)) or coercionFailure() + objValUnwrap(u') + + -- slight optimization for case #u = 1, x=y , #x =1 and S=T + -- I know it's pathological, but it may avoid an instantiation + (x=y) and (1 = #u) and (1 = #x) and (S = T) => + [1,1,[(CAAR u).0,0,:CDAR u]] + + (u' := coerceDmpCoeffs(u,S,T)) = 'failed => + coercionFailure() + plusfunc := getFunctionFromDomain("+",target,[target,target]) + u'' := genMpFromDmpTerm(u'.0, 0) + for i in 1..(#u' - 1) repeat + u'' := SPADCALL(u'',genMpFromDmpTerm(u'.i, 0),plusfunc) + u'' + +coerceDmpCoeffs(u,S,T) == + -- u is a dmp, S is domain of coeffs, T is domain to coerce coeffs to + S = T => u + u' := nil + bad := nil + for [e,:c] in u repeat + bad => nil + null (c' := coerceInt(objNewWrap(c,S),T)) => return (bad := true) + u' := [[e,:objValUnwrap(c')],:u'] + bad => 'failed + nreverse u' + +sortAndReorderDmpExponents(u,vl) == + vl' := reverse MSORT vl + n := (-1) + #vl + pos := LIST2VEC LZeros (n+1) + for i in 0..n repeat pos.i := position(vl.i,vl') + u' := nil + for [e,:c] in u repeat + e' := LIST2VEC LZeros (n+1) + for i in 0..n repeat e'.(pos.i) := e.i + u' := [[e',:c],:u'] + reverse u' + +domain2NDmp(u, source, target is [., y, T]) == + target' := ['DistributedMultivariatePolynomial,y,T] + u = '_$fromCoerceable_$ => canCoerce(source,target') + (u' := coerceInt(objNewWrap(u,source),target')) => + (u'' := coerceInt(u',target)) => + objValUnwrap(u'') + coercionFailure() + coercionFailure() + +Dmp2NDmp(u,source is [dmp,x,S],target is [ndmp,y,T]) == + -- a null DMP = 0 + null u => domainZero(target) + target' := [dmp,y,T] + u = '_$fromCoerceable_$ => Dmp2Dmp(u,source,target') + (u' := Dmp2Dmp(u,source,target')) => addDmpLikeTermsAsTarget(u',target) + coercionFailure() + +addDmpLikeTermsAsTarget(u,target) == + u' := domainZero(target) + func := getFunctionFromDomain("+",target,[target,target]) + for t in u repeat u' := SPADCALL(u',[t],func) + u' + +-- rewrite ? +Dmp2P(u, source is [dmp,vl, S], target is [.,T]) == + -- a null DMP = 0 + null u => domainZero(target) + u = '_$fromCoerceable_$ => + t := canCoerce(S,T) + null t => canCoerce(S,target) + t + + S is ['Polynomial,.] => + mp := coerceInt(objNewWrap(u,source),['MultivariatePolynomial,vl,S]) + or coercionFailure() + p := coerceInt(mp,target) or coercionFailure() + objValUnwrap p + + -- slight optimization for case #u = 1, #vl =1 and S=T + -- I know it's pathological, but it may avoid an instantiation + (1 = #u) and (1 = #vl) and (S = T) => + (lexp:= (CAAR u).0) = 0 => [1,:CDAR u] + [1,vl.0,[lexp,0,:CDAR u]] + + vl' := reverse MSORT vl + source' := [dmp,vl',S] + target' := ['MultivariatePolynomial,vl',S] + u' := sortAndReorderDmpExponents(u,vl) + u' := coerceInt(objNewWrap(u',source'),target') + if u' then + u' := translateMpVars2PVars (objValUnwrap(u'),vl') + u' := coerceInt(objNewWrap(u',['Polynomial,S]),target) + u' => objValUnwrap(u') + -- get drastic. create monomials + source' := [dmp,vl,T] + u' := domainZero(target) + oneT := domainOne(T) + plusfunc := getFunctionFromDomain("+",target,[target,target]) + multfunc := getFunctionFromDomain("*",target,[target,target]) + for [e,:c] in u repeat + (c' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + (e' := coerceInt(objNewWrap([[e,:oneT]],source'),target)) or + coercionFailure() + t := SPADCALL(objValUnwrap(e'),objValUnwrap(c'),multfunc) + u' := SPADCALL(u',t,plusfunc) + coercionFailure() + +translateMpVars2PVars (u, vl) == + u is [ =1, v, :termlist] => + [ 1, vl.(v-1), + :[[e,:translateMpVars2PVars(c,vl)] for [e,:c] in termlist]] + u + +Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) == + null u => -- this is true if u = 0 + domainZero(target) + + u = '_$fromCoerceable_$ => + member(var,vl) => + vl' := remove(vl,var) + null vl' => -- no remaining variables + canCoerce(S,T) + null rest vl' => -- one remaining variable + canCoerce([up,first vl',S],T) + canCoerce([dmp,vl',S], T) + canCoerce(source,T) + + -- check constant case + (null rest u) and (first(u) is [e,:c]) and + ( and/[(0 = e.i) for i in 0..(-1 + #vl)] ) => + (x := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(x) + + -- check non-member case + null member(var,vl) => + (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() + [[0,:objValUnwrap u']] + + vl' := remove(vl,var) + + -- only one variable in DMP case + null vl' => + u' := nreverse SORTBY('CAR,[[e.0,:c] for [e,:c] in u]) + (u' := coerceInt(objNewWrap(u',[up,var,S]),target)) or + coercionFailure() + objValUnwrap u' + + S1 := [dmp,vl',S] + plusfunc:= getFunctionFromDomain('_+,T,[T,T]) + zero := getConstantFromDomain('(Zero),T) + x := NIL + pos:= POSN1(var,vl) + for [e,:c] in u until not y repeat + exp:= e.pos + e1:= removeVectorElt(e,pos) + y:= coerceInt(objNewWrap([[e1,:c]],S1),T) => + -- need to be careful about zeros + p:= ASSQ(exp,x) => + c' := SPADCALL(CDR p,objValUnwrap(y),plusfunc) + c' = zero => x := REMALIST(x,exp) + RPLACD(p,c') + zero = objValUnwrap(y) => 'iterate + x := CONS(CONS(exp,objValUnwrap(y)),x) + y => nreverse SORTBY('CAR,x) + coercionFailure() + +removeVectorElt(v,pos) == + -- removes the pos'th element from vector v + LIST2VEC [x for x in VEC2LIST v for y in 0.. | not (y=pos)] + +removeListElt(l,pos) == + pos = 0 => CDR l + [CAR l, :removeListElt(CDR l,pos-1)] + +NDmp2domain(u,source is [ndmp,x,S],target) == + -- a null NDMP = 0 + null u => domainZero(target) + dmp := 'DistributedMultivariatePolynomial + source' := [dmp,x,S] + u = '_$fromCoerceable_$ => canCoerce(source',target) + u' := addDmpLikeTermsAsTarget(u,source') + (u'' := coerceInt(objNewWrap(u',source'),target)) => + objValUnwrap(u'') + coercionFailure() + +NDmp2NDmp(u,source is [ndmp,x,S],target is [.,y,T]) == + -- a null NDMP = 0 + null u => domainZero(target) + dmp := 'DistributedMultivariatePolynomial + source' := [dmp,x,S] + target' := [dmp,y,T] + u = '_$fromCoerceable_$ => canCoerce(source',target') + u' := addDmpLikeTermsAsTarget(u,source') + (u'' := coerceInt(objNewWrap(u',source'),target')) => + addDmpLikeTermsAsTarget(objValUnwrap(u''),target) + coercionFailure() + +--% Expression + +Expr2Complex(u,source is [.,S], target is [.,T]) == + u = '_$fromCoerceable_$ => nil -- can't tell, in general + + not member(S, [$Integer, $Float, $DoubleFloat]) => coercionFailure() + not member(T, [$Float, $DoubleFloat]) => coercionFailure() + + complexNumeric := getFunctionFromDomain("complexNumeric", ['Numeric, S], [source]) + + -- the following might fail + cf := SPADCALL(u,complexNumeric) -- returns a Float + T = $DoubleFloat => + null (z := coerceInt(objNewWrap(cf, ['Complex, $Float]), ['Complex, $DoubleFloat])) => + coercionFailure() + objValUnwrap z + cf + +Expr2Dmp(u,source is [Expr,S], target is [dmp,v2,T]) == + u = '_$fromCoerceable_$ => canCoerce(source, T) + + null v2 => + not (z := coerceInt(objNewWrap(u, source), T)) => coercionFailure() + [[LIST2VEC NIL, :objValUnwrap z]] + + obj := objNewWrap(u, source) + univ := coerceInt(obj, ['UnivariatePolynomial, first v2, T]) + not univ => + T = source => coercionFailure() + not (z := coerceInt(obj, [dmp, v2, source])) => + coercionFailure() + z := objValUnwrap z + for term in z repeat + [., :c] := term + not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() + RPLACD(term, objValUnwrap c) + z + + univ := objValUnwrap univ + + -- only one variable + + null rest v2 => + for term in univ repeat + RPLACA(term, VECTOR CAR term) + univ + + -- more than one variable + + summands := nil + for [e,:c] in univ repeat + summands := Expr2Dmp1(summands, + LIST2VEC [e, :[0 for v in rest v2]], c, T, 1, rest v2, T) + + plus := getFunctionFromDomain("+", target, [target, target]) + sum := domainZero target + for summand in summands repeat + sum := SPADCALL([summand], sum, plus) + sum + +Expr2Dmp1(summands, vec, c, source, index, varList, T) == + if null varList then + if not (source = T) then + not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() + c := objValUnwrap c + summands := [[vec, :c], :summands] + else + univ := coerceInt(objNewWrap(c, source), + ['UnivariatePolynomial, first varList, T]) + univ := objValUnwrap univ + + for [e,:c] in univ repeat + vec := COPY_-SEQ vec + vec.index := e + summands := Expr2Dmp1(summands, vec, c, T, index+1, rest varList, T) + summands + +Expr2Mp(u,source is [Expr,S], target is [.,v2,T]) == + u = '_$fromCoerceable_$ => canCoerce(source, T) + + dmp := ['DistributedMultivariatePolynomial,v2,T] + d := Expr2Dmp(u,source, dmp) + not (m := coerceInt(objNewWrap(d, dmp), target)) => coercionFailure() + objValUnwrap m + +Expr2Up(u,source is [Expr,S], target is [.,var,T]) == + u = '_$fromCoerceable_$ => canCoerce(source, T) + kernelFunc := getFunctionFromDomain("kernels", source, [source]) + kernelDom := ['Kernel, source] + nameFunc := getFunctionFromDomain("name", kernelDom, [kernelDom]) + kernels := SPADCALL(u,kernelFunc) + v1 := [SPADCALL(kernel, nameFunc) for kernel in kernels] + + not member(var, v1) => coercionFailure() + + -- variable is a kernel + + varKernel := kernels.(POSN1(var, v1)) + univFunc := getFunctionFromDomain("univariate", source, [source, kernelDom]) + sup := ['SparseUnivariatePolynomial, source] + + fracUniv := SPADCALL(u, varKernel, univFunc) + denom := CDR fracUniv + + not equalOne(denom, sup) => coercionFailure() + + numer := CAR fracUniv + uniType := ['UnivariatePolynomial, var, source] + (z := coerceInt(objNewWrap(numer, uniType), target)) => objValUnwrap z + coercionFailure() + +--% Kernels over Expr + +Ker2Ker(u,source is [.,S], target is [.,T]) == + u = '_$fromCoerceable_$ => canCoerce(S, T) + not (m := coerceInt(objNewWrap(u, source), S)) => coercionFailure() + u' := objValUnwrap m + not (m' := coerceInt(objNewWrap(u', S), T)) => coercionFailure() + u'' := objValUnwrap m' + not (m'' := coerceInt(objNewWrap(u'', T), target)) => coercionFailure() + objValUnwrap m'' + +Ker2Expr(u,source is [.,S], target) == + u = '_$fromCoerceable_$ => canCoerce(S, target) + not (m := coerceByFunction(objNewWrap(u, source), S)) => coercionFailure() + u':= objValUnwrap m + not (m' := coerceInt(objNewWrap(u', S), target)) => coercionFailure() + objValUnwrap m' + + +--% Factored objects + +Factored2Factored(u,oldmode,newmode) == + [.,oldargmode,:.]:= oldmode + [.,newargmode,:.]:= newmode + u = '_$fromCoerceable_$ => canCoerce(oldargmode,newargmode) + u' := unwrap u + unit' := coerceInt(objNewWrap(first u',oldargmode),newargmode) + null unit' => coercionFailure() + factors := KDR u' + factors' := [(coerceFFE(x,oldargmode,newargmode)) for x in factors] + member('failed,factors') => coercionFailure() + [objValUnwrap(unit'),:factors'] + +coerceFFE(ffe, oldmode, newmode) == + fac' := coerceInt(objNewWrap(ffe.1,oldmode),newmode) + null fac' => 'failed + LIST2VEC [ffe.0,objValUnwrap(fac'),ffe.2] + +--% Complex + +Complex2underDomain(u,[.,S],target) == + u = '_$fromCoerceable_$ => nil + [r,:i] := u + i=domainZero(S) => + [r',.,.]:= coerceInt(objNewWrap(r,S),target) or + coercionFailure() + r' + coercionFailure() + +Complex2FR(u,S is [.,R],target is [.,T]) == + u = '_$fromCoerceable_$ => + S ^= T => nil + R = $Integer => true + nil + S ^= T => coercionFailure() + package := + R = $Integer => ['GaussianFactorizationPackage] + coercionFailure() + factor := getFunctionFromDomain('factor,package,[S]) + SPADCALL(u,factor) + +Complex2Expr(u, source is [.,S], target is [., T]) == + u = '_$fromCoerceable_$ => + T is ['Complex, T1] and canCoerceFrom(S, T1) or coercionFailure() + E := defaultTargetFE source + negOne := coerceInt(objNewWrap(-1, $Integer), E) + null negOne => coercionFailure() + sqrtFun := getFunctionFromDomain('sqrt, E, [E]) + i := SPADCALL(objValUnwrap negOne, sqrtFun) + realFun := getFunctionFromDomain('real, source, [source]) + imagFun := getFunctionFromDomain('imag, source, [source]) + real := SPADCALL(u, realFun) + imag := SPADCALL(u, imagFun) + realExp := coerceInt(objNewWrap(real, S), E) + null realExp => coercionFailure() + imagExp := coerceInt(objNewWrap(imag, S), E) + null imagExp => coercionFailure() + timesFun := getFunctionFromDomain('_*, E, [E, E]) + plusFun := getFunctionFromDomain('_+, E, [E, E]) + newVal := SPADCALL(objValUnwrap(realExp), + SPADCALL(i, objValUnwrap imagExp, timesFun), plusFun) + newObj := objNewWrap(newVal, E) + finalObj := coerceInt(newObj, target) + finalObj => objValUnwrap finalObj + coercionFailure() + +--% Integer + +I2EI(n,source,target) == + n = '_$fromCoerceable_$ => nil + if not ODDP(n) then n else coercionFailure() + +I2OI(n,source,target) == + n = '_$fromCoerceable_$ => nil + if ODDP(n) then n else coercionFailure() + +I2PI(n,source,target) == + n = '_$fromCoerceable_$ => nil + if n > 0 then n else coercionFailure() + +I2NNI(n,source,target) == + n = '_$fromCoerceable_$ => nil + if n >= 0 then n else coercionFailure() + +--% List + +L2Tuple(val, source is [.,S], target is [.,T]) == + val = '_$fromCoerceable_$ => canCoerce(S,T) + null (object := coerceInt1(objNewWrap(val,source), ['List, T])) => + coercionFailure() + asTupleNew0 objValUnwrap object + +L2DP(l, source is [.,S], target is [.,n,T]) == + -- need to know size of the list + l = '_$fromCoerceable_$ => nil + n ^= SIZE l => coercionFailure() + (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),['Vector,T])) or + coercionFailure() + V2DP(objValUnwrap v, ['Vector, T], target) + +V2DP(v, source is [.,S], target is [.,n,T]) == + -- need to know size of the vector + v = '_$fromCoerceable_$ => nil + n ^= SIZE v => coercionFailure() + (v1 := coerceInt(objNewWrap(v,source),['Vector,T])) or + coercionFailure() + dpFun := getFunctionFromDomain('directProduct, target, [['Vector,T]]) + SPADCALL(objValUnwrap v1, dpFun) + +L2V(l, source is [.,S], target is [.,T]) == + l = '_$fromCoerceable_$ => canCoerce(S,T) + (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),target)) or + coercionFailure() + objValUnwrap(v) + +V2L(v, source is [.,S], target is [.,T]) == + v = '_$fromCoerceable_$ => canCoerce(S,T) + (l := coerceInt(objNewWrap(VEC2LIST v,['List,S]),target)) or + coercionFailure() + objValUnwrap(l) + +L2M(u,[.,D],[.,R]) == + u = '_$fromCoerceable_$ => nil + D is ['List,E] and isRectangularList(u,#u,# first u) => + u' := nil + for x in u repeat + x' := nil + for y in x repeat + (y' := coerceInt(objNewWrap(y,E),R)) or coercionFailure() + x' := [objValUnwrap(y'),:x'] + u' := [LIST2VEC reverse x',:u'] + LIST2VEC reverse u' + coercionFailure() + +L2Record(l,[.,D],[.,:al]) == + l = '_$fromCoerceable_$ => nil + #l = #al => + v:= [u for x in l for [":",.,D'] in al] where u() == + T:= coerceInt(objNewWrap(x,D),D') or return 'failed + objValUnwrap(T) + v = 'failed => coercionFailure() + #v = 2 => [v.0,:v.1] + LIST2VEC v + coercionFailure() + +L2Rm(u,source is [.,D],target is [.,n,m,R]) == + u = '_$fromCoerceable_$ => nil + D is ['List,E] and isRectangularList(u,n,m) => + L2M(u,source,['Matrix,R]) + coercionFailure() + +L2Sm(u,source is [.,D],[.,n,R]) == + u = '_$fromCoerceable_$ => nil + D is ['List,E] and isRectangularList(u,n,n) => + L2M(u,source,['Matrix,R]) + coercionFailure() + +L2Set(x,source is [.,S],target is [.,T]) == + x = '_$fromCoerceable_$ => canCoerce(S,T) + -- call library function brace to get a set + target' := ['Set,S] + u := objNewWrap( + SPADCALL(x,getFunctionFromDomain('brace,target',[source])), + target') + (u := coerceInt(u,target)) or coercionFailure() + objValUnwrap u + +Set2L(x,source is [.,S],target is [.,T]) == + x = '_$fromCoerceable_$ => canCoerce(S,T) + -- call library function destruct to get a list + u := objNewWrap( + SPADCALL(x,getFunctionFromDomain('destruct,source,[source])), + ['List,S]) + (u := coerceInt(u,target)) or coercionFailure() + objValUnwrap u + +Agg2Agg(x,source is [agg1,S],target is [.,T]) == + x = '_$fromCoerceable_$ => canCoerce(S,T) + S = T => coercionFailure() -- library function + target' := [agg1,T] + (u := coerceInt(objNewWrap(x,source),target')) or coercionFailure() + (u := coerceInt(u,target)) or coercionFailure() + objValUnwrap u + +Agg2L2Agg(x,source is [.,S],target) == + -- tries to use list as an intermediate type + mid := ['List,S] + x = '_$fromCoerceable_$ => + canCoerce(source,mid) and canCoerce(mid,target) + (u := coerceInt(objNewWrap(x,source),mid)) or coercionFailure() + (u := coerceInt(u,target)) or coercionFailure() + objValUnwrap u + +isRectangularList(x,p,q) == + p=0 or p=#x => + n:= #first x + and/[n=#y for y in rest x] => p=0 or q=n + +--% Matrix + +M2L(x,[.,S],target) == + mid := ['Vector,['Vector,S]] + x = '_$fromCoerceable_$ => canCoerce(mid,target) + (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() + objValUnwrap u + +M2M(x,[.,R],[.,S]) == + x = '_$fromCoerceable_$ => canCoerce(R,S) + n := # x + m := # x.0 + v := nil + for i in 0..(n-1) repeat + u := nil + for j in 0..(m-1) repeat + y := x.i.j + (y' := coerceInt(objNewWrap(y,R),S)) or coercionFailure() + u := [objValUnwrap y',:u] + v := [LIST2VEC reverse u,:v] + LIST2VEC reverse v + +M2Rm(x,source is [.,R],[.,p,q,S]) == + x = '_$fromCoerceable_$ => nil + n:= #x + m:= #x.0 + n=p and m=q => M2M(x,source,[nil,S]) + coercionFailure() + +M2Sm(x,source is [.,R],[.,p,S]) == + x = '_$fromCoerceable_$ => nil + n:= #x + m:= #x.(0) + n=m and m=p => M2M(x,source,[nil,S]) + coercionFailure() + +M2V(x,[.,S],target) == + mid := ['Vector,['Vector,S]] + x = '_$fromCoerceable_$ => canCoerce(mid,target) + (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() + objValUnwrap u + +--% Multivariate Polynomial + +Mp2Dmp(u, source is [., x, S], target is [dmp, y, T]) == + -- Change the representation to a DMP with the same variables and + -- coerce. + target' := [dmp,x,S] + u = '_$fromCoerceable_$ => canCoerce(target',target) + + -- check if we have a constant + u is [ =0,:c] => + null (u' := coerceInt(objNewWrap(c,S),target)) => + coercionFailure() + objValUnwrap(u') + + plus := getFunctionFromDomain('_+,target',[target',target']) + mult := getFunctionFromDomain('_*,target',[target',target']) + one := domainOne(S) + zero := domainZero(S) + (u' := coerceInt(objNewWrap(Mp2SimilarDmp(u,S,#x,plus,mult,one,zero), + target'),target)) or coercionFailure() + objValUnwrap(u') + +Mp2SimilarDmp(u,S,n,plus,mult,one,zero) == + u is [ =0,:c] => + c = zero => NIL -- zero for dmp + [[LIST2VEC LZeros n,:c]] + u is [ =1,x,:terms] => + u' := NIL -- zero for dmp + for [e,:c] in terms repeat + e' := LIST2VEC LZeros n + e'.(x-1) := e + t := [[e',:one]] + t := SPADCALL(t,Mp2SimilarDmp(c,S,n,plus,mult,one,zero),mult) + u' := SPADCALL(u',t,plus) + u' + +Mp2Expr(u,source is [mp,vars,S], target is [Expr,T]) == + u = '_$fromCoerceable_$ => canCoerce(S, target) + + dmp := ['DistributedMultivariatePolynomial, vars, S] + not (d := coerceInt(objNewWrap(u, source), dmp)) => coercionFailure() + Dmp2Expr(objValUnwrap d, dmp, target) + +Mp2FR(u,S is [.,vl,R],[.,T]) == + u = '_$fromCoerceable_$ => + S ^= T => nil + R in '((Integer) (Fraction (Integer))) => true + nil + S ^= T => coercionFailure() + package := + R = $Integer => + ovl := ['OrderedVariableList, vl] + ['MultivariateFactorize,ovl, ['IndexedExponents, ovl],R,S] + R is ['Fraction, D] => + ovl := ['OrderedVariableList, vl] + package := ['MRationalFactorize,['IndexedExponents, ovl], ovl, D, S] + coercionFailure() + factor := getFunctionFromDomain('factor,package,[S]) + SPADCALL(u,factor) + +Mp2Mp(u,source is [mp,x,S], target is [.,y,T]) == + -- need not deal with case of x = y (coerceByMapping) + common := intersection(y,x) + x' := SETDIFFERENCE(x,common) + y' := SETDIFFERENCE(y,common) + + u = '_$fromCoerceable_$ => + x = y => canCoerce(S,T) + null common => canCoerce(source,T) + null x' => canCoerce(S,target) + null y' => canCoerce([mp,x',S],T) + canCoerce([mp,x',S],[mp,y',T]) + + -- first check for constant case + u is [ =0,:c] => + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + + plus := getFunctionFromDomain('_+,target,[target,target]) + + -- now no-common-variables case + + null common => + times := getFunctionFromDomain('_*,target,[target,target]) + expn := getFunctionFromDomain('_*_*,target, + [target,$NonNegativeInteger]) + Mp2MpAux0(u,S,target,x,plus,times,expn) + + -- if source vars are all in target + null x' => + monom := getFunctionFromDomain('monomial,target, + [target,['OrderedVariableList,y],$NonNegativeInteger]) + Mp2MpAux1(u,S,target,x,y,plus,monom) + + -- if target vars are all in source + null y' => -- change source to MP[common] MP[x'] S + univariate := getFunctionFromDomain('univariate, + source,[source,['OrderedVariableList,x]]) + u' := Mp2MpAux2(u,x,common,x',common,x',univariate,S,NIL) + (u' := coerceInt(objNewWrap(u', [mp,common,[mp,x',S]]),target)) or + coercionFailure() + objValUnwrap(u') + + -- we have a mixture + (u' := coerceInt(objNewWrap(u,source),[mp,common,[mp,x',S]])) or + coercionFailure() + (u' := coerceInt(u',target)) or coercionFailure() + objValUnwrap(u') + +Mp2MpAux0(u,S,target,vars,plus,times,expn) == + -- for case when no common variables + u is [ =0,:c] => + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + [.,var,:terms] := u + [mp,.,T] := target + x := coerceInt(objNewWrap(vars.(var-1),['Variable,vars.(var-1)]), + [mp,vars,$Integer]) or coercionFailure() + (x := coerceInt(x,T)) or coercionFailure() + x := [0,:objValUnwrap x] + sum := domainZero(target) + for [e,:c] in terms repeat + prod := SPADCALL(SPADCALL(x,e,expn), + Mp2MpAux0(c,S,target,vars,plus,times,expn),times) + sum := SPADCALL(sum,prod,plus) + sum + +Mp2MpAux1(u,S,target,varl1,varl2,plus,monom) == + -- for case when source vars are all in target + u is [ =0,:c] => + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + [.,var,:terms] := u + sum := domainZero(target) + for [e,:c] in terms repeat + mon := SPADCALL( Mp2MpAux1(c,S,target,varl1,varl2,plus,monom), + position1(varl1.(var-1), varl2),e,monom) + sum := SPADCALL(sum,mon,plus) + sum + +Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) == + -- target vars are all in source + mp2 := ['MultivariatePolynomial,oldcomm,['MultivariatePolynomial, + oldrest,S]] + common => + u is [ =0,:c] => + (u' := coerceInt(objNewWrap(c,S),mp2)) or coercionFailure() + objValUnwrap(u') + [var,:common] := common + u' := SPADCALL(u,position1(var,x),univariate) + null(rest(u')) and (first(first(u')) = 0) => + Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) + [1,position1(var,oldcomm),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, + common,restvars,univariate,S,isUnder)] for [e,:c] in u']] + null isUnder => + [0,:Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,true)] + -- just treat like elt of [mp,x',S] + u is [ =0,:c] => u + [var,:restvars] := restvars + u' := SPADCALL(u,position1(var,x),univariate) + null(rest(u')) and (first(first(u')) = 0) => + Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) + [1,position1(var,oldrest),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, + common,restvars,univariate,S,isUnder)] for [e,:c] in u']] + +genMpFromDmpTerm(u, oldlen) == + + -- given one term of a DMP representation of a polynomial, this creates + -- the corresponding MP term. + + patlen := oldlen + [e,:c] := u + numexps := # e + patlen >= numexps => [0, :c] + for i in patlen..(numexps - 1) repeat + e.i = 0 => patlen := patlen + 1 + return nil + patlen >= numexps => [0, :c] + [1, 1+patlen, [e.patlen,:genMpFromDmpTerm(u,patlen+1)]] + +Mp2P(u, source is [mp,vl, S], target is [p,R]) == + u = '_$fromCoerceable_$ => canCoerce(S,target) + S is ['Polynomial,.] => MpP2P(u,vl,S,R) + vl' := REVERSE MSORT vl + -- if Mp2Mp fails, a THROW will occur + u' := Mp2Mp(u,source,[mp,vl',S]) + u' := translateMpVars2PVars (u',vl') + (u' := coerceInt(objNewWrap(u',[p,S]),target)) or coercionFailure() + objValUnwrap(u') + +MpP2P(u,vl,PS,R) == + -- u has type MP(vl,PS). Want to coerce to P R. + PR := ['Polynomial,R] + u is [ =0,:c] => + (u' :=coerceInt(objNewWrap(c,PS),PR)) or + coercionFailure() + objValUnwrap u' + [ .,pos,:ec] := u + multivariate := getFunctionFromDomain('multivariate, + PR,[['SparseUnivariatePolynomial,PR],$Symbol]) + sup := [[e,:MpP2P(c,vl,PS,R)] for [e,:c] in ec] + p := SPADCALL(sup,vl.(pos-1),multivariate) + --(p' :=coerceInt(objNewWrap(p,PS),['Polynomial,R])) or coercionFailure() + --objValUnwrap(p') + +Mp2Up(u,source is [mp,vl,S],target is [up,x,T]) == + u = '_$fromCoerceable_$ => + member(x,vl) => + vl = [x] => canCoerce(S,T) + canCoerce([mp,delete(x,vl),S],T) + canCoerce(source,T) + + u is [ =0,:c] => -- constant polynomial? + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap u' + + null member(x,vl) => + (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() + [[0,:objValUnwrap(u')]] + + vl = [x] => + u' := [[e,:c] for [e,.,:c] in CDDR u] + (u' := coerceInt(objNewWrap(u',[up,x,S]),target)) + or coercionFailure() + objValUnwrap u' + + -- do a univariate to transform u to a UP(x,P S) and then coerce again + var := position1(x,vl) + UPP := ['UnivariatePolynomial,x,source] + univariate := getFunctionFromDomain('univariate, + source,[source,['OrderedVariableList,vl]]) + upU := SPADCALL(u,var,univariate) -- we may assume this has type UPP + (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() + objValUnwrap u' + +--% OrderedVariableList + +OV2OV(u,source is [.,svl], target is [.,tvl]) == + svl = intersection(svl,tvl) => + u = '_$fromCoerceable_$ => true + position1(svl.(u-1),tvl) + u = '_$fromCoerceable_$ => nil + coercionFailure() + +OV2P(u,source is [.,svl], target is [.,T]) == + u = '_$fromCoerceable_$ => true + v := svl.(unwrap(u)-1) + [1,v,[1,0,:domainOne(T)]] + +OV2poly(u,source is [.,svl], target is [p,vl,T]) == + u = '_$fromCoerceable_$ => + p = 'UnivariatePolynomial => (# svl = 1) and (p = svl.0) + and/[member(v,vl) for v in svl] + v := svl.(unwrap(u)-1) + val' := [1,:domainOne(T)] + p = 'UnivariatePolynomial => + v ^= vl => coercionFailure() + [[1,:domainOne(T)]] + null member(v,vl) => coercionFailure() + val' := [[1,:domainOne(T)]] + source' := ['UnivariatePolynomial,v,T] + (u' := coerceInt(objNewWrap(val',source'),target)) or + coercionFailure() + objValUnwrap(u') + +OV2SE(u,source is [.,svl], target) == + u = '_$fromCoerceable_$ => true + svl.(unwrap(u)-1) + +OV2Sy(u,source is [.,svl], target) == + u = '_$fromCoerceable_$ => true + svl.(unwrap(u)-1) + +--% Polynomial + +varsInPoly(u) == + u is [ =1, v, :termlist] => + [v,:varsInPoly(c) for [e,:c] in termlist] + nil + +P2FR(u,S is [.,R],[.,T]) == + u = '_$fromCoerceable_$ => + S ^= T => nil + R in '((Integer) (Fraction (Integer))) => true + nil + S ^= T => coercionFailure() + package := + R = $Integer => + ['MultivariateFactorize,$Symbol,['IndexedExponents, $Symbol],R,S] + R is ['Fraction, D] => + package := ['MRationalFactorize,['IndexedExponents, $Symbol],$Symbol, + D, S] + coercionFailure() + factor := getFunctionFromDomain('factor,package,[S]) + SPADCALL(u,factor) + +P2Dmp(u, source is [., S], target is [., y, T]) == + u = '_$fromCoerceable_$ => + -- might be able to say yes + canCoerce(source,T) + u is [ =0,:c] => -- polynomial is a constant + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + univariate := getFunctionFromDomain('univariate, + source,[source,$Symbol]) + plus := getFunctionFromDomain("+",target,[target,target]) + monom := getFunctionFromDomain('monomial,target, + [target,['OrderedVariableList,y],$NonNegativeInteger]) + P2DmpAux(u,source,S,target,copy y,y,T,univariate,plus,monom) + +P2Expr(u, source is [.,S], target is [., T]) == + u = '_$fromCoerceable_$ => + canCoerce(S, T) + S = T => coercionFailure() + newS := ['Polynomial, T] + val := coerceInt(objNewWrap(u, source), newS) + null val => coercionFailure() + val := coerceInt(val, target) + null val => coercionFailure() + objValUnwrap val + +P2DmpAux(u,source,S,target,varlist,vars,T,univariate,plus,monom) == + u is [ =0,:c] => -- polynomial is a constant + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + + -- if no variables left, try to go to underdomain of target (T) + null vars => + (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() + -- if successful, embed + (u' := coerceByFunction(u',target)) or coercionFailure() + objValUnwrap(u') + + -- there are variables, so get them out of u + [x,:vars] := vars + sup := SPADCALL(u,x,univariate) -- this is a SUP P S + null sup => -- zero? unlikely. + domainZero(target) + -- degree 0 polynomial? (variable did not occur) + null(rest(sup)) and first(sup) is [ =0,:c] => + -- call again, but with one less var + P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom) + var := position1(x,varlist) + u' := domainZero(target) + for [e,:c] in sup repeat + u'' := SPADCALL( + P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom), + var,e,monom) + u' := SPADCALL(u',u'',plus) + u' + +P2Mp(u, source is [., S], target is [., y, T]) == + u = '_$fromCoerceable_$ => + -- might be able to say yes + canCoerce(source,T) + univariate := getFunctionFromDomain('univariate, + source,[source,$Symbol]) + P2MpAux(u,source,S,target,copy y,y,T,univariate) + +P2MpAux(u,source,S,target,varlist,vars,T,univariate) == + u is [ =0,:c] => -- polynomial is a constant + (u' := coerceInt(objNewWrap(c,S),target)) or + coercionFailure() + objValUnwrap(u') + + -- if no variables left, try to go to underdomain of target (T) + null vars => + (u' := coerceInt(objNewWrap(u,source),T)) or + coercionFailure() + -- if successful, embed + [ 0,:objValUnwrap(u')] + + -- there are variables, so get them out of u + [x,:vars] := vars + sup := SPADCALL(u,x,univariate) -- this is a SUP P S + null sup => -- zero? unlikely. + domainZero(target) + -- degree 0 polynomial? (variable did not occur) + null(rest(sup)) and first(sup) is [ =0,:c] => + -- call again, but with one less var + P2MpAux(c,source,S,target,varlist,vars,T,univariate) + terms := [[e,:P2MpAux(c,source,S,target,varlist,vars,T,univariate)] for + [e,:c] in sup] + [1, position1(x,varlist), :terms] + +varIsOnlyVarInPoly(u, var) == + u is [ =1, v, :termlist] => + v ^= var => nil + and/[varIsOnlyVarInPoly(c,var) for [e,:c] in termlist] + true + +P2Up(u,source is [.,S],target is [.,x,T]) == + u = '_$fromCoerceable_$ => canCoerce(source,T) + u is [ =0,:c] => + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + + -- see if the target var is the polynomial vars + varsFun := getFunctionFromDomain('variables,source,[source]) + vars := SPADCALL(u,varsFun) + not member(x,vars) => + (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() + [[0,:objValUnwrap(u')]] + + -- do a univariate to transform u to a UP(x,P S) and then coerce again + UPP := ['UnivariatePolynomial,x,source] + univariate := getFunctionFromDomain('univariate, + source,[source,$Symbol]) + upU := SPADCALL(u,x,univariate) -- we may assume this has type UPP + (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() + objValUnwrap(u') + +--% Fraction + +Qf2PF(u,source is [.,D],target) == + u = '_$fromCoerceable_$ => canCoerce(D,target) + [num,:den] := u + num':= coerceInt(objNewWrap(num,D),target) or + coercionFailure() + num' := objValUnwrap num' + den':= coerceInt(objNewWrap(den,D),target) or + coercionFailure() + den' := objValUnwrap den' + equalZero(den', target) => throwKeyedMsg("S2IA0001",NIL) + SPADCALL(num',den', getFunctionFromDomain("/",target,[target,target])) + +Qf2F(u,source is [.,D,:.],target) == + D = $Integer => + u = '_$fromCoerceable_$ => true + Rn2F(u,source,target) + u = '_$fromCoerceable_$ => canCoerce(D,target) + [num,:den] := u + [.,:num']:= coerceInt(objNewWrap(num,D),target) or + coercionFailure() + [.,:den']:= coerceInt(objNewWrap(den,D),target) or + coercionFailure() + (unwrap num') * 1.0 / (unwrap den') + +Rn2F(rnum, source, target) == + float(CAR(rnum)/CDR(rnum)) + +-- next function is needed in RN algebra code +--Rn2F([a,:b],source,target) == +-- al:=if LINTP a then QLENGTHCODE a else 4 +-- bl:=if LINTP b then QLENGTHCODE b else 4 +-- MAX(al,bl) < 36 => FLOAT a / FLOAT b +-- sl:=0 +-- if al>32 then +-- sl:=35*(al-32)/4 +-- a:=a/2**sl +-- if bl>32 then +-- sbl:=35*(bl-32)/4 +-- b:=b/2**sbl +-- sl:=sl-sbl +-- ans:=FLOAT a /FLOAT b +-- sl=0 => ans +-- ans*2**sl + +Qf2domain(u,source is [.,D],target) == + -- tests whether it is an element of the underlying domain + useUnder := (ut := underDomainOf target) and canCoerce(source,ut) + u = '_$fromCoerceable_$ => useUnder + not (containsPolynomial(D) and containsPolynomial(target)) and + useUnder => coercionFailure() -- let other mechanism handle it + [num, :den] := u + (num' := coerceInt(objNewWrap(num,D),target)) or coercionFailure() + num' := objValUnwrap(num') + equalOne(den,D) => num' + (target is [.,[=$QuotientField,T]]) or + (target is [.,.,[=$QuotientField,T]]) => + (den' := coerceInt(objNewWrap(den,D),T)) or coercionFailure() + den' := [domainOne(T),:objValUnwrap(den')] + timesfunc:= getFunctionFromDomain('_*,target, + [[$QuotientField,T],target]) + SPADCALL(den',num',timesfunc) + coercionFailure() + +Qf2EF(u,[.,S],target) == + u = '_$fromCoerceable_$ => canCoerce(S,target) + [num,:den] := u + (num' := coerceInt(objNewWrap(num,S),target)) or + coercionFailure() + (den' := coerceInt(objNewWrap(den,S),target)) or + coercionFailure() + divfun := getFunctionFromDomain("/",target,[target,target]) + SPADCALL(objValUnwrap(num'),objValUnwrap(den'),divfun) + +Qf2Qf(u0,[.,S],target is [.,T]) == + u0 = '_$fromCoerceable_$ => + S = ['Polynomial, [$QuotientField, $Integer]] and + T = '(Polynomial (Integer)) => true + canCoerce(S,T) + [a,:b] := u0 + S = ['Polynomial, [$QuotientField, $Integer]] and + T = '(Polynomial (Integer)) => + (a' := coerceInt(objNewWrap(a,S),target)) => + (b' := coerceInt(objNewWrap(b,S),target)) => + divfunc:= getFunctionFromDomain('_/,target,[target,target]) + SPADCALL(objValUnwrap(a'),objValUnwrap(b'),divfunc) + coercionFailure() + coercionFailure() + (a' := coerceInt(objNewWrap(a,S),T)) => + (b' := coerceInt(objNewWrap(b,S),T)) => + [objValUnwrap(a'),:objValUnwrap(b')] + coercionFailure() + coercionFailure() + +-- partOf(x,i) == +-- VECP x => x.i +-- i=0 => first x +-- i=1 => rest x +-- systemError '"partOf" + +--% RectangularMatrix + +Rm2L(x,[.,.,.,R],target) == M2L(x,['Matrix,R],target) + +Rm2M(x,[.,.,.,R],target is [.,S]) == M2M(x,[nil,R],target) + +Rm2Sm(x,[.,n,m,S],[.,p,R]) == + x = '_$fromCoerceable_$ => n=m and m=p and canCoerce(S,R) + n=m and m=p => + M2M(x,[nil,S],[nil,R]) + coercionFailure() + +Rm2V(x,[.,.,.,R],target) == M2V(x,['Matrix,R],target) + +--% Script + +Scr2Scr(u, source is [.,S], target is [.,T]) == + u = '_$fromCoerceable_$ => canCoerce(S,T) + null (v := coerceInt(objNewWrap(CDR u,S),T)) => + coercionFailure() + [CAR u, :objValUnwrap(v)] + +--% SparseUnivariatePolynomialnimial + +SUP2Up(u,source is [.,S],target is [.,x,T]) == + u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) + null u => u + S = T => u + -- try to go underneath first + null (u' := coerceInt(objNewWrap(u,source),T)) => + -- must be careful in case any of the coeffs come back 0 + u' := NIL + zero := getConstantFromDomain('(Zero),T) + for [e,:c] in u repeat + c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or + coercionFailure()) + c' = zero => 'iterate + u' := [[e,:c'],:u'] + nreverse u' + [[0,:objValUnwrap u']] + +--% SquareMatrix + +Sm2L(x,[.,.,R],target) == M2L(x,['Matrix,R],target) + +Sm2M(x,[.,n,R],target is [.,S]) == M2M(x,[nil,R],target) + +Sm2PolyType(u,source is [sm,n,S], target is [pol,vl,T]) == + -- only really handles cases like: + -- SM[2] P I -> P[x,y] SM[2] P I + -- works for UP, MP, DMP and NDMP + u = '_$fromCoerceable_$ => canCoerce(source,T) + -- first want to check case S is Polynomial + S is ['Polynomial,S'] => + -- check to see if variable occurs in any of the terms + if ATOM vl + then vl' := [vl] + else vl' := vl + novars := true + for i in 0..(n-1) while novars repeat + for j in 0..(n-1) while novars repeat + varsUsed := varsInPoly u.i.j + or/[member(x,varsUsed) for x in vl'] => novars := nil + novars => coercionFailure() + source' := [sm,n,[pol,vl,S]] + null (u' := coerceInt(objNewWrap(u,source),source')) => + coercionFailure() + null (u' := coerceInt(u',target)) => + coercionFailure() + objValUnwrap(u') + -- let other cases be handled by standard machinery + coercionFailure() + +Sm2Rm(x,[.,n,R],[.,p,q,S]) == + x = '_$fromCoerceable_$ => p=q and p=n and canCoerce(R,S) + p=q and p=n => + M2M(x,[nil,R],[nil,S]) + coercionFailure() + +Sm2V(x,[.,.,R],target) == M2V(x,['Matrix,R],target) + +--% Symbol + +Sy2OV(u,source,target is [.,vl]) == + u = '_$fromCoerceable_$ => nil + position1(u,vl) + +Sy2Dmp(u,source,target is [dmp,vl,S]) == + u = '_$fromCoerceable_$ => canCoerce(source,S) + len:= #vl + -1^=(n:= position(u,vl)) => + u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] + objValUnwrap(coerceInt(objNew(u,[dmp,vl,$Integer]),target)) + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[Zeros len,:objValUnwrap u]] + +Sy2Mp(u,source,target is [mp,vl,S]) == + u = '_$fromCoerceable_$ => canCoerce(source,S) + (n:= position1(u,vl)) ^= 0 => + [1,n,[1,0,:domainOne(S)]] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [0,:objValUnwrap(u)] + +Sy2NDmp(u,source,target is [ndmp,vl,S]) == + u = '_$fromCoerceable_$ => canCoerce(source,S) + len:= #vl + -1^=(n:= position(u,vl)) => + u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] + objValUnwrap(coerceInt(objNew(u,[ndmp,vl,$Integer]),target)) + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[Zeros len,:objValUnwrap(u)]] + +Sy2P(u,source,target is [poly,S]) == + u = '_$fromCoerceable_$ => true + -- first try to get it into an underdomain + if (S ^= $Integer) then + u' := coerceInt(objNewWrap(u,source),S) + if u' then return [0,:objValUnwrap(u')] + -- if that failed, return it as a polynomial variable + [1,u,[1,0,:domainOne(S)]] + +Sy2Up(u,source,target is [up,x,S]) == + u = '_$fromCoerceable_$ => canCoerce(source,S) + u=x => [[1,:domainOne(S)]] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[0,:objValUnwrap u]] + +Sy2Var(u,source,target is [.,x]) == + u = '_$fromCoerceable_$ => NIL + u=x => u + coercionFailure() + +--% Univariate Polynomial + +Up2Dmp(u,source is ['UnivariatePolynomial,var,S], + target is ['DistributedMultivariatePolynomial,vl,T]) == + -- var must be a member of vl, or u is a constant + u = '_$fromCoerceable_$ => member(var,vl) and canCoerce(S,target) + null u => domainZero(target) + u is [[e,:c]] and e=0 => + z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) + coercionFailure() + member(var,vl) => + x:= domainZero(target) + one:= domainOne(T) + plusfunc:= getFunctionFromDomain('_+,target,[target,target]) + multfunc:= getFunctionFromDomain('_*,target,[target,target]) + n:= #vl ; p:= POSN1(var,vl) + l1:= not (p=0) and [0 for m in 1..p] + l2:= not (p=n-1) and [0 for m in p..n-2] + for [e,:c] in u until not z repeat + z:= coerceInt(objNewWrap(c,S),target) => + y:= SPADCALL(objValUnwrap(z), + [[LIST2VEC [:l1,e,:l2],:one]],multfunc) + x:= SPADCALL(x,y,plusfunc) + z => x + coercionFailure() + coercionFailure() + +Up2Expr(u,source is [up,var,S], target is [Expr,T]) == + u = '_$fromCoerceable_$ => canCoerce(S, target) + + null u => domainZero(target) + + u is [[e,:c]] and e=0 => + (z := coerceInt(objNewWrap(c, S), target)) => objValUnwrap(z) + coercionFailure() + + sym := objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) + + plus := getFunctionFromDomain("+", target, [target, target]) + mult := getFunctionFromDomain("*", target, [target, target]) + expn := getFunctionFromDomain("**", target, [target, $Integer]) + + -- coerce via Horner's rule + + [e1, :c1] := first u + if not (S = target) then + not (c1 := coerceInt(objNewWrap(c1, S), target)) => coercionFailure() + c1 := objValUnwrap(c1) + + for [e2, :c2] in rest u repeat + coef := + e1 - e2 = 1 => sym + SPADCALL(sym, e1-e2, expn) + if not (S = target) then + not (c2 := coerceInt(objNewWrap(c2, S), target)) => + coercionFailure() + c2 := objValUnwrap(c2) + coef := SPADCALL(SPADCALL(c1, coef, mult), c2, plus) + e1 := e2 + c1 := coef + + e1 = 0 => c1 + e1 = 1 => SPADCALL(sym, c1, mult) + SPADCALL(SPADCALL(sym, e1, expn), c1, mult) + +Up2FR(u,S is [.,x,R],target is [.,T]) == + u = '_$fromCoerceable_$ => + S ^= T => nil + R in '((Integer) (Fraction (Integer))) => true + nil + S ^= T => coercionFailure() + package := + R = $Integer => ['UnivariateFactorize,S] + R = $RationalNumber => package := ['RationalFactorize,S] + coercionFailure() + factor := getFunctionFromDomain('factor,package,[S]) + SPADCALL(u,factor) + +Up2Mp(u,source is [.,x,S], target is [.,vl,T]) == + u = '_$fromCoerceable_$ => + member(x,vl) => canCoerce(S,T) + canCoerce(source,T) + + null u => domainZero(target) + + null(rest(u)) and (first(u) is [e,:c]) and e=0 => + x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) + coercionFailure() + + null member(x,vl) => + (x := coerceInt(objNewWrap(u,source),T)) or coercionFailure() + [0,:objValUnwrap(x)] + + plus := getFunctionFromDomain('_+,target,[target,target]) + monom := getFunctionFromDomain('monomial,target, + [target,['OrderedVariableList,vl],$NonNegativeInteger]) + sum := domainZero(target) + pos := position1(x,vl) + + for [e,:c] in u repeat + (p := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + mon := SPADCALL(objValUnwrap(p),pos,e,monom) + sum := SPADCALL(sum,mon,plus) + sum + +Up2P(u,source is [.,var,S],target is [.,T]) == + u = '_$fromCoerceable_$ => canCoerce(S,target) + null u => domainZero(target) + u is [[e,:c]] and e=0 => + x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) + coercionFailure() + pol:= domainZero(target) + one:= domainOne(T) + plusfunc := getFunctionFromDomain("+",target,[target,target]) + multfunc := getFunctionFromDomain("*",target,[target,target]) + for [e,:c] in u until not x repeat + x:= coerceInt(objNewWrap(c,S),target) => + term:= SPADCALL([1,var,[e,0,:one]],objValUnwrap(x),multfunc) + pol:= SPADCALL(pol,term,plusfunc) + coercionFailure() + x => pol + coercionFailure() + +Up2SUP(u,source is [.,x,S],target is [.,T]) == + u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) + null u => u + S = T => u + -- try to go underneath first + null (u' := coerceInt(objNewWrap(u,source),T)) => + u' := NIL + zero := getConstantFromDomain('(Zero),T) + for [e,:c] in u repeat + c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or + coercionFailure()) + c' = zero => 'iterate + u' := [[e,:c'],:u'] + nreverse u' + [[0,:objValUnwrap u']] + +Up2Up(u,source is [.,v1,S], target is [.,v2,T]) == + -- if v1 = v2 then this is handled by coerceIntByMap + -- this only handles case where poly is a constant + u = '_$fromCoerceable_$ => + v1=v2 => canCoerce(S,T) + canCoerce(source,T) + null u => u + u is [[e,:c]] and e=0 => + x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) + coercionFailure() + coercionFailure() + +insertAlist(a,b,l) == + null l => [[a,:b]] + a = l.0.0 => (RPLAC(CDAR l,b);l) + _?ORDER(l.0.0,a) => [[a,:b],:l] + (fn(a,b,l);l) where fn(a,b,l) == + null rest l => RPLAC(rest l,[[a,:b]]) + a = l.1.0 => RPLAC(rest l.1,b) + _?ORDER(l.1.0,a) => RPLAC(rest l,[[a,:b],:rest l]) + fn(a,b,rest l) + +--% Union + +Un2E(x,source,target) == + ['Union,:branches] := source + x = '_$fromCoerceable_$ => + and/[canCoerce(t, target) for t in branches | ^ STRINGP t] + coerceUn2E(x,source) + +--% Variable + +Var2OV(u,source,target is [.,vl]) == + sym := CADR source + u = '_$fromCoerceable_$ => member(sym,vl) + member(sym,vl) => position1(sym,vl) + coercionFailure() + +Var2Dmp(u,source,target is [dmp,vl,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) + + len := #vl + -1 ^= (n:= position(sym,vl)) => + LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], + :getConstantFromDomain('(One),S)] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[Zeros len,:objValUnwrap u]] + +Var2Gdmp(u,source,target is [dmp,vl,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) + + len := #vl + -1 ^= (n:= position(sym,vl)) => + LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], + :getConstantFromDomain('(One),S)] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[Zeros len,:objValUnwrap u]] + +Var2Mp(u,source,target is [mp,vl,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) + (n:= position1(u,vl)) ^= 0 => + [1,n,[1,0,:getConstantFromDomain('(One),S)]] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [0,:objValUnwrap u] + +Var2NDmp(u,source,target is [ndmp,vl,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) + + len:= #vl + -1^=(n:= position(u,vl)) => + LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], + :getConstantFromDomain('(One),S)] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[Zeros len,:objValUnwrap(u)]] + +Var2P(u,source,target is [poly,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => true + + -- first try to get it into an underdomain + if (S ^= $Integer) then + u' := coerceInt(objNewWrap(u,source),S) + if u' then return [0,:objValUnwrap(u')] + -- if that failed, return it as a polynomial variable + [1,sym,[1,0,:getConstantFromDomain('(One),S)]] + +Var2QF(u,source,target is [qf,S]) == + u = '_$fromCoerceable_$ => canCoerce(source,S) + + S = $Integer => coercionFailure() + sym := CADR source + (u' := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [objValUnwrap u',:getConstantFromDomain('(One),S)] + +Var2FS(u,source,target is [fs,S]) == + u = '_$fromCoerceable_$ => true + (v := coerceInt(objNewWrap(u,source),['Polynomial,S])) or + coercionFailure() + (v := coerceInt(v,target)) or coercionFailure() + objValUnwrap v + +Var2Up(u,source,target is [up,x,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) + + x=sym => [[1,:getConstantFromDomain('(One),S)]] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[0,:objValUnwrap u]] + +Var2SUP(u,source,target is [sup,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => (sym = "?") or canCoerce(source,S) + + sym = "?" => [[1,:getConstantFromDomain('(One),S)]] + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + [[0,:objValUnwrap u]] + +Var2UpS(u,source,target is [ups,x,S]) == + sym := CADR source + u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) + + mid := ['UnivariatePolynomial,x,S] + x = sym => + u := Var2Up(u,source,mid) + (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() + objValUnwrap u + (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() + (u := coerceInt(u,target)) or coercionFailure() + objValUnwrap u + +Var2OtherPS(u,source,target is [.,x,S]) == + sym := CADR source + mid := ['UnivariatePowerSeries,x,S] + u = '_$fromCoerceable_$ => + (sym = x) or (canCoerce(source,mid) and canCoerce(mid,target)) + u := Var2UpS(u,source,mid) + (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() + objValUnwrap u + +--% Vector + +V2M(u,[.,D],[.,R]) == + u = '_$fromCoerceable_$ => + D is ['Vector,:.] => nil -- don't have data + canCoerce(D,R) + -- first see if we are coercing a vector of vectors + D is ['Vector,E] and + isRectangularVector(u,MAXINDEX u,MAXINDEX u.0) => + LIST2VEC + [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) + for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] + -- if not, try making it into a 1 by n matrix + coercionFailure() +--LIST2VEC [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(u.i,D),R)) +-- for i in 0..MAXINDEX(u)]] + +V2Rm(u,[.,D],[.,n,m,R]) == + u = '_$fromCoerceable_$ => nil + D is [.,E,:.] and isRectangularVector(u,n-1,m-1) => + LIST2VEC + [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) + for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] + coercionFailure() + +V2Sm(u,[.,D],[.,n,R]) == + u = '_$fromCoerceable_$ => nil + D is [.,E,:.] and isRectangularVector(u,n-1,n-1) => + LIST2VEC + [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) + for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] + coercionFailure() + +isRectangularVector(x,p,q) == + MAXINDEX x = p => + and/[q=MAXINDEX x.i for i in 0..p] + +-- Polynomial and Expression to Univariate series types + +P2Uts(u, source, target) == + P2Us(u,source, target, 'taylor) + +P2Uls(u, source, target) == + P2Us(u,source, target, 'laurent) + +P2Upxs(u, source, target) == + P2Us(u,source, target, 'puiseux) + +P2Us(u, source is [.,S], target is [.,T,var,cen], type) == + u = '_$fromCoerceable_$ => + -- might be able to say yes + canCoerce(S,T) + T isnt ['Expression, :.] => coercionFailure() + if S ^= '(Float) then S := $Integer + obj := objNewWrap(u, source) + E := ['Expression, S] + newU := coerceInt(obj, E) + null newU => coercionFailure() + EQtype := ['Equation, E] + eqfun := getFunctionFromDomain('_=, EQtype, [E,E]) + varE := coerceInt(objNewWrap(var, '(Symbol)), E) + null varE => coercionFailure() + cenE := coerceInt(objNewWrap(cen, T), E) + null cenE => coercionFailure() + eq := SPADCALL(objValUnwrap(varE), objValUnwrap(cenE), eqfun) + package := ['ExpressionToUnivariatePowerSeries, S, E] + func := getFunctionFromDomain(type, package, [E, EQtype]) + newObj := SPADCALL(objValUnwrap(newU), eq, func) + newType := CAR newObj + newVal := CDR newObj + newType = target => newVal + finalObj := coerceInt(objNewWrap(newVal, newType), target) + null finalObj => coercionFailure() + objValUnwrap finalObj + + +--% General Coercion Commutation Functions + +-- general commutation functions are called with 5 values +-- u object of type source +-- source type of u +-- S underdomain of source +-- target coercion target type +-- T underdomain of T +-- Because of checking, can always assume S and T have underdomains. + +--% Complex + +commuteComplex(u,source,S,target,T) == + u = '_$fromCoerceable_$ => + canCoerce(S,target) and canCoerce(T,target) + [real,:imag] := u + (real := coerceInt(objNewWrap(real,S),target)) or coercionFailure() + (imag := coerceInt(objNewWrap(imag,S),target)) or coercionFailure() + T' := underDomainOf T + i := [domainZero(T'), + :domainOne(T')] + (i := coerceInt(objNewWrap(i,T),target)) or coercionFailure() + f := getFunctionFromDomain("*",target,[target,target]) + i := SPADCALL(objValUnwrap i, objValUnwrap imag, f) + f := getFunctionFromDomain("+",target,[target,target]) + SPADCALL(objValUnwrap real,i,f) + +--% Quaternion + +commuteQuaternion(u,source,S,target,T) == + u = '_$fromCoerceable_$ => + canCoerce(S,target) and canCoerce(T,target) + c := [objValUnwrap(coerceInt(objNewWrap(x,S),target) + or coercionFailure()) for x in VEC2LIST u] + q := '(Quaternion (Integer)) + e := [[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]] + e := [(coerceInt(objNewWrap(LIST2VEC x,q),T) + or coercionFailure()) for x in e] + e :=[objValUnwrap(coerceInt(x,target) or coercionFailure()) for x in e] + u' := domainZero(target) + mult := getFunctionFromDomain("*",target,[target,target]) + plus := getFunctionFromDomain("+",target,[target,target]) + for x in c for y in e repeat + u' := SPADCALL(u',SPADCALL(x,y,mult),plus) + u' + +--% Fraction + +commuteFraction(u,source,S,target,T) == + u = '_$fromCoerceable_$ => + ofCategory(target,'(Field)) => canCoerce(S,target) + canCoerce(S,T) and canCoerce(T,target) + [n,:d] := u + ofCategory(target,'(Field)) => + -- see if denominator can go over to target + (d' := coerceInt(objNewWrap(d,S),target)) or coercionFailure() + -- if so, try to invert it + inv := getFunctionFromDomain('inv,target,[target]) + d' := SPADCALL(objValUnwrap d',inv) + -- now coerce to target + (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() + multfunc := getFunctionFromDomain("*",target,[target,target]) + SPADCALL(d',objValUnwrap n',multfunc) + -- see if denominator can go over to QF part of target + (d' := coerceInt(objNewWrap(d,S),T)) or coercionFailure() + -- if so, try to invert it + inv := getFunctionFromDomain('inv,T,[T]) + d' := SPADCALL(objValUnwrap d',inv) + -- now coerce to target + (d' := coerceInt(objNewWrap(d',T),target)) or coercionFailure() + (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() + multfunc := getFunctionFromDomain("*",target,[target,target]) + SPADCALL(objValUnwrap d',objValUnwrap n',multfunc) + +--% SquareMatrix + +commuteSquareMatrix(u,source,S,target,T) == + u = '_$fromCoerceable_$ => + canCoerce(S,target) and canCoerce(T,target) + -- commuting matrices of matrices should be a no-op + S is ['SquareMatrix,:.] => + source=target => u + coercionFailure() + u' := domainZero(target) + plusfunc := getFunctionFromDomain("+",target,[target,target]) + multfunc := getFunctionFromDomain("*",target,[target,target]) + zero := domainZero(S) + [sm,n,:.] := source + S' := [sm,n,$Integer] + for i in 0..(n-1) repeat + for j in 0..(n-1) repeat + (e := u.i.j) = zero => 'iterate + (e' := coerceInt(objNewWrap(e,S),target)) or coercionFailure() + (Eij := coerceInt(objNewWrap(makeEijSquareMatrix(i,j,n),S'),T)) or + coercionFailure() + (Eij := coerceInt(Eij,target)) or coercionFailure() + e' := SPADCALL(objValUnwrap(e'),objValUnwrap(Eij),multfunc) + u' := SPADCALL(e',u',plusfunc) + u' + +makeEijSquareMatrix(i, j, dim) == + -- assume using 0 based scale, makes a dim by dim matrix with a + -- 1 in the i,j position, zeros elsewhere + LIST2VEC [LIST2VEC [((i=r) and (j=c) => 1; 0) + for c in 0..(dim-1)] for r in 0..(dim-1)] + +--% Univariate Polynomial and Sparse Univariate Polynomial + +commuteUnivariatePolynomial(u,source,S,target,T) == + commuteSparseUnivariatePolynomial(u,source,S,target,T) + +commuteSparseUnivariatePolynomial(u,source,S,target,T) == + u = '_$fromCoerceable_$ => + canCoerce(S,target) and canCoerce(T,target) + + u' := domainZero(target) + null u => u' + + T' := underDomainOf T + one := domainOne(T') + monom := getFunctionFromDomain('monomial,T,[T',$NonNegativeInteger]) + plus := getFunctionFromDomain("+",target,[target,target]) + times := getFunctionFromDomain("*",target,[target,target]) + + for [e,:c] in u repeat + (c := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + m := SPADCALL(one,e,monom) + (m := coerceInt(objNewWrap(m,T),target)) or coercionFailure() + c := objValUnwrap c + m := objValUnwrap m + u' := SPADCALL(u',SPADCALL(c,m,times),plus) + u' + +--% Multivariate Polynomials + +commutePolynomial(u,source,S,target,T) == + commuteMPolyCat(u,source,S,target,T) + +commuteMultivariatePolynomial(u,source,S,target,T) == + commuteMPolyCat(u,source,S,target,T) + +commuteDistributedMultivariatePolynomial(u,source,S,target,T) == + commuteMPolyCat(u,source,S,target,T) + +commuteNewDistributedMultivariatePolynomial(u,source,S,target,T) == + commuteMPolyCat(u,source,S,target,T) + +commuteMPolyCat(u,source,S,target,T) == + u = '_$fromCoerceable_$ => canCoerce(S,target) + -- check constant case + isconstfun := getFunctionFromDomain("ground?",source,[source]) + SPADCALL(u,isconstfun) => + constfun := getFunctionFromDomain("ground",source,[source]) + c := SPADCALL(u,constfun) + (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() + objValUnwrap(u') + + lmfun := getFunctionFromDomain('leadingMonomial,source,[source]) + lm := SPADCALL(u,lmfun) -- has type source, is leading monom + + lcfun := getFunctionFromDomain('leadingCoefficient,source,[source]) + lc := SPADCALL(lm,lcfun) -- has type S, is leading coef + (lc' := coerceInt(objNewWrap(lc,S),target)) or coercionFailure() + + pmfun := getFunctionFromDomain('primitiveMonomials,source,[source]) + lm := first SPADCALL(lm,pmfun) -- now we have removed the leading coef + (lm' := coerceInt(objNewWrap(lm,source),T)) or coercionFailure() + (lm' := coerceInt(lm',target)) or coercionFailure() + + rdfun := getFunctionFromDomain('reductum,source,[source]) + rd := SPADCALL(u,rdfun) -- has type source, is reductum + (rd' := coerceInt(objNewWrap(rd,source),target)) or coercionFailure() + + lc' := objValUnwrap lc' + lm' := objValUnwrap lm' + rd' := objValUnwrap rd' + + plusfun := getFunctionFromDomain("+",target,[target,target]) + multfun := getFunctionFromDomain("*",target,[target,target]) + SPADCALL(SPADCALL(lc',lm',multfun),rd',plusfun) + +------------------------------------------------------------------------ +-- Format for alist member is: domain coercionType function +-- here coercionType can be one of 'total, 'partial or 'indeterm +-- (indeterminant - cannot tell in a simple way). +-- +-- In terms of canCoerceFrom, 'total implies true, 'partial implies +-- false (just cannot tell without actual data) and 'indeterm means +-- to call the function with the data = "$fromCoerceable$" for a +-- response of true or false. +------------------------------------------------------------------------ +-- There are no entries here for RationalNumber or RationalFunction. +-- These should have been changed to QF I and QF P, respectively, by +-- a function like deconstructTower. RSS 8-1-85 +------------------------------------------------------------------------ + +SETANDFILEQ($CoerceTable, '( _ + (Complex . ( _ + (Expression indeterm Complex2Expr) _ + (Factored indeterm Complex2FR) _ + (Integer partial Complex2underDomain) _ + (PrimeField partial Complex2underDomain) _ + ))_ + (DirectProduct . ( _ + (DirectProduct partial DP2DP) _ + )) _ + (DistributedMultivariatePolynomial . ( _ + (DistributedMultivariatePolynomial indeterm Dmp2Dmp) _ + (Expression indeterm Dmp2Expr) _ + (Factored indeterm Mp2FR) _ + (HomogeneousDistributedMultivariatePolynomial indeterm Dmp2NDmp) _ + (MultivariatePolynomial indeterm Dmp2Mp) _ + (Polynomial indeterm Dmp2P) _ + (UnivariatePolynomial indeterm Dmp2Up) _ + ))_ + (Expression . ( + (Complex partial Expr2Complex) _ + (DistributedMultivariatePolynomial indeterm Expr2Dmp) _ + (HomogeneousDistributedMultivariatePolynomial indeterm Expr2Dmp) _ + (MultivariatePolynomial indeterm Expr2Mp) _ + (UnivariateLaurentSeries indeterm P2Uls) _ + (UnivariatePolynomial indeterm Expr2Up) _ + (UnivariatePuiseuxSeries indeterm P2Upxs) _ + (UnivariateTaylorSeries indeterm P2Uts) _ + )) _ + + (Kernel . ( _ + (Kernel indeterm Ker2Ker) _ + (Expression indeterm Ker2Expr) _ + )) _ + + (Factored . ( _ + (Factored indeterm Factored2Factored) _ + ))_ + (Fraction . ( _ + (DistributedMultivariatePolynomial partial Qf2domain) _ + (ElementaryFunction indeterm Qf2EF) _ + (Expression indeterm Qf2EF) _ + (Fraction indeterm Qf2Qf) _ + (HomogeneousDistributedMultivariatePolynomial partial Qf2domain) _ + (Integer partial Qf2domain) _ + (MultivariatePolynomial partial Qf2domain) _ + (Polynomial partial Qf2domain) _ + (PrimeField indeterm Qf2PF) _ + (UnivariateLaurentSeries indeterm P2Uls) _ + (UnivariatePolynomial partial Qf2domain) _ + (UnivariatePuiseuxSeries indeterm P2Upxs) _ + (UnivariateTaylorSeries indeterm P2Uts) _ + ))_ + (Int . ( _ + (Expression total ncI2E) _ + (Integer total ncI2I) _ + ))_ + (Baby . ( _ + (Expression total ncI2E) _ + (Integer total ncI2I) _ + ))_ + (Integer . ( _ + (Baby total I2ncI) _ + (EvenInteger partial I2EI) _ + (Int total I2ncI) _ + (NonNegativeInteger partial I2NNI) _ + (OddInteger partial I2OI) _ + (PositiveInteger partial I2PI) _ + ))_ + (List . ( _ + (DirectProduct indeterm L2DP) _ + (Matrix partial L2M) _ + (Record partial L2Record) _ + (RectangularMatrix partial L2Rm) _ + (Set indeterm L2Set) _ + (SquareMatrix partial L2Sm) _ + (Stream indeterm Agg2Agg) _ + (Tuple indeterm L2Tuple) _ + (Vector indeterm L2V) _ + ))_ + )) + +SETANDFILEQ($CoerceTable,NCONC($CoerceTable,'( _ + (Matrix . ( _ + (List indeterm M2L) _ + (RectangularMatrix partial M2Rm) _ + (SquareMatrix partial M2Sm) _ + (Vector indeterm M2L) _ + ))_ + (MultivariatePolynomial . ( _ + (DistributedMultivariatePolynomial indeterm Mp2Dmp) _ + (Expression indeterm Mp2Expr) _ + (Factored indeterm Mp2FR) _ + (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ + (MultivariatePolynomial indeterm Mp2Mp) _ + (Polynomial indeterm Mp2P) _ + (UnivariatePolynomial indeterm Mp2Up) _ + ))_ + (HomogeneousDirectProduct . ( _ + (HomogeneousDirectProduct indeterm DP2DP) _ + ))_ + (HomogeneousDistributedMultivariatePolynomial . ( _ + (Complex indeterm NDmp2domain) _ + (DistributedMultivariatePolynomial indeterm NDmp2domain) _ + (Expression indeterm Dmp2Expr) _ + (Factored indeterm Mp2FR) _ + (Fraction indeterm NDmp2domain) _ + (HomogeneousDistributedMultivariatePolynomial indeterm NDmp2NDmp) _ + (MultivariatePolynomial indeterm NDmp2domain) _ + (Polynomial indeterm NDmp2domain) _ + (Quaternion indeterm NDmp2domain) _ + (UnivariatePolynomial indeterm NDmp2domain) _ + ))_ + (OrderedVariableList . ( _ + (DistributedMultivariatePolynomial indeterm OV2poly) _ + (HomogeneousDistributedMultivariatePolynomial indeterm OV2poly) _ + (MultivariatePolynomial indeterm OV2poly) _ + (OrderedVariableList indeterm OV2OV) _ + (Polynomial total OV2P) _ + (Symbol total OV2Sy) _ + (UnivariatePolynomial indeterm OV2poly) _ + ))_ + (Polynomial . ( _ + (DistributedMultivariatePolynomial indeterm P2Dmp) _ + (Expression indeterm P2Expr) _ + (Factored indeterm P2FR) _ + (HomogeneousDistributedMultivariatePolynomial partial domain2NDmp) _ + (MultivariatePolynomial indeterm P2Mp) _ + (UnivariateLaurentSeries indeterm P2Uls) _ + (UnivariatePolynomial indeterm P2Up) _ + (UnivariatePuiseuxSeries indeterm P2Upxs) _ + (UnivariateTaylorSeries indeterm P2Uts) _ + ))_ + (Set . ( _ + (List indeterm Set2L) _ + (Vector indeterm Agg2L2Agg) _ + ))_ + (RectangularMatrix . ( _ + (List indeterm Rm2L) _ + (Matrix indeterm Rm2M) _ + (SquareMatrix indeterm Rm2Sm) _ + (Vector indeterm Rm2V) _ + ))_ + (SparseUnivariatePolynomial . ( _ + (UnivariatePolynomial indeterm SUP2Up) _ + ))_ + (SquareMatrix . ( + -- ones for polys needed for M[2] P I -> P[x,y] M[2] P I, say + (DistributedMultivariatePolynomial partial Sm2PolyType) _ + (HomogeneousDistributedMultivariatePolynomial partial Sm2PolyType) _ + (List indeterm Sm2L) _ + (Matrix indeterm Sm2M) _ + (MultivariatePolynomial partial Sm2PolyType) _ + (RectangularMatrix indeterm Sm2Rm) _ + (UnivariatePolynomial indeterm Sm2PolyType) _ + (Vector indeterm Sm2V) _ + ) ) _ + (Symbol . ( _ + (DistributedMultivariatePolynomial indeterm Sy2Dmp) _ + (HomogeneousDistributedMultivariatePolynomial indeterm Sy2NDmp) _ + (MultivariatePolynomial indeterm Sy2Mp) _ + (OrderedVariableList partial Sy2OV) _ + (Polynomial total Sy2P) _ + (UnivariatePolynomial indeterm Sy2Up) _ + (Variable indeterm Sy2Var) _ + ) ) _ + (UnivariatePolynomial . ( _ + (DistributedMultivariatePolynomial indeterm Up2Dmp) _ + (Expression indeterm Up2Expr) _ + (Factored indeterm Up2FR) _ + (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ + (MultivariatePolynomial indeterm Up2Mp) _ + (Polynomial indeterm Up2P) _ + (SparseUnivariatePolynomial indeterm Up2SUP) _ + (UnivariatePolynomial indeterm Up2Up) _ + ) ) _ + (Variable . ( _ + (AlgebraicFunction total Var2FS) _ + (ContinuedFractionPowerSeries indeterm Var2OtherPS) _ + (DistributedMultivariatePolynomial indeterm Var2Dmp) _ + (ElementaryFunction total Var2FS) _ + (Fraction indeterm Var2QF) _ + (FunctionalExpression total Var2FS) _ + (GeneralDistributedMultivariatePolynomial indeterm Var2Gdmp) _ + (HomogeneousDistributedMultivariatePolynomial indeterm Var2NDmp) _ + (LiouvillianFunction total Var2FS) _ + (MultivariatePolynomial indeterm Var2Mp) _ + (OrderedVariableList indeterm Var2OV) _ + (Polynomial total Var2P) _ + (SparseUnivariatePolynomial indeterm Var2SUP) _ + (Symbol total Identity) _ + (UnivariatePolynomial indeterm Var2Up) _ + (UnivariatePowerSeries indeterm Var2UpS) _ + ) ) _ + (Vector . ( _ + (DirectProduct indeterm V2DP) _ + (List indeterm V2L) _ + (Matrix indeterm V2M) _ + (RectangularMatrix indeterm V2Rm) _ + (Set indeterm Agg2L2Agg) _ + (SquareMatrix indeterm V2Sm) _ + (Stream indeterm Agg2Agg) _ + ) ) _ + ) ) ) + +-- this list is too long for the parser, so it has to be split into parts +-- specifies the commute functions +-- commute stands for partial commute function +--SETANDFILEQ($CommuteTable, '( _ +-- (DistributedMultivariatePolynomial . ( _ +-- (DistributedMultivariatePolynomial commute commuteMultPol) _ +-- (Complex commute commuteMultPol) _ +-- (MultivariatePolynomial commute commuteMultPol) _ +-- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ +-- (Polynomial commute commuteMultPol) _ +-- (Quaternion commute commuteMultPol) _ +-- (Fraction commute commuteMultPol) _ +-- (SquareMatrix commute commuteMultPol) _ +-- (UnivariatePolynomial commute commuteMultPol) _ +-- )) _ +-- (Complex . ( _ +-- (DistributedMultivariatePolynomial commute commuteG2) _ +-- (MultivariatePolynomial commute commuteG2) _ +-- (NewDistributedMultivariatePolynomial commute commuteG2) _ +-- (Polynomial commute commuteG1) _ +-- (Fraction commute commuteG1) _ +-- (SquareMatrix commute commuteG2) _ +-- (UnivariatePolynomial commute commuteG2) _ +-- )) _ +-- (MultivariatePolynomial . ( _ +-- (DistributedMultivariatePolynomial commute commuteMultPol) _ +-- (Complex commute commuteMultPol) _ +-- (MultivariatePolynomial commute commuteMultPol) _ +-- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ +-- (Polynomial commute commuteMultPol) _ +-- (Quaternion commute commuteMultPol) _ +-- (Fraction commute commuteMultPol) _ +-- (SquareMatrix commute commuteMultPol) _ +-- (UnivariatePolynomial commute commuteMultPol) _ +-- )) _ +-- (Polynomial . ( _ +-- (DistributedMultivariatePolynomial commute commuteMultPol) _ +-- (Complex commute commuteMultPol) _ +-- (MultivariatePolynomial commute commuteMultPol) _ +-- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ +-- (Polynomial commute commuteMultPol) _ +-- (Quaternion commute commuteMultPol) _ +-- (Fraction commute commuteMultPol) _ +-- (SquareMatrix commute commuteMultPol) _ +-- (UnivariatePolynomial commute commuteMultPol) _ +-- )) _ +-- (Quaternion . ( _ +-- (DistributedMultivariatePolynomial commute commuteQuat2) _ +-- (MultivariatePolynomial commute commuteQuat2) _ +-- (NewDistributedMultivariatePolynomial commute commuteQuat2) _ +-- (Polynomial commute commuteQuat1) _ +-- (SquareMatrix commute commuteQuat2) _ +-- (UnivariatePolynomial commute commuteQuat2) _ +-- )) _ +-- (SquareMatrix . ( _ +-- (DistributedMultivariatePolynomial commute commuteSm2) _ +-- (Complex commute commuteSm1) _ +-- (MultivariatePolynomial commute commuteSm2) _ +-- (NewDistributedMultivariatePolynomial commute commuteSm2) _ +-- (Polynomial commute commuteSm1) _ +-- (Quaternion commute commuteSm1) _ +-- (SparseUnivariatePolynomial commute commuteSm1) _ +-- (UnivariatePolynomial commute commuteSm2) _ +-- )) _ +-- (UnivariatePolynomial . ( _ +-- (DistributedMultivariatePolynomial commute commuteUp2) _ +-- (Complex commute commuteUp1) _ +-- (MultivariatePolynomial commute commuteUp2) _ +-- (NewDistributedMultivariatePolynomial commute commuteUp2) _ +-- (Polynomial commute commuteUp1) _ +-- (Quaternion commute commuteUp1) _ +-- (Fraction commute commuteUp1) _ +-- (SparseUnivariatePolynomial commute commuteUp1) _ +-- (SquareMatrix commute commuteUp2) _ +-- (UnivariatePolynomial commute commuteUp2) _ +-- )) _ +-- )) + +SETANDFILEQ($CommuteTable, '( _ + (Complex . ( _ + (DistributedMultivariatePolynomial commute commuteG2) _ + (MultivariatePolynomial commute commuteG2) _ + (HomogeneousDistributedMultivariatePolynomial commute commuteG2) _ + (Polynomial commute commuteG1) _ + (Fraction commute commuteG1) _ + (SquareMatrix commute commuteG2) _ + (UnivariatePolynomial commute commuteG2) _ + )) _ + (Polynomial . ( _ + (Complex commute commuteMultPol) _ + (MultivariatePolynomial commute commuteMultPol) _ + (HomogeneousDistributedMultivariatePolynomial commute commuteMultPol)_ + (Polynomial commute commuteMultPol) _ + (Quaternion commute commuteMultPol) _ + (Fraction commute commuteMultPol) _ + (SquareMatrix commute commuteMultPol) _ + (UnivariatePolynomial commute commuteMultPol) _ + )) _ + (SquareMatrix . ( _ + (DistributedMultivariatePolynomial commute commuteSm2) _ + (Complex commute commuteSm1) _ + (MultivariatePolynomial commute commuteSm2) _ + (HomogeneousDistributedMultivariatePolynomial commute commuteSm2)_ + (Polynomial commute commuteSm1) _ + (Quaternion commute commuteSm1) _ + (SparseUnivariatePolynomial commute commuteSm1) _ + (UnivariatePolynomial commute commuteSm2) _ + )) _ + )) + diff --git a/src/interp/i-coerfn.boot.pamphlet b/src/interp/i-coerfn.boot.pamphlet deleted file mode 100644 index 24f14bf5..00000000 --- a/src/interp/i-coerfn.boot.pamphlet +++ /dev/null @@ -1,2312 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-coerfn.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -Special coercion routines - -This is the newly revised set of coercion functions to work with -the new library and the new runtime system. - -coerceByTable is driven off $CoerceTable which is used to match -the top-level constructors of the source and object types. The -form of $CoerceTable is an alist where the "properties" are the -source top-level constructors and the values are triples - target-domain coercion-type function -where target-domain is the top-level constructor of the target, -coercion-type is one of 'total, 'partial or 'indeterm, and -function is the name of the function to call to handle the -coercion. coercion-type is used by canCoerce and friends: 'total -means that a coercion can definitely be performed, 'partial means -that one cannot tell whether a coercion can be performed unless -you have the actual data (like telling whether a Polynomial Integer -can be coerced to an Integer: you have to know whether it is a -constant polynomial), and 'indeterm means that you might be able -to tell without data, but you need to call the function with the -argument "$fromCoerceable$" for a response of true or false. As an -example of this last kind, you may be able to coerce a list to a -vector but you have to know what the underlying types are. So -List Integer is coerceable to Vector Integer but List Float is -not necessarily coerceable to Vector Integer. - -The functions always take three arguments: - value this is the unwrapped source object - source-type this is the type of the source - target-type this is the requested type of the target -For ethical reasons and to avoid eternal damnation, we try to use -library functions to perform a lot of the structure manipulations. -However, we sometimes cheat for efficiency reasons, particularly to -avoid intermediate instantiations. - -the following are older comments: - -This file contains the special coercion routines that convert from -one datatype to another in the interpreter. The choice of the -primary special routine is made by the function coerceByTable. Note -that not all coercions use these functions, as some are done via SPAD -algebra code and controlled by the function coerceByFunction. See -the file COERCE BOOT for more information. - -some assumption about the call of commute and embed functions: -embed functions are called for one level embedding only, - e.g. I to P I, but not I to P G I -commute functions are called for two types which differ only in the - permutation of the two top type constructors - e.g. G P RN to P G RN, but not G P I to P G RN or - P[x] G RN to G P RN - -all functions in this file should call canCoerce and coerceInt, as - opposed to canCoerceFrom and coerceInteractive - -all these coercion functions have the following result: -1. if u=$fromCoerceable$, then TRUE or NIL -2. if the coercion succeeds, the coerced value (this may be NIL) -3. if the coercion fails, they throw to a catch point in - coerceByTable - -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"i-coerce" -)package "BOOT" - -$coerceFailure := GENSYM() - -position1(x,y) == - -- this is used where we want to assume a 1-based index - 1 + position(x,y) - ---% Direct Product, New and Old - -DP2DP(u,source is [.,n,S],target is [.,m,T]) == - n ^= m => nil - u = '_$fromCoerceable_$ => canCoerce(S,T) - null (u' := coerceInt(objNewWrap(u,['Vector,S]),['Vector,T])) => - coercionFailure() - objValUnwrap u' - ---% Distributed Multivariate Polynomials, New and Old - -Dmp2Dmp(u,source is [dmp,v1,S], target is [.,v2,T]) == - -- the variable lists must share some variables, or u is a constant - u = '_$fromCoerceable_$ => - v:= intersection(v1,v2) - v and - w2:= SETDIFFERENCE(v2,v) - t1:= if w1 then [dmp,w1,S] else S - t2:= if w2 then [dmp,w2,T] else T - canCoerce(t1,t2) - null u => domainZero(target) - u is [[e,:c]] and e=LIST2VEC [0 for v in v1] => - z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) - coercionFailure() - v:= intersection(v1,v2) => - w1:= SETDIFFERENCE(v1,v) => - coerceDmp1(u,source,target,v,w1) - coerceDmp2(u,source,target) - coercionFailure() - -coerceDmp1(u,source is [.,v1,S],target is [.,v2,T],v,w) == - -- coerces one Dmp to another, where v1 is not a subset of v2 - -- v is the intersection, w the complement of v1 and v2 - t:= ['DistributedMultivariatePolynomial,w,S] - x:= domainZero(target) - one:= domainOne(T) - plusfunc:= getFunctionFromDomain('_+,target,[target,target]) - multfunc:= getFunctionFromDomain('_*,target,[target,target]) - pat1:= [member(x,v) for x in v1] - pat2:= [member(x,w) for x in v1] - pat3:= [member(x,v) and POSN1(x,v) for x in v2] - for [e,:c] in u until not z repeat - exp:= LIST2VEC [y for x in pat2 for y in VEC2LIST e | x] - z:= coerceInt(objNewWrap([CONS(exp,c)],t),target) => - li:= [y for x in pat1 for y in VEC2LIST e | x] - a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat3],one)] - x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) - z => x - coercionFailure() - -coerceDmp2(u,source is [.,v1,S],target is [.,v2,T]) == - -- coerces one Dmp to another, where v1 is included in v2 - x:= domainZero(target) - one:= domainOne(T) - plusfunc:= getFunctionFromDomain('_+,target,[target,target]) - multfunc:= getFunctionFromDomain('_*,target,[target,target]) - pat:= [member(x,v1) and POSN1(x,v1) for x in v2] - for [e,:c] in u until not z repeat - z:= coerceInt(objNewWrap(c,S),target) => - li:= VEC2LIST e - a:= [CONS(LIST2VEC [if x then li.x else 0 for x in pat],one)] - x:= SPADCALL(x,SPADCALL(objValUnwrap(z),a,multfunc),plusfunc) - NIL - z => x - coercionFailure() - -Dmp2Expr(u,source is [dmp,vars,S], target is [Expr,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - - null vars => - [[., :c]] := u - not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() - objValUnwrap(c) - - syms := [objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) for - var in vars] - sum := domainZero(target) - - plus := getFunctionFromDomain("+", target, [target, target]) - mult := getFunctionFromDomain("*", target, [target, target]) - expn := getFunctionFromDomain("**", target, [target, $Integer]) - - for [e, :c] in u repeat - not (c := coerceInt(objNewWrap(c, S), target)) => coercionFailure() - c := objValUnwrap(c) - term := domainOne(target) - for i in 0.. for sym in syms repeat - exp := e.i - e.i > 0 => term := SPADCALL(term, SPADCALL(sym, e.i, expn), mult) - sum := SPADCALL(sum, SPADCALL(c, term, mult), plus) - - sum - -Dmp2Mp(u, source is [dmp, x, S], target is [mp, y, T]) == - source' := [dmp,y,T] - u = '_$fromCoerceable_$ => - x = y => canCoerce(S,T) - canCoerce(source',target) - null u => domainZero(target) -- 0 dmp is = nil - x ^= y => - (u' := coerceInt(objNewWrap(u,source),source')) or coercionFailure() - (u' := coerceInt(u',target)) or coercionFailure() - objValUnwrap(u') - - -- slight optimization for case #u = 1, x=y , #x =1 and S=T - -- I know it's pathological, but it may avoid an instantiation - (x=y) and (1 = #u) and (1 = #x) and (S = T) => - [1,1,[(CAAR u).0,0,:CDAR u]] - - (u' := coerceDmpCoeffs(u,S,T)) = 'failed => - coercionFailure() - plusfunc := getFunctionFromDomain("+",target,[target,target]) - u'' := genMpFromDmpTerm(u'.0, 0) - for i in 1..(#u' - 1) repeat - u'' := SPADCALL(u'',genMpFromDmpTerm(u'.i, 0),plusfunc) - u'' - -coerceDmpCoeffs(u,S,T) == - -- u is a dmp, S is domain of coeffs, T is domain to coerce coeffs to - S = T => u - u' := nil - bad := nil - for [e,:c] in u repeat - bad => nil - null (c' := coerceInt(objNewWrap(c,S),T)) => return (bad := true) - u' := [[e,:objValUnwrap(c')],:u'] - bad => 'failed - nreverse u' - -sortAndReorderDmpExponents(u,vl) == - vl' := reverse MSORT vl - n := (-1) + #vl - pos := LIST2VEC LZeros (n+1) - for i in 0..n repeat pos.i := position(vl.i,vl') - u' := nil - for [e,:c] in u repeat - e' := LIST2VEC LZeros (n+1) - for i in 0..n repeat e'.(pos.i) := e.i - u' := [[e',:c],:u'] - reverse u' - -domain2NDmp(u, source, target is [., y, T]) == - target' := ['DistributedMultivariatePolynomial,y,T] - u = '_$fromCoerceable_$ => canCoerce(source,target') - (u' := coerceInt(objNewWrap(u,source),target')) => - (u'' := coerceInt(u',target)) => - objValUnwrap(u'') - coercionFailure() - coercionFailure() - -Dmp2NDmp(u,source is [dmp,x,S],target is [ndmp,y,T]) == - -- a null DMP = 0 - null u => domainZero(target) - target' := [dmp,y,T] - u = '_$fromCoerceable_$ => Dmp2Dmp(u,source,target') - (u' := Dmp2Dmp(u,source,target')) => addDmpLikeTermsAsTarget(u',target) - coercionFailure() - -addDmpLikeTermsAsTarget(u,target) == - u' := domainZero(target) - func := getFunctionFromDomain("+",target,[target,target]) - for t in u repeat u' := SPADCALL(u',[t],func) - u' - --- rewrite ? -Dmp2P(u, source is [dmp,vl, S], target is [.,T]) == - -- a null DMP = 0 - null u => domainZero(target) - u = '_$fromCoerceable_$ => - t := canCoerce(S,T) - null t => canCoerce(S,target) - t - - S is ['Polynomial,.] => - mp := coerceInt(objNewWrap(u,source),['MultivariatePolynomial,vl,S]) - or coercionFailure() - p := coerceInt(mp,target) or coercionFailure() - objValUnwrap p - - -- slight optimization for case #u = 1, #vl =1 and S=T - -- I know it's pathological, but it may avoid an instantiation - (1 = #u) and (1 = #vl) and (S = T) => - (lexp:= (CAAR u).0) = 0 => [1,:CDAR u] - [1,vl.0,[lexp,0,:CDAR u]] - - vl' := reverse MSORT vl - source' := [dmp,vl',S] - target' := ['MultivariatePolynomial,vl',S] - u' := sortAndReorderDmpExponents(u,vl) - u' := coerceInt(objNewWrap(u',source'),target') - if u' then - u' := translateMpVars2PVars (objValUnwrap(u'),vl') - u' := coerceInt(objNewWrap(u',['Polynomial,S]),target) - u' => objValUnwrap(u') - -- get drastic. create monomials - source' := [dmp,vl,T] - u' := domainZero(target) - oneT := domainOne(T) - plusfunc := getFunctionFromDomain("+",target,[target,target]) - multfunc := getFunctionFromDomain("*",target,[target,target]) - for [e,:c] in u repeat - (c' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - (e' := coerceInt(objNewWrap([[e,:oneT]],source'),target)) or - coercionFailure() - t := SPADCALL(objValUnwrap(e'),objValUnwrap(c'),multfunc) - u' := SPADCALL(u',t,plusfunc) - coercionFailure() - -translateMpVars2PVars (u, vl) == - u is [ =1, v, :termlist] => - [ 1, vl.(v-1), - :[[e,:translateMpVars2PVars(c,vl)] for [e,:c] in termlist]] - u - -Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) == - null u => -- this is true if u = 0 - domainZero(target) - - u = '_$fromCoerceable_$ => - member(var,vl) => - vl' := remove(vl,var) - null vl' => -- no remaining variables - canCoerce(S,T) - null rest vl' => -- one remaining variable - canCoerce([up,first vl',S],T) - canCoerce([dmp,vl',S], T) - canCoerce(source,T) - - -- check constant case - (null rest u) and (first(u) is [e,:c]) and - ( and/[(0 = e.i) for i in 0..(-1 + #vl)] ) => - (x := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(x) - - -- check non-member case - null member(var,vl) => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [[0,:objValUnwrap u']] - - vl' := remove(vl,var) - - -- only one variable in DMP case - null vl' => - u' := nreverse SORTBY('CAR,[[e.0,:c] for [e,:c] in u]) - (u' := coerceInt(objNewWrap(u',[up,var,S]),target)) or - coercionFailure() - objValUnwrap u' - - S1 := [dmp,vl',S] - plusfunc:= getFunctionFromDomain('_+,T,[T,T]) - zero := getConstantFromDomain('(Zero),T) - x := NIL - pos:= POSN1(var,vl) - for [e,:c] in u until not y repeat - exp:= e.pos - e1:= removeVectorElt(e,pos) - y:= coerceInt(objNewWrap([[e1,:c]],S1),T) => - -- need to be careful about zeros - p:= ASSQ(exp,x) => - c' := SPADCALL(CDR p,objValUnwrap(y),plusfunc) - c' = zero => x := REMALIST(x,exp) - RPLACD(p,c') - zero = objValUnwrap(y) => 'iterate - x := CONS(CONS(exp,objValUnwrap(y)),x) - y => nreverse SORTBY('CAR,x) - coercionFailure() - -removeVectorElt(v,pos) == - -- removes the pos'th element from vector v - LIST2VEC [x for x in VEC2LIST v for y in 0.. | not (y=pos)] - -removeListElt(l,pos) == - pos = 0 => CDR l - [CAR l, :removeListElt(CDR l,pos-1)] - -NDmp2domain(u,source is [ndmp,x,S],target) == - -- a null NDMP = 0 - null u => domainZero(target) - dmp := 'DistributedMultivariatePolynomial - source' := [dmp,x,S] - u = '_$fromCoerceable_$ => canCoerce(source',target) - u' := addDmpLikeTermsAsTarget(u,source') - (u'' := coerceInt(objNewWrap(u',source'),target)) => - objValUnwrap(u'') - coercionFailure() - -NDmp2NDmp(u,source is [ndmp,x,S],target is [.,y,T]) == - -- a null NDMP = 0 - null u => domainZero(target) - dmp := 'DistributedMultivariatePolynomial - source' := [dmp,x,S] - target' := [dmp,y,T] - u = '_$fromCoerceable_$ => canCoerce(source',target') - u' := addDmpLikeTermsAsTarget(u,source') - (u'' := coerceInt(objNewWrap(u',source'),target')) => - addDmpLikeTermsAsTarget(objValUnwrap(u''),target) - coercionFailure() - ---% Expression - -Expr2Complex(u,source is [.,S], target is [.,T]) == - u = '_$fromCoerceable_$ => nil -- can't tell, in general - - not member(S, [$Integer, $Float, $DoubleFloat]) => coercionFailure() - not member(T, [$Float, $DoubleFloat]) => coercionFailure() - - complexNumeric := getFunctionFromDomain("complexNumeric", ['Numeric, S], [source]) - - -- the following might fail - cf := SPADCALL(u,complexNumeric) -- returns a Float - T = $DoubleFloat => - null (z := coerceInt(objNewWrap(cf, ['Complex, $Float]), ['Complex, $DoubleFloat])) => - coercionFailure() - objValUnwrap z - cf - -Expr2Dmp(u,source is [Expr,S], target is [dmp,v2,T]) == - u = '_$fromCoerceable_$ => canCoerce(source, T) - - null v2 => - not (z := coerceInt(objNewWrap(u, source), T)) => coercionFailure() - [[LIST2VEC NIL, :objValUnwrap z]] - - obj := objNewWrap(u, source) - univ := coerceInt(obj, ['UnivariatePolynomial, first v2, T]) - not univ => - T = source => coercionFailure() - not (z := coerceInt(obj, [dmp, v2, source])) => - coercionFailure() - z := objValUnwrap z - for term in z repeat - [., :c] := term - not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() - RPLACD(term, objValUnwrap c) - z - - univ := objValUnwrap univ - - -- only one variable - - null rest v2 => - for term in univ repeat - RPLACA(term, VECTOR CAR term) - univ - - -- more than one variable - - summands := nil - for [e,:c] in univ repeat - summands := Expr2Dmp1(summands, - LIST2VEC [e, :[0 for v in rest v2]], c, T, 1, rest v2, T) - - plus := getFunctionFromDomain("+", target, [target, target]) - sum := domainZero target - for summand in summands repeat - sum := SPADCALL([summand], sum, plus) - sum - -Expr2Dmp1(summands, vec, c, source, index, varList, T) == - if null varList then - if not (source = T) then - not (c := coerceInt(objNewWrap(c, source), T)) => coercionFailure() - c := objValUnwrap c - summands := [[vec, :c], :summands] - else - univ := coerceInt(objNewWrap(c, source), - ['UnivariatePolynomial, first varList, T]) - univ := objValUnwrap univ - - for [e,:c] in univ repeat - vec := COPY_-SEQ vec - vec.index := e - summands := Expr2Dmp1(summands, vec, c, T, index+1, rest varList, T) - summands - -Expr2Mp(u,source is [Expr,S], target is [.,v2,T]) == - u = '_$fromCoerceable_$ => canCoerce(source, T) - - dmp := ['DistributedMultivariatePolynomial,v2,T] - d := Expr2Dmp(u,source, dmp) - not (m := coerceInt(objNewWrap(d, dmp), target)) => coercionFailure() - objValUnwrap m - -Expr2Up(u,source is [Expr,S], target is [.,var,T]) == - u = '_$fromCoerceable_$ => canCoerce(source, T) - kernelFunc := getFunctionFromDomain("kernels", source, [source]) - kernelDom := ['Kernel, source] - nameFunc := getFunctionFromDomain("name", kernelDom, [kernelDom]) - kernels := SPADCALL(u,kernelFunc) - v1 := [SPADCALL(kernel, nameFunc) for kernel in kernels] - - not member(var, v1) => coercionFailure() - - -- variable is a kernel - - varKernel := kernels.(POSN1(var, v1)) - univFunc := getFunctionFromDomain("univariate", source, [source, kernelDom]) - sup := ['SparseUnivariatePolynomial, source] - - fracUniv := SPADCALL(u, varKernel, univFunc) - denom := CDR fracUniv - - not equalOne(denom, sup) => coercionFailure() - - numer := CAR fracUniv - uniType := ['UnivariatePolynomial, var, source] - (z := coerceInt(objNewWrap(numer, uniType), target)) => objValUnwrap z - coercionFailure() - ---% Kernels over Expr - -Ker2Ker(u,source is [.,S], target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, T) - not (m := coerceInt(objNewWrap(u, source), S)) => coercionFailure() - u' := objValUnwrap m - not (m' := coerceInt(objNewWrap(u', S), T)) => coercionFailure() - u'' := objValUnwrap m' - not (m'' := coerceInt(objNewWrap(u'', T), target)) => coercionFailure() - objValUnwrap m'' - -Ker2Expr(u,source is [.,S], target) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - not (m := coerceByFunction(objNewWrap(u, source), S)) => coercionFailure() - u':= objValUnwrap m - not (m' := coerceInt(objNewWrap(u', S), target)) => coercionFailure() - objValUnwrap m' - - ---% Factored objects - -Factored2Factored(u,oldmode,newmode) == - [.,oldargmode,:.]:= oldmode - [.,newargmode,:.]:= newmode - u = '_$fromCoerceable_$ => canCoerce(oldargmode,newargmode) - u' := unwrap u - unit' := coerceInt(objNewWrap(first u',oldargmode),newargmode) - null unit' => coercionFailure() - factors := KDR u' - factors' := [(coerceFFE(x,oldargmode,newargmode)) for x in factors] - member('failed,factors') => coercionFailure() - [objValUnwrap(unit'),:factors'] - -coerceFFE(ffe, oldmode, newmode) == - fac' := coerceInt(objNewWrap(ffe.1,oldmode),newmode) - null fac' => 'failed - LIST2VEC [ffe.0,objValUnwrap(fac'),ffe.2] - ---% Complex - -Complex2underDomain(u,[.,S],target) == - u = '_$fromCoerceable_$ => nil - [r,:i] := u - i=domainZero(S) => - [r',.,.]:= coerceInt(objNewWrap(r,S),target) or - coercionFailure() - r' - coercionFailure() - -Complex2FR(u,S is [.,R],target is [.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R = $Integer => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => ['GaussianFactorizationPackage] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -Complex2Expr(u, source is [.,S], target is [., T]) == - u = '_$fromCoerceable_$ => - T is ['Complex, T1] and canCoerceFrom(S, T1) or coercionFailure() - E := defaultTargetFE source - negOne := coerceInt(objNewWrap(-1, $Integer), E) - null negOne => coercionFailure() - sqrtFun := getFunctionFromDomain('sqrt, E, [E]) - i := SPADCALL(objValUnwrap negOne, sqrtFun) - realFun := getFunctionFromDomain('real, source, [source]) - imagFun := getFunctionFromDomain('imag, source, [source]) - real := SPADCALL(u, realFun) - imag := SPADCALL(u, imagFun) - realExp := coerceInt(objNewWrap(real, S), E) - null realExp => coercionFailure() - imagExp := coerceInt(objNewWrap(imag, S), E) - null imagExp => coercionFailure() - timesFun := getFunctionFromDomain('_*, E, [E, E]) - plusFun := getFunctionFromDomain('_+, E, [E, E]) - newVal := SPADCALL(objValUnwrap(realExp), - SPADCALL(i, objValUnwrap imagExp, timesFun), plusFun) - newObj := objNewWrap(newVal, E) - finalObj := coerceInt(newObj, target) - finalObj => objValUnwrap finalObj - coercionFailure() - ---% Integer - -I2EI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if not ODDP(n) then n else coercionFailure() - -I2OI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if ODDP(n) then n else coercionFailure() - -I2PI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if n > 0 then n else coercionFailure() - -I2NNI(n,source,target) == - n = '_$fromCoerceable_$ => nil - if n >= 0 then n else coercionFailure() - ---% List - -L2Tuple(val, source is [.,S], target is [.,T]) == - val = '_$fromCoerceable_$ => canCoerce(S,T) - null (object := coerceInt1(objNewWrap(val,source), ['List, T])) => - coercionFailure() - asTupleNew0 objValUnwrap object - -L2DP(l, source is [.,S], target is [.,n,T]) == - -- need to know size of the list - l = '_$fromCoerceable_$ => nil - n ^= SIZE l => coercionFailure() - (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),['Vector,T])) or - coercionFailure() - V2DP(objValUnwrap v, ['Vector, T], target) - -V2DP(v, source is [.,S], target is [.,n,T]) == - -- need to know size of the vector - v = '_$fromCoerceable_$ => nil - n ^= SIZE v => coercionFailure() - (v1 := coerceInt(objNewWrap(v,source),['Vector,T])) or - coercionFailure() - dpFun := getFunctionFromDomain('directProduct, target, [['Vector,T]]) - SPADCALL(objValUnwrap v1, dpFun) - -L2V(l, source is [.,S], target is [.,T]) == - l = '_$fromCoerceable_$ => canCoerce(S,T) - (v := coerceInt(objNewWrap(LIST2VEC l,['Vector,S]),target)) or - coercionFailure() - objValUnwrap(v) - -V2L(v, source is [.,S], target is [.,T]) == - v = '_$fromCoerceable_$ => canCoerce(S,T) - (l := coerceInt(objNewWrap(VEC2LIST v,['List,S]),target)) or - coercionFailure() - objValUnwrap(l) - -L2M(u,[.,D],[.,R]) == - u = '_$fromCoerceable_$ => nil - D is ['List,E] and isRectangularList(u,#u,# first u) => - u' := nil - for x in u repeat - x' := nil - for y in x repeat - (y' := coerceInt(objNewWrap(y,E),R)) or coercionFailure() - x' := [objValUnwrap(y'),:x'] - u' := [LIST2VEC reverse x',:u'] - LIST2VEC reverse u' - coercionFailure() - -L2Record(l,[.,D],[.,:al]) == - l = '_$fromCoerceable_$ => nil - #l = #al => - v:= [u for x in l for [":",.,D'] in al] where u() == - T:= coerceInt(objNewWrap(x,D),D') or return 'failed - objValUnwrap(T) - v = 'failed => coercionFailure() - #v = 2 => [v.0,:v.1] - LIST2VEC v - coercionFailure() - -L2Rm(u,source is [.,D],target is [.,n,m,R]) == - u = '_$fromCoerceable_$ => nil - D is ['List,E] and isRectangularList(u,n,m) => - L2M(u,source,['Matrix,R]) - coercionFailure() - -L2Sm(u,source is [.,D],[.,n,R]) == - u = '_$fromCoerceable_$ => nil - D is ['List,E] and isRectangularList(u,n,n) => - L2M(u,source,['Matrix,R]) - coercionFailure() - -L2Set(x,source is [.,S],target is [.,T]) == - x = '_$fromCoerceable_$ => canCoerce(S,T) - -- call library function brace to get a set - target' := ['Set,S] - u := objNewWrap( - SPADCALL(x,getFunctionFromDomain('brace,target',[source])), - target') - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Set2L(x,source is [.,S],target is [.,T]) == - x = '_$fromCoerceable_$ => canCoerce(S,T) - -- call library function destruct to get a list - u := objNewWrap( - SPADCALL(x,getFunctionFromDomain('destruct,source,[source])), - ['List,S]) - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Agg2Agg(x,source is [agg1,S],target is [.,T]) == - x = '_$fromCoerceable_$ => canCoerce(S,T) - S = T => coercionFailure() -- library function - target' := [agg1,T] - (u := coerceInt(objNewWrap(x,source),target')) or coercionFailure() - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Agg2L2Agg(x,source is [.,S],target) == - -- tries to use list as an intermediate type - mid := ['List,S] - x = '_$fromCoerceable_$ => - canCoerce(source,mid) and canCoerce(mid,target) - (u := coerceInt(objNewWrap(x,source),mid)) or coercionFailure() - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -isRectangularList(x,p,q) == - p=0 or p=#x => - n:= #first x - and/[n=#y for y in rest x] => p=0 or q=n - ---% Matrix - -M2L(x,[.,S],target) == - mid := ['Vector,['Vector,S]] - x = '_$fromCoerceable_$ => canCoerce(mid,target) - (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() - objValUnwrap u - -M2M(x,[.,R],[.,S]) == - x = '_$fromCoerceable_$ => canCoerce(R,S) - n := # x - m := # x.0 - v := nil - for i in 0..(n-1) repeat - u := nil - for j in 0..(m-1) repeat - y := x.i.j - (y' := coerceInt(objNewWrap(y,R),S)) or coercionFailure() - u := [objValUnwrap y',:u] - v := [LIST2VEC reverse u,:v] - LIST2VEC reverse v - -M2Rm(x,source is [.,R],[.,p,q,S]) == - x = '_$fromCoerceable_$ => nil - n:= #x - m:= #x.0 - n=p and m=q => M2M(x,source,[nil,S]) - coercionFailure() - -M2Sm(x,source is [.,R],[.,p,S]) == - x = '_$fromCoerceable_$ => nil - n:= #x - m:= #x.(0) - n=m and m=p => M2M(x,source,[nil,S]) - coercionFailure() - -M2V(x,[.,S],target) == - mid := ['Vector,['Vector,S]] - x = '_$fromCoerceable_$ => canCoerce(mid,target) - (u := coerceInt(objNewWrap(x,mid),target)) or coercionFailure() - objValUnwrap u - ---% Multivariate Polynomial - -Mp2Dmp(u, source is [., x, S], target is [dmp, y, T]) == - -- Change the representation to a DMP with the same variables and - -- coerce. - target' := [dmp,x,S] - u = '_$fromCoerceable_$ => canCoerce(target',target) - - -- check if we have a constant - u is [ =0,:c] => - null (u' := coerceInt(objNewWrap(c,S),target)) => - coercionFailure() - objValUnwrap(u') - - plus := getFunctionFromDomain('_+,target',[target',target']) - mult := getFunctionFromDomain('_*,target',[target',target']) - one := domainOne(S) - zero := domainZero(S) - (u' := coerceInt(objNewWrap(Mp2SimilarDmp(u,S,#x,plus,mult,one,zero), - target'),target)) or coercionFailure() - objValUnwrap(u') - -Mp2SimilarDmp(u,S,n,plus,mult,one,zero) == - u is [ =0,:c] => - c = zero => NIL -- zero for dmp - [[LIST2VEC LZeros n,:c]] - u is [ =1,x,:terms] => - u' := NIL -- zero for dmp - for [e,:c] in terms repeat - e' := LIST2VEC LZeros n - e'.(x-1) := e - t := [[e',:one]] - t := SPADCALL(t,Mp2SimilarDmp(c,S,n,plus,mult,one,zero),mult) - u' := SPADCALL(u',t,plus) - u' - -Mp2Expr(u,source is [mp,vars,S], target is [Expr,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - - dmp := ['DistributedMultivariatePolynomial, vars, S] - not (d := coerceInt(objNewWrap(u, source), dmp)) => coercionFailure() - Dmp2Expr(objValUnwrap d, dmp, target) - -Mp2FR(u,S is [.,vl,R],[.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R in '((Integer) (Fraction (Integer))) => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => - ovl := ['OrderedVariableList, vl] - ['MultivariateFactorize,ovl, ['IndexedExponents, ovl],R,S] - R is ['Fraction, D] => - ovl := ['OrderedVariableList, vl] - package := ['MRationalFactorize,['IndexedExponents, ovl], ovl, D, S] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -Mp2Mp(u,source is [mp,x,S], target is [.,y,T]) == - -- need not deal with case of x = y (coerceByMapping) - common := intersection(y,x) - x' := SETDIFFERENCE(x,common) - y' := SETDIFFERENCE(y,common) - - u = '_$fromCoerceable_$ => - x = y => canCoerce(S,T) - null common => canCoerce(source,T) - null x' => canCoerce(S,target) - null y' => canCoerce([mp,x',S],T) - canCoerce([mp,x',S],[mp,y',T]) - - -- first check for constant case - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - plus := getFunctionFromDomain('_+,target,[target,target]) - - -- now no-common-variables case - - null common => - times := getFunctionFromDomain('_*,target,[target,target]) - expn := getFunctionFromDomain('_*_*,target, - [target,$NonNegativeInteger]) - Mp2MpAux0(u,S,target,x,plus,times,expn) - - -- if source vars are all in target - null x' => - monom := getFunctionFromDomain('monomial,target, - [target,['OrderedVariableList,y],$NonNegativeInteger]) - Mp2MpAux1(u,S,target,x,y,plus,monom) - - -- if target vars are all in source - null y' => -- change source to MP[common] MP[x'] S - univariate := getFunctionFromDomain('univariate, - source,[source,['OrderedVariableList,x]]) - u' := Mp2MpAux2(u,x,common,x',common,x',univariate,S,NIL) - (u' := coerceInt(objNewWrap(u', [mp,common,[mp,x',S]]),target)) or - coercionFailure() - objValUnwrap(u') - - -- we have a mixture - (u' := coerceInt(objNewWrap(u,source),[mp,common,[mp,x',S]])) or - coercionFailure() - (u' := coerceInt(u',target)) or coercionFailure() - objValUnwrap(u') - -Mp2MpAux0(u,S,target,vars,plus,times,expn) == - -- for case when no common variables - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - [.,var,:terms] := u - [mp,.,T] := target - x := coerceInt(objNewWrap(vars.(var-1),['Variable,vars.(var-1)]), - [mp,vars,$Integer]) or coercionFailure() - (x := coerceInt(x,T)) or coercionFailure() - x := [0,:objValUnwrap x] - sum := domainZero(target) - for [e,:c] in terms repeat - prod := SPADCALL(SPADCALL(x,e,expn), - Mp2MpAux0(c,S,target,vars,plus,times,expn),times) - sum := SPADCALL(sum,prod,plus) - sum - -Mp2MpAux1(u,S,target,varl1,varl2,plus,monom) == - -- for case when source vars are all in target - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - [.,var,:terms] := u - sum := domainZero(target) - for [e,:c] in terms repeat - mon := SPADCALL( Mp2MpAux1(c,S,target,varl1,varl2,plus,monom), - position1(varl1.(var-1), varl2),e,monom) - sum := SPADCALL(sum,mon,plus) - sum - -Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) == - -- target vars are all in source - mp2 := ['MultivariatePolynomial,oldcomm,['MultivariatePolynomial, - oldrest,S]] - common => - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),mp2)) or coercionFailure() - objValUnwrap(u') - [var,:common] := common - u' := SPADCALL(u,position1(var,x),univariate) - null(rest(u')) and (first(first(u')) = 0) => - Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) - [1,position1(var,oldcomm),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, - common,restvars,univariate,S,isUnder)] for [e,:c] in u']] - null isUnder => - [0,:Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,true)] - -- just treat like elt of [mp,x',S] - u is [ =0,:c] => u - [var,:restvars] := restvars - u' := SPADCALL(u,position1(var,x),univariate) - null(rest(u')) and (first(first(u')) = 0) => - Mp2MpAux2(u,x,oldcomm,oldrest,common,restvars,univariate,S,isUnder) - [1,position1(var,oldrest),:[[e,:Mp2MpAux2(c,x,oldcomm,oldrest, - common,restvars,univariate,S,isUnder)] for [e,:c] in u']] - -genMpFromDmpTerm(u, oldlen) == - - -- given one term of a DMP representation of a polynomial, this creates - -- the corresponding MP term. - - patlen := oldlen - [e,:c] := u - numexps := # e - patlen >= numexps => [0, :c] - for i in patlen..(numexps - 1) repeat - e.i = 0 => patlen := patlen + 1 - return nil - patlen >= numexps => [0, :c] - [1, 1+patlen, [e.patlen,:genMpFromDmpTerm(u,patlen+1)]] - -Mp2P(u, source is [mp,vl, S], target is [p,R]) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - S is ['Polynomial,.] => MpP2P(u,vl,S,R) - vl' := REVERSE MSORT vl - -- if Mp2Mp fails, a THROW will occur - u' := Mp2Mp(u,source,[mp,vl',S]) - u' := translateMpVars2PVars (u',vl') - (u' := coerceInt(objNewWrap(u',[p,S]),target)) or coercionFailure() - objValUnwrap(u') - -MpP2P(u,vl,PS,R) == - -- u has type MP(vl,PS). Want to coerce to P R. - PR := ['Polynomial,R] - u is [ =0,:c] => - (u' :=coerceInt(objNewWrap(c,PS),PR)) or - coercionFailure() - objValUnwrap u' - [ .,pos,:ec] := u - multivariate := getFunctionFromDomain('multivariate, - PR,[['SparseUnivariatePolynomial,PR],$Symbol]) - sup := [[e,:MpP2P(c,vl,PS,R)] for [e,:c] in ec] - p := SPADCALL(sup,vl.(pos-1),multivariate) - --(p' :=coerceInt(objNewWrap(p,PS),['Polynomial,R])) or coercionFailure() - --objValUnwrap(p') - -Mp2Up(u,source is [mp,vl,S],target is [up,x,T]) == - u = '_$fromCoerceable_$ => - member(x,vl) => - vl = [x] => canCoerce(S,T) - canCoerce([mp,delete(x,vl),S],T) - canCoerce(source,T) - - u is [ =0,:c] => -- constant polynomial? - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap u' - - null member(x,vl) => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [[0,:objValUnwrap(u')]] - - vl = [x] => - u' := [[e,:c] for [e,.,:c] in CDDR u] - (u' := coerceInt(objNewWrap(u',[up,x,S]),target)) - or coercionFailure() - objValUnwrap u' - - -- do a univariate to transform u to a UP(x,P S) and then coerce again - var := position1(x,vl) - UPP := ['UnivariatePolynomial,x,source] - univariate := getFunctionFromDomain('univariate, - source,[source,['OrderedVariableList,vl]]) - upU := SPADCALL(u,var,univariate) -- we may assume this has type UPP - (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() - objValUnwrap u' - ---% OrderedVariableList - -OV2OV(u,source is [.,svl], target is [.,tvl]) == - svl = intersection(svl,tvl) => - u = '_$fromCoerceable_$ => true - position1(svl.(u-1),tvl) - u = '_$fromCoerceable_$ => nil - coercionFailure() - -OV2P(u,source is [.,svl], target is [.,T]) == - u = '_$fromCoerceable_$ => true - v := svl.(unwrap(u)-1) - [1,v,[1,0,:domainOne(T)]] - -OV2poly(u,source is [.,svl], target is [p,vl,T]) == - u = '_$fromCoerceable_$ => - p = 'UnivariatePolynomial => (# svl = 1) and (p = svl.0) - and/[member(v,vl) for v in svl] - v := svl.(unwrap(u)-1) - val' := [1,:domainOne(T)] - p = 'UnivariatePolynomial => - v ^= vl => coercionFailure() - [[1,:domainOne(T)]] - null member(v,vl) => coercionFailure() - val' := [[1,:domainOne(T)]] - source' := ['UnivariatePolynomial,v,T] - (u' := coerceInt(objNewWrap(val',source'),target)) or - coercionFailure() - objValUnwrap(u') - -OV2SE(u,source is [.,svl], target) == - u = '_$fromCoerceable_$ => true - svl.(unwrap(u)-1) - -OV2Sy(u,source is [.,svl], target) == - u = '_$fromCoerceable_$ => true - svl.(unwrap(u)-1) - ---% Polynomial - -varsInPoly(u) == - u is [ =1, v, :termlist] => - [v,:varsInPoly(c) for [e,:c] in termlist] - nil - -P2FR(u,S is [.,R],[.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R in '((Integer) (Fraction (Integer))) => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => - ['MultivariateFactorize,$Symbol,['IndexedExponents, $Symbol],R,S] - R is ['Fraction, D] => - package := ['MRationalFactorize,['IndexedExponents, $Symbol],$Symbol, - D, S] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -P2Dmp(u, source is [., S], target is [., y, T]) == - u = '_$fromCoerceable_$ => - -- might be able to say yes - canCoerce(source,T) - u is [ =0,:c] => -- polynomial is a constant - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - univariate := getFunctionFromDomain('univariate, - source,[source,$Symbol]) - plus := getFunctionFromDomain("+",target,[target,target]) - monom := getFunctionFromDomain('monomial,target, - [target,['OrderedVariableList,y],$NonNegativeInteger]) - P2DmpAux(u,source,S,target,copy y,y,T,univariate,plus,monom) - -P2Expr(u, source is [.,S], target is [., T]) == - u = '_$fromCoerceable_$ => - canCoerce(S, T) - S = T => coercionFailure() - newS := ['Polynomial, T] - val := coerceInt(objNewWrap(u, source), newS) - null val => coercionFailure() - val := coerceInt(val, target) - null val => coercionFailure() - objValUnwrap val - -P2DmpAux(u,source,S,target,varlist,vars,T,univariate,plus,monom) == - u is [ =0,:c] => -- polynomial is a constant - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - -- if no variables left, try to go to underdomain of target (T) - null vars => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - -- if successful, embed - (u' := coerceByFunction(u',target)) or coercionFailure() - objValUnwrap(u') - - -- there are variables, so get them out of u - [x,:vars] := vars - sup := SPADCALL(u,x,univariate) -- this is a SUP P S - null sup => -- zero? unlikely. - domainZero(target) - -- degree 0 polynomial? (variable did not occur) - null(rest(sup)) and first(sup) is [ =0,:c] => - -- call again, but with one less var - P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom) - var := position1(x,varlist) - u' := domainZero(target) - for [e,:c] in sup repeat - u'' := SPADCALL( - P2DmpAux(c,source,S,target,varlist,vars,T,univariate,plus,monom), - var,e,monom) - u' := SPADCALL(u',u'',plus) - u' - -P2Mp(u, source is [., S], target is [., y, T]) == - u = '_$fromCoerceable_$ => - -- might be able to say yes - canCoerce(source,T) - univariate := getFunctionFromDomain('univariate, - source,[source,$Symbol]) - P2MpAux(u,source,S,target,copy y,y,T,univariate) - -P2MpAux(u,source,S,target,varlist,vars,T,univariate) == - u is [ =0,:c] => -- polynomial is a constant - (u' := coerceInt(objNewWrap(c,S),target)) or - coercionFailure() - objValUnwrap(u') - - -- if no variables left, try to go to underdomain of target (T) - null vars => - (u' := coerceInt(objNewWrap(u,source),T)) or - coercionFailure() - -- if successful, embed - [ 0,:objValUnwrap(u')] - - -- there are variables, so get them out of u - [x,:vars] := vars - sup := SPADCALL(u,x,univariate) -- this is a SUP P S - null sup => -- zero? unlikely. - domainZero(target) - -- degree 0 polynomial? (variable did not occur) - null(rest(sup)) and first(sup) is [ =0,:c] => - -- call again, but with one less var - P2MpAux(c,source,S,target,varlist,vars,T,univariate) - terms := [[e,:P2MpAux(c,source,S,target,varlist,vars,T,univariate)] for - [e,:c] in sup] - [1, position1(x,varlist), :terms] - -varIsOnlyVarInPoly(u, var) == - u is [ =1, v, :termlist] => - v ^= var => nil - and/[varIsOnlyVarInPoly(c,var) for [e,:c] in termlist] - true - -P2Up(u,source is [.,S],target is [.,x,T]) == - u = '_$fromCoerceable_$ => canCoerce(source,T) - u is [ =0,:c] => - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - -- see if the target var is the polynomial vars - varsFun := getFunctionFromDomain('variables,source,[source]) - vars := SPADCALL(u,varsFun) - not member(x,vars) => - (u' := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [[0,:objValUnwrap(u')]] - - -- do a univariate to transform u to a UP(x,P S) and then coerce again - UPP := ['UnivariatePolynomial,x,source] - univariate := getFunctionFromDomain('univariate, - source,[source,$Symbol]) - upU := SPADCALL(u,x,univariate) -- we may assume this has type UPP - (u' := coerceInt(objNewWrap(upU,UPP),target)) or coercionFailure() - objValUnwrap(u') - ---% Fraction - -Qf2PF(u,source is [.,D],target) == - u = '_$fromCoerceable_$ => canCoerce(D,target) - [num,:den] := u - num':= coerceInt(objNewWrap(num,D),target) or - coercionFailure() - num' := objValUnwrap num' - den':= coerceInt(objNewWrap(den,D),target) or - coercionFailure() - den' := objValUnwrap den' - equalZero(den', target) => throwKeyedMsg("S2IA0001",NIL) - SPADCALL(num',den', getFunctionFromDomain("/",target,[target,target])) - -Qf2F(u,source is [.,D,:.],target) == - D = $Integer => - u = '_$fromCoerceable_$ => true - Rn2F(u,source,target) - u = '_$fromCoerceable_$ => canCoerce(D,target) - [num,:den] := u - [.,:num']:= coerceInt(objNewWrap(num,D),target) or - coercionFailure() - [.,:den']:= coerceInt(objNewWrap(den,D),target) or - coercionFailure() - (unwrap num') * 1.0 / (unwrap den') - -Rn2F(rnum, source, target) == - float(CAR(rnum)/CDR(rnum)) - --- next function is needed in RN algebra code ---Rn2F([a,:b],source,target) == --- al:=if LINTP a then QLENGTHCODE a else 4 --- bl:=if LINTP b then QLENGTHCODE b else 4 --- MAX(al,bl) < 36 => FLOAT a / FLOAT b --- sl:=0 --- if al>32 then --- sl:=35*(al-32)/4 --- a:=a/2**sl --- if bl>32 then --- sbl:=35*(bl-32)/4 --- b:=b/2**sbl --- sl:=sl-sbl --- ans:=FLOAT a /FLOAT b --- sl=0 => ans --- ans*2**sl - -Qf2domain(u,source is [.,D],target) == - -- tests whether it is an element of the underlying domain - useUnder := (ut := underDomainOf target) and canCoerce(source,ut) - u = '_$fromCoerceable_$ => useUnder - not (containsPolynomial(D) and containsPolynomial(target)) and - useUnder => coercionFailure() -- let other mechanism handle it - [num, :den] := u - (num' := coerceInt(objNewWrap(num,D),target)) or coercionFailure() - num' := objValUnwrap(num') - equalOne(den,D) => num' - (target is [.,[=$QuotientField,T]]) or - (target is [.,.,[=$QuotientField,T]]) => - (den' := coerceInt(objNewWrap(den,D),T)) or coercionFailure() - den' := [domainOne(T),:objValUnwrap(den')] - timesfunc:= getFunctionFromDomain('_*,target, - [[$QuotientField,T],target]) - SPADCALL(den',num',timesfunc) - coercionFailure() - -Qf2EF(u,[.,S],target) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - [num,:den] := u - (num' := coerceInt(objNewWrap(num,S),target)) or - coercionFailure() - (den' := coerceInt(objNewWrap(den,S),target)) or - coercionFailure() - divfun := getFunctionFromDomain("/",target,[target,target]) - SPADCALL(objValUnwrap(num'),objValUnwrap(den'),divfun) - -Qf2Qf(u0,[.,S],target is [.,T]) == - u0 = '_$fromCoerceable_$ => - S = ['Polynomial, [$QuotientField, $Integer]] and - T = '(Polynomial (Integer)) => true - canCoerce(S,T) - [a,:b] := u0 - S = ['Polynomial, [$QuotientField, $Integer]] and - T = '(Polynomial (Integer)) => - (a' := coerceInt(objNewWrap(a,S),target)) => - (b' := coerceInt(objNewWrap(b,S),target)) => - divfunc:= getFunctionFromDomain('_/,target,[target,target]) - SPADCALL(objValUnwrap(a'),objValUnwrap(b'),divfunc) - coercionFailure() - coercionFailure() - (a' := coerceInt(objNewWrap(a,S),T)) => - (b' := coerceInt(objNewWrap(b,S),T)) => - [objValUnwrap(a'),:objValUnwrap(b')] - coercionFailure() - coercionFailure() - --- partOf(x,i) == --- VECP x => x.i --- i=0 => first x --- i=1 => rest x --- systemError '"partOf" - ---% RectangularMatrix - -Rm2L(x,[.,.,.,R],target) == M2L(x,['Matrix,R],target) - -Rm2M(x,[.,.,.,R],target is [.,S]) == M2M(x,[nil,R],target) - -Rm2Sm(x,[.,n,m,S],[.,p,R]) == - x = '_$fromCoerceable_$ => n=m and m=p and canCoerce(S,R) - n=m and m=p => - M2M(x,[nil,S],[nil,R]) - coercionFailure() - -Rm2V(x,[.,.,.,R],target) == M2V(x,['Matrix,R],target) - ---% Script - -Scr2Scr(u, source is [.,S], target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(S,T) - null (v := coerceInt(objNewWrap(CDR u,S),T)) => - coercionFailure() - [CAR u, :objValUnwrap(v)] - ---% SparseUnivariatePolynomialnimial - -SUP2Up(u,source is [.,S],target is [.,x,T]) == - u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) - null u => u - S = T => u - -- try to go underneath first - null (u' := coerceInt(objNewWrap(u,source),T)) => - -- must be careful in case any of the coeffs come back 0 - u' := NIL - zero := getConstantFromDomain('(Zero),T) - for [e,:c] in u repeat - c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or - coercionFailure()) - c' = zero => 'iterate - u' := [[e,:c'],:u'] - nreverse u' - [[0,:objValUnwrap u']] - ---% SquareMatrix - -Sm2L(x,[.,.,R],target) == M2L(x,['Matrix,R],target) - -Sm2M(x,[.,n,R],target is [.,S]) == M2M(x,[nil,R],target) - -Sm2PolyType(u,source is [sm,n,S], target is [pol,vl,T]) == - -- only really handles cases like: - -- SM[2] P I -> P[x,y] SM[2] P I - -- works for UP, MP, DMP and NDMP - u = '_$fromCoerceable_$ => canCoerce(source,T) - -- first want to check case S is Polynomial - S is ['Polynomial,S'] => - -- check to see if variable occurs in any of the terms - if ATOM vl - then vl' := [vl] - else vl' := vl - novars := true - for i in 0..(n-1) while novars repeat - for j in 0..(n-1) while novars repeat - varsUsed := varsInPoly u.i.j - or/[member(x,varsUsed) for x in vl'] => novars := nil - novars => coercionFailure() - source' := [sm,n,[pol,vl,S]] - null (u' := coerceInt(objNewWrap(u,source),source')) => - coercionFailure() - null (u' := coerceInt(u',target)) => - coercionFailure() - objValUnwrap(u') - -- let other cases be handled by standard machinery - coercionFailure() - -Sm2Rm(x,[.,n,R],[.,p,q,S]) == - x = '_$fromCoerceable_$ => p=q and p=n and canCoerce(R,S) - p=q and p=n => - M2M(x,[nil,R],[nil,S]) - coercionFailure() - -Sm2V(x,[.,.,R],target) == M2V(x,['Matrix,R],target) - ---% Symbol - -Sy2OV(u,source,target is [.,vl]) == - u = '_$fromCoerceable_$ => nil - position1(u,vl) - -Sy2Dmp(u,source,target is [dmp,vl,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - len:= #vl - -1^=(n:= position(u,vl)) => - u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] - objValUnwrap(coerceInt(objNew(u,[dmp,vl,$Integer]),target)) - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap u]] - -Sy2Mp(u,source,target is [mp,vl,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - (n:= position1(u,vl)) ^= 0 => - [1,n,[1,0,:domainOne(S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [0,:objValUnwrap(u)] - -Sy2NDmp(u,source,target is [ndmp,vl,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - len:= #vl - -1^=(n:= position(u,vl)) => - u:= wrap LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1],:1] - objValUnwrap(coerceInt(objNew(u,[ndmp,vl,$Integer]),target)) - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap(u)]] - -Sy2P(u,source,target is [poly,S]) == - u = '_$fromCoerceable_$ => true - -- first try to get it into an underdomain - if (S ^= $Integer) then - u' := coerceInt(objNewWrap(u,source),S) - if u' then return [0,:objValUnwrap(u')] - -- if that failed, return it as a polynomial variable - [1,u,[1,0,:domainOne(S)]] - -Sy2Up(u,source,target is [up,x,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - u=x => [[1,:domainOne(S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[0,:objValUnwrap u]] - -Sy2Var(u,source,target is [.,x]) == - u = '_$fromCoerceable_$ => NIL - u=x => u - coercionFailure() - ---% Univariate Polynomial - -Up2Dmp(u,source is ['UnivariatePolynomial,var,S], - target is ['DistributedMultivariatePolynomial,vl,T]) == - -- var must be a member of vl, or u is a constant - u = '_$fromCoerceable_$ => member(var,vl) and canCoerce(S,target) - null u => domainZero(target) - u is [[e,:c]] and e=0 => - z:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(z) - coercionFailure() - member(var,vl) => - x:= domainZero(target) - one:= domainOne(T) - plusfunc:= getFunctionFromDomain('_+,target,[target,target]) - multfunc:= getFunctionFromDomain('_*,target,[target,target]) - n:= #vl ; p:= POSN1(var,vl) - l1:= not (p=0) and [0 for m in 1..p] - l2:= not (p=n-1) and [0 for m in p..n-2] - for [e,:c] in u until not z repeat - z:= coerceInt(objNewWrap(c,S),target) => - y:= SPADCALL(objValUnwrap(z), - [[LIST2VEC [:l1,e,:l2],:one]],multfunc) - x:= SPADCALL(x,y,plusfunc) - z => x - coercionFailure() - coercionFailure() - -Up2Expr(u,source is [up,var,S], target is [Expr,T]) == - u = '_$fromCoerceable_$ => canCoerce(S, target) - - null u => domainZero(target) - - u is [[e,:c]] and e=0 => - (z := coerceInt(objNewWrap(c, S), target)) => objValUnwrap(z) - coercionFailure() - - sym := objValUnwrap coerceInt(objNewWrap(var, $Symbol), target) - - plus := getFunctionFromDomain("+", target, [target, target]) - mult := getFunctionFromDomain("*", target, [target, target]) - expn := getFunctionFromDomain("**", target, [target, $Integer]) - - -- coerce via Horner's rule - - [e1, :c1] := first u - if not (S = target) then - not (c1 := coerceInt(objNewWrap(c1, S), target)) => coercionFailure() - c1 := objValUnwrap(c1) - - for [e2, :c2] in rest u repeat - coef := - e1 - e2 = 1 => sym - SPADCALL(sym, e1-e2, expn) - if not (S = target) then - not (c2 := coerceInt(objNewWrap(c2, S), target)) => - coercionFailure() - c2 := objValUnwrap(c2) - coef := SPADCALL(SPADCALL(c1, coef, mult), c2, plus) - e1 := e2 - c1 := coef - - e1 = 0 => c1 - e1 = 1 => SPADCALL(sym, c1, mult) - SPADCALL(SPADCALL(sym, e1, expn), c1, mult) - -Up2FR(u,S is [.,x,R],target is [.,T]) == - u = '_$fromCoerceable_$ => - S ^= T => nil - R in '((Integer) (Fraction (Integer))) => true - nil - S ^= T => coercionFailure() - package := - R = $Integer => ['UnivariateFactorize,S] - R = $RationalNumber => package := ['RationalFactorize,S] - coercionFailure() - factor := getFunctionFromDomain('factor,package,[S]) - SPADCALL(u,factor) - -Up2Mp(u,source is [.,x,S], target is [.,vl,T]) == - u = '_$fromCoerceable_$ => - member(x,vl) => canCoerce(S,T) - canCoerce(source,T) - - null u => domainZero(target) - - null(rest(u)) and (first(u) is [e,:c]) and e=0 => - x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) - coercionFailure() - - null member(x,vl) => - (x := coerceInt(objNewWrap(u,source),T)) or coercionFailure() - [0,:objValUnwrap(x)] - - plus := getFunctionFromDomain('_+,target,[target,target]) - monom := getFunctionFromDomain('monomial,target, - [target,['OrderedVariableList,vl],$NonNegativeInteger]) - sum := domainZero(target) - pos := position1(x,vl) - - for [e,:c] in u repeat - (p := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - mon := SPADCALL(objValUnwrap(p),pos,e,monom) - sum := SPADCALL(sum,mon,plus) - sum - -Up2P(u,source is [.,var,S],target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - null u => domainZero(target) - u is [[e,:c]] and e=0 => - x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) - coercionFailure() - pol:= domainZero(target) - one:= domainOne(T) - plusfunc := getFunctionFromDomain("+",target,[target,target]) - multfunc := getFunctionFromDomain("*",target,[target,target]) - for [e,:c] in u until not x repeat - x:= coerceInt(objNewWrap(c,S),target) => - term:= SPADCALL([1,var,[e,0,:one]],objValUnwrap(x),multfunc) - pol:= SPADCALL(pol,term,plusfunc) - coercionFailure() - x => pol - coercionFailure() - -Up2SUP(u,source is [.,x,S],target is [.,T]) == - u = '_$fromCoerceable_$ => canCoerce(source,T) or canCoerce(S,T) - null u => u - S = T => u - -- try to go underneath first - null (u' := coerceInt(objNewWrap(u,source),T)) => - u' := NIL - zero := getConstantFromDomain('(Zero),T) - for [e,:c] in u repeat - c' := objValUnwrap (coerceInt(objNewWrap(c,S),T) or - coercionFailure()) - c' = zero => 'iterate - u' := [[e,:c'],:u'] - nreverse u' - [[0,:objValUnwrap u']] - -Up2Up(u,source is [.,v1,S], target is [.,v2,T]) == - -- if v1 = v2 then this is handled by coerceIntByMap - -- this only handles case where poly is a constant - u = '_$fromCoerceable_$ => - v1=v2 => canCoerce(S,T) - canCoerce(source,T) - null u => u - u is [[e,:c]] and e=0 => - x:= coerceInt(objNewWrap(c,S),target) => objValUnwrap(x) - coercionFailure() - coercionFailure() - -insertAlist(a,b,l) == - null l => [[a,:b]] - a = l.0.0 => (RPLAC(CDAR l,b);l) - _?ORDER(l.0.0,a) => [[a,:b],:l] - (fn(a,b,l);l) where fn(a,b,l) == - null rest l => RPLAC(rest l,[[a,:b]]) - a = l.1.0 => RPLAC(rest l.1,b) - _?ORDER(l.1.0,a) => RPLAC(rest l,[[a,:b],:rest l]) - fn(a,b,rest l) - ---% Union - -Un2E(x,source,target) == - ['Union,:branches] := source - x = '_$fromCoerceable_$ => - and/[canCoerce(t, target) for t in branches | ^ STRINGP t] - coerceUn2E(x,source) - ---% Variable - -Var2OV(u,source,target is [.,vl]) == - sym := CADR source - u = '_$fromCoerceable_$ => member(sym,vl) - member(sym,vl) => position1(sym,vl) - coercionFailure() - -Var2Dmp(u,source,target is [dmp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) - - len := #vl - -1 ^= (n:= position(sym,vl)) => - LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], - :getConstantFromDomain('(One),S)] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap u]] - -Var2Gdmp(u,source,target is [dmp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) - - len := #vl - -1 ^= (n:= position(sym,vl)) => - LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], - :getConstantFromDomain('(One),S)] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap u]] - -Var2Mp(u,source,target is [mp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) - (n:= position1(u,vl)) ^= 0 => - [1,n,[1,0,:getConstantFromDomain('(One),S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [0,:objValUnwrap u] - -Var2NDmp(u,source,target is [ndmp,vl,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => member(sym,vl) or canCoerce(source,S) - - len:= #vl - -1^=(n:= position(u,vl)) => - LIST [LIST2VEC [(n=i => 1; 0) for i in 0..len-1], - :getConstantFromDomain('(One),S)] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[Zeros len,:objValUnwrap(u)]] - -Var2P(u,source,target is [poly,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => true - - -- first try to get it into an underdomain - if (S ^= $Integer) then - u' := coerceInt(objNewWrap(u,source),S) - if u' then return [0,:objValUnwrap(u')] - -- if that failed, return it as a polynomial variable - [1,sym,[1,0,:getConstantFromDomain('(One),S)]] - -Var2QF(u,source,target is [qf,S]) == - u = '_$fromCoerceable_$ => canCoerce(source,S) - - S = $Integer => coercionFailure() - sym := CADR source - (u' := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [objValUnwrap u',:getConstantFromDomain('(One),S)] - -Var2FS(u,source,target is [fs,S]) == - u = '_$fromCoerceable_$ => true - (v := coerceInt(objNewWrap(u,source),['Polynomial,S])) or - coercionFailure() - (v := coerceInt(v,target)) or coercionFailure() - objValUnwrap v - -Var2Up(u,source,target is [up,x,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) - - x=sym => [[1,:getConstantFromDomain('(One),S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[0,:objValUnwrap u]] - -Var2SUP(u,source,target is [sup,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => (sym = "?") or canCoerce(source,S) - - sym = "?" => [[1,:getConstantFromDomain('(One),S)]] - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - [[0,:objValUnwrap u]] - -Var2UpS(u,source,target is [ups,x,S]) == - sym := CADR source - u = '_$fromCoerceable_$ => (sym = x) or canCoerce(source,S) - - mid := ['UnivariatePolynomial,x,S] - x = sym => - u := Var2Up(u,source,mid) - (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() - objValUnwrap u - (u := coerceInt(objNewWrap(u,source),S)) or coercionFailure() - (u := coerceInt(u,target)) or coercionFailure() - objValUnwrap u - -Var2OtherPS(u,source,target is [.,x,S]) == - sym := CADR source - mid := ['UnivariatePowerSeries,x,S] - u = '_$fromCoerceable_$ => - (sym = x) or (canCoerce(source,mid) and canCoerce(mid,target)) - u := Var2UpS(u,source,mid) - (u := coerceInt(objNewWrap(u,mid),target)) or coercionFailure() - objValUnwrap u - ---% Vector - -V2M(u,[.,D],[.,R]) == - u = '_$fromCoerceable_$ => - D is ['Vector,:.] => nil -- don't have data - canCoerce(D,R) - -- first see if we are coercing a vector of vectors - D is ['Vector,E] and - isRectangularVector(u,MAXINDEX u,MAXINDEX u.0) => - LIST2VEC - [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) - for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] - -- if not, try making it into a 1 by n matrix - coercionFailure() ---LIST2VEC [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(u.i,D),R)) --- for i in 0..MAXINDEX(u)]] - -V2Rm(u,[.,D],[.,n,m,R]) == - u = '_$fromCoerceable_$ => nil - D is [.,E,:.] and isRectangularVector(u,n-1,m-1) => - LIST2VEC - [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) - for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] - coercionFailure() - -V2Sm(u,[.,D],[.,n,R]) == - u = '_$fromCoerceable_$ => nil - D is [.,E,:.] and isRectangularVector(u,n-1,n-1) => - LIST2VEC - [LIST2VEC [objValUnwrap(coerceInt(objNewWrap(x.j,E),R)) - for j in 0..MAXINDEX(x:=u.i)] for i in 0..MAXINDEX u] - coercionFailure() - -isRectangularVector(x,p,q) == - MAXINDEX x = p => - and/[q=MAXINDEX x.i for i in 0..p] - --- Polynomial and Expression to Univariate series types - -P2Uts(u, source, target) == - P2Us(u,source, target, 'taylor) - -P2Uls(u, source, target) == - P2Us(u,source, target, 'laurent) - -P2Upxs(u, source, target) == - P2Us(u,source, target, 'puiseux) - -P2Us(u, source is [.,S], target is [.,T,var,cen], type) == - u = '_$fromCoerceable_$ => - -- might be able to say yes - canCoerce(S,T) - T isnt ['Expression, :.] => coercionFailure() - if S ^= '(Float) then S := $Integer - obj := objNewWrap(u, source) - E := ['Expression, S] - newU := coerceInt(obj, E) - null newU => coercionFailure() - EQtype := ['Equation, E] - eqfun := getFunctionFromDomain('_=, EQtype, [E,E]) - varE := coerceInt(objNewWrap(var, '(Symbol)), E) - null varE => coercionFailure() - cenE := coerceInt(objNewWrap(cen, T), E) - null cenE => coercionFailure() - eq := SPADCALL(objValUnwrap(varE), objValUnwrap(cenE), eqfun) - package := ['ExpressionToUnivariatePowerSeries, S, E] - func := getFunctionFromDomain(type, package, [E, EQtype]) - newObj := SPADCALL(objValUnwrap(newU), eq, func) - newType := CAR newObj - newVal := CDR newObj - newType = target => newVal - finalObj := coerceInt(objNewWrap(newVal, newType), target) - null finalObj => coercionFailure() - objValUnwrap finalObj - - ---% General Coercion Commutation Functions - --- general commutation functions are called with 5 values --- u object of type source --- source type of u --- S underdomain of source --- target coercion target type --- T underdomain of T --- Because of checking, can always assume S and T have underdomains. - ---% Complex - -commuteComplex(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - [real,:imag] := u - (real := coerceInt(objNewWrap(real,S),target)) or coercionFailure() - (imag := coerceInt(objNewWrap(imag,S),target)) or coercionFailure() - T' := underDomainOf T - i := [domainZero(T'), - :domainOne(T')] - (i := coerceInt(objNewWrap(i,T),target)) or coercionFailure() - f := getFunctionFromDomain("*",target,[target,target]) - i := SPADCALL(objValUnwrap i, objValUnwrap imag, f) - f := getFunctionFromDomain("+",target,[target,target]) - SPADCALL(objValUnwrap real,i,f) - ---% Quaternion - -commuteQuaternion(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - c := [objValUnwrap(coerceInt(objNewWrap(x,S),target) - or coercionFailure()) for x in VEC2LIST u] - q := '(Quaternion (Integer)) - e := [[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]] - e := [(coerceInt(objNewWrap(LIST2VEC x,q),T) - or coercionFailure()) for x in e] - e :=[objValUnwrap(coerceInt(x,target) or coercionFailure()) for x in e] - u' := domainZero(target) - mult := getFunctionFromDomain("*",target,[target,target]) - plus := getFunctionFromDomain("+",target,[target,target]) - for x in c for y in e repeat - u' := SPADCALL(u',SPADCALL(x,y,mult),plus) - u' - ---% Fraction - -commuteFraction(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - ofCategory(target,'(Field)) => canCoerce(S,target) - canCoerce(S,T) and canCoerce(T,target) - [n,:d] := u - ofCategory(target,'(Field)) => - -- see if denominator can go over to target - (d' := coerceInt(objNewWrap(d,S),target)) or coercionFailure() - -- if so, try to invert it - inv := getFunctionFromDomain('inv,target,[target]) - d' := SPADCALL(objValUnwrap d',inv) - -- now coerce to target - (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() - multfunc := getFunctionFromDomain("*",target,[target,target]) - SPADCALL(d',objValUnwrap n',multfunc) - -- see if denominator can go over to QF part of target - (d' := coerceInt(objNewWrap(d,S),T)) or coercionFailure() - -- if so, try to invert it - inv := getFunctionFromDomain('inv,T,[T]) - d' := SPADCALL(objValUnwrap d',inv) - -- now coerce to target - (d' := coerceInt(objNewWrap(d',T),target)) or coercionFailure() - (n' := coerceInt(objNewWrap(n,S),target)) or coercionFailure() - multfunc := getFunctionFromDomain("*",target,[target,target]) - SPADCALL(objValUnwrap d',objValUnwrap n',multfunc) - ---% SquareMatrix - -commuteSquareMatrix(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - -- commuting matrices of matrices should be a no-op - S is ['SquareMatrix,:.] => - source=target => u - coercionFailure() - u' := domainZero(target) - plusfunc := getFunctionFromDomain("+",target,[target,target]) - multfunc := getFunctionFromDomain("*",target,[target,target]) - zero := domainZero(S) - [sm,n,:.] := source - S' := [sm,n,$Integer] - for i in 0..(n-1) repeat - for j in 0..(n-1) repeat - (e := u.i.j) = zero => 'iterate - (e' := coerceInt(objNewWrap(e,S),target)) or coercionFailure() - (Eij := coerceInt(objNewWrap(makeEijSquareMatrix(i,j,n),S'),T)) or - coercionFailure() - (Eij := coerceInt(Eij,target)) or coercionFailure() - e' := SPADCALL(objValUnwrap(e'),objValUnwrap(Eij),multfunc) - u' := SPADCALL(e',u',plusfunc) - u' - -makeEijSquareMatrix(i, j, dim) == - -- assume using 0 based scale, makes a dim by dim matrix with a - -- 1 in the i,j position, zeros elsewhere - LIST2VEC [LIST2VEC [((i=r) and (j=c) => 1; 0) - for c in 0..(dim-1)] for r in 0..(dim-1)] - ---% Univariate Polynomial and Sparse Univariate Polynomial - -commuteUnivariatePolynomial(u,source,S,target,T) == - commuteSparseUnivariatePolynomial(u,source,S,target,T) - -commuteSparseUnivariatePolynomial(u,source,S,target,T) == - u = '_$fromCoerceable_$ => - canCoerce(S,target) and canCoerce(T,target) - - u' := domainZero(target) - null u => u' - - T' := underDomainOf T - one := domainOne(T') - monom := getFunctionFromDomain('monomial,T,[T',$NonNegativeInteger]) - plus := getFunctionFromDomain("+",target,[target,target]) - times := getFunctionFromDomain("*",target,[target,target]) - - for [e,:c] in u repeat - (c := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - m := SPADCALL(one,e,monom) - (m := coerceInt(objNewWrap(m,T),target)) or coercionFailure() - c := objValUnwrap c - m := objValUnwrap m - u' := SPADCALL(u',SPADCALL(c,m,times),plus) - u' - ---% Multivariate Polynomials - -commutePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteMultivariatePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteDistributedMultivariatePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteNewDistributedMultivariatePolynomial(u,source,S,target,T) == - commuteMPolyCat(u,source,S,target,T) - -commuteMPolyCat(u,source,S,target,T) == - u = '_$fromCoerceable_$ => canCoerce(S,target) - -- check constant case - isconstfun := getFunctionFromDomain("ground?",source,[source]) - SPADCALL(u,isconstfun) => - constfun := getFunctionFromDomain("ground",source,[source]) - c := SPADCALL(u,constfun) - (u' := coerceInt(objNewWrap(c,S),target)) or coercionFailure() - objValUnwrap(u') - - lmfun := getFunctionFromDomain('leadingMonomial,source,[source]) - lm := SPADCALL(u,lmfun) -- has type source, is leading monom - - lcfun := getFunctionFromDomain('leadingCoefficient,source,[source]) - lc := SPADCALL(lm,lcfun) -- has type S, is leading coef - (lc' := coerceInt(objNewWrap(lc,S),target)) or coercionFailure() - - pmfun := getFunctionFromDomain('primitiveMonomials,source,[source]) - lm := first SPADCALL(lm,pmfun) -- now we have removed the leading coef - (lm' := coerceInt(objNewWrap(lm,source),T)) or coercionFailure() - (lm' := coerceInt(lm',target)) or coercionFailure() - - rdfun := getFunctionFromDomain('reductum,source,[source]) - rd := SPADCALL(u,rdfun) -- has type source, is reductum - (rd' := coerceInt(objNewWrap(rd,source),target)) or coercionFailure() - - lc' := objValUnwrap lc' - lm' := objValUnwrap lm' - rd' := objValUnwrap rd' - - plusfun := getFunctionFromDomain("+",target,[target,target]) - multfun := getFunctionFromDomain("*",target,[target,target]) - SPADCALL(SPADCALL(lc',lm',multfun),rd',plusfun) - ------------------------------------------------------------------------- --- Format for alist member is: domain coercionType function --- here coercionType can be one of 'total, 'partial or 'indeterm --- (indeterminant - cannot tell in a simple way). --- --- In terms of canCoerceFrom, 'total implies true, 'partial implies --- false (just cannot tell without actual data) and 'indeterm means --- to call the function with the data = "$fromCoerceable$" for a --- response of true or false. ------------------------------------------------------------------------- --- There are no entries here for RationalNumber or RationalFunction. --- These should have been changed to QF I and QF P, respectively, by --- a function like deconstructTower. RSS 8-1-85 ------------------------------------------------------------------------- - -SETANDFILEQ($CoerceTable, '( _ - (Complex . ( _ - (Expression indeterm Complex2Expr) _ - (Factored indeterm Complex2FR) _ - (Integer partial Complex2underDomain) _ - (PrimeField partial Complex2underDomain) _ - ))_ - (DirectProduct . ( _ - (DirectProduct partial DP2DP) _ - )) _ - (DistributedMultivariatePolynomial . ( _ - (DistributedMultivariatePolynomial indeterm Dmp2Dmp) _ - (Expression indeterm Dmp2Expr) _ - (Factored indeterm Mp2FR) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Dmp2NDmp) _ - (MultivariatePolynomial indeterm Dmp2Mp) _ - (Polynomial indeterm Dmp2P) _ - (UnivariatePolynomial indeterm Dmp2Up) _ - ))_ - (Expression . ( - (Complex partial Expr2Complex) _ - (DistributedMultivariatePolynomial indeterm Expr2Dmp) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Expr2Dmp) _ - (MultivariatePolynomial indeterm Expr2Mp) _ - (UnivariateLaurentSeries indeterm P2Uls) _ - (UnivariatePolynomial indeterm Expr2Up) _ - (UnivariatePuiseuxSeries indeterm P2Upxs) _ - (UnivariateTaylorSeries indeterm P2Uts) _ - )) _ - - (Kernel . ( _ - (Kernel indeterm Ker2Ker) _ - (Expression indeterm Ker2Expr) _ - )) _ - - (Factored . ( _ - (Factored indeterm Factored2Factored) _ - ))_ - (Fraction . ( _ - (DistributedMultivariatePolynomial partial Qf2domain) _ - (ElementaryFunction indeterm Qf2EF) _ - (Expression indeterm Qf2EF) _ - (Fraction indeterm Qf2Qf) _ - (HomogeneousDistributedMultivariatePolynomial partial Qf2domain) _ - (Integer partial Qf2domain) _ - (MultivariatePolynomial partial Qf2domain) _ - (Polynomial partial Qf2domain) _ - (PrimeField indeterm Qf2PF) _ - (UnivariateLaurentSeries indeterm P2Uls) _ - (UnivariatePolynomial partial Qf2domain) _ - (UnivariatePuiseuxSeries indeterm P2Upxs) _ - (UnivariateTaylorSeries indeterm P2Uts) _ - ))_ - (Int . ( _ - (Expression total ncI2E) _ - (Integer total ncI2I) _ - ))_ - (Baby . ( _ - (Expression total ncI2E) _ - (Integer total ncI2I) _ - ))_ - (Integer . ( _ - (Baby total I2ncI) _ - (EvenInteger partial I2EI) _ - (Int total I2ncI) _ - (NonNegativeInteger partial I2NNI) _ - (OddInteger partial I2OI) _ - (PositiveInteger partial I2PI) _ - ))_ - (List . ( _ - (DirectProduct indeterm L2DP) _ - (Matrix partial L2M) _ - (Record partial L2Record) _ - (RectangularMatrix partial L2Rm) _ - (Set indeterm L2Set) _ - (SquareMatrix partial L2Sm) _ - (Stream indeterm Agg2Agg) _ - (Tuple indeterm L2Tuple) _ - (Vector indeterm L2V) _ - ))_ - )) - -SETANDFILEQ($CoerceTable,NCONC($CoerceTable,'( _ - (Matrix . ( _ - (List indeterm M2L) _ - (RectangularMatrix partial M2Rm) _ - (SquareMatrix partial M2Sm) _ - (Vector indeterm M2L) _ - ))_ - (MultivariatePolynomial . ( _ - (DistributedMultivariatePolynomial indeterm Mp2Dmp) _ - (Expression indeterm Mp2Expr) _ - (Factored indeterm Mp2FR) _ - (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ - (MultivariatePolynomial indeterm Mp2Mp) _ - (Polynomial indeterm Mp2P) _ - (UnivariatePolynomial indeterm Mp2Up) _ - ))_ - (HomogeneousDirectProduct . ( _ - (HomogeneousDirectProduct indeterm DP2DP) _ - ))_ - (HomogeneousDistributedMultivariatePolynomial . ( _ - (Complex indeterm NDmp2domain) _ - (DistributedMultivariatePolynomial indeterm NDmp2domain) _ - (Expression indeterm Dmp2Expr) _ - (Factored indeterm Mp2FR) _ - (Fraction indeterm NDmp2domain) _ - (HomogeneousDistributedMultivariatePolynomial indeterm NDmp2NDmp) _ - (MultivariatePolynomial indeterm NDmp2domain) _ - (Polynomial indeterm NDmp2domain) _ - (Quaternion indeterm NDmp2domain) _ - (UnivariatePolynomial indeterm NDmp2domain) _ - ))_ - (OrderedVariableList . ( _ - (DistributedMultivariatePolynomial indeterm OV2poly) _ - (HomogeneousDistributedMultivariatePolynomial indeterm OV2poly) _ - (MultivariatePolynomial indeterm OV2poly) _ - (OrderedVariableList indeterm OV2OV) _ - (Polynomial total OV2P) _ - (Symbol total OV2Sy) _ - (UnivariatePolynomial indeterm OV2poly) _ - ))_ - (Polynomial . ( _ - (DistributedMultivariatePolynomial indeterm P2Dmp) _ - (Expression indeterm P2Expr) _ - (Factored indeterm P2FR) _ - (HomogeneousDistributedMultivariatePolynomial partial domain2NDmp) _ - (MultivariatePolynomial indeterm P2Mp) _ - (UnivariateLaurentSeries indeterm P2Uls) _ - (UnivariatePolynomial indeterm P2Up) _ - (UnivariatePuiseuxSeries indeterm P2Upxs) _ - (UnivariateTaylorSeries indeterm P2Uts) _ - ))_ - (Set . ( _ - (List indeterm Set2L) _ - (Vector indeterm Agg2L2Agg) _ - ))_ - (RectangularMatrix . ( _ - (List indeterm Rm2L) _ - (Matrix indeterm Rm2M) _ - (SquareMatrix indeterm Rm2Sm) _ - (Vector indeterm Rm2V) _ - ))_ - (SparseUnivariatePolynomial . ( _ - (UnivariatePolynomial indeterm SUP2Up) _ - ))_ - (SquareMatrix . ( - -- ones for polys needed for M[2] P I -> P[x,y] M[2] P I, say - (DistributedMultivariatePolynomial partial Sm2PolyType) _ - (HomogeneousDistributedMultivariatePolynomial partial Sm2PolyType) _ - (List indeterm Sm2L) _ - (Matrix indeterm Sm2M) _ - (MultivariatePolynomial partial Sm2PolyType) _ - (RectangularMatrix indeterm Sm2Rm) _ - (UnivariatePolynomial indeterm Sm2PolyType) _ - (Vector indeterm Sm2V) _ - ) ) _ - (Symbol . ( _ - (DistributedMultivariatePolynomial indeterm Sy2Dmp) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Sy2NDmp) _ - (MultivariatePolynomial indeterm Sy2Mp) _ - (OrderedVariableList partial Sy2OV) _ - (Polynomial total Sy2P) _ - (UnivariatePolynomial indeterm Sy2Up) _ - (Variable indeterm Sy2Var) _ - ) ) _ - (UnivariatePolynomial . ( _ - (DistributedMultivariatePolynomial indeterm Up2Dmp) _ - (Expression indeterm Up2Expr) _ - (Factored indeterm Up2FR) _ - (HomogeneousDistributedMultivariatePolynomial indeterm domain2NDmp) _ - (MultivariatePolynomial indeterm Up2Mp) _ - (Polynomial indeterm Up2P) _ - (SparseUnivariatePolynomial indeterm Up2SUP) _ - (UnivariatePolynomial indeterm Up2Up) _ - ) ) _ - (Variable . ( _ - (AlgebraicFunction total Var2FS) _ - (ContinuedFractionPowerSeries indeterm Var2OtherPS) _ - (DistributedMultivariatePolynomial indeterm Var2Dmp) _ - (ElementaryFunction total Var2FS) _ - (Fraction indeterm Var2QF) _ - (FunctionalExpression total Var2FS) _ - (GeneralDistributedMultivariatePolynomial indeterm Var2Gdmp) _ - (HomogeneousDistributedMultivariatePolynomial indeterm Var2NDmp) _ - (LiouvillianFunction total Var2FS) _ - (MultivariatePolynomial indeterm Var2Mp) _ - (OrderedVariableList indeterm Var2OV) _ - (Polynomial total Var2P) _ - (SparseUnivariatePolynomial indeterm Var2SUP) _ - (Symbol total Identity) _ - (UnivariatePolynomial indeterm Var2Up) _ - (UnivariatePowerSeries indeterm Var2UpS) _ - ) ) _ - (Vector . ( _ - (DirectProduct indeterm V2DP) _ - (List indeterm V2L) _ - (Matrix indeterm V2M) _ - (RectangularMatrix indeterm V2Rm) _ - (Set indeterm Agg2L2Agg) _ - (SquareMatrix indeterm V2Sm) _ - (Stream indeterm Agg2Agg) _ - ) ) _ - ) ) ) - --- this list is too long for the parser, so it has to be split into parts --- specifies the commute functions --- commute stands for partial commute function ---SETANDFILEQ($CommuteTable, '( _ --- (DistributedMultivariatePolynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteMultPol) _ --- (Complex commute commuteMultPol) _ --- (MultivariatePolynomial commute commuteMultPol) _ --- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ --- (Polynomial commute commuteMultPol) _ --- (Quaternion commute commuteMultPol) _ --- (Fraction commute commuteMultPol) _ --- (SquareMatrix commute commuteMultPol) _ --- (UnivariatePolynomial commute commuteMultPol) _ --- )) _ --- (Complex . ( _ --- (DistributedMultivariatePolynomial commute commuteG2) _ --- (MultivariatePolynomial commute commuteG2) _ --- (NewDistributedMultivariatePolynomial commute commuteG2) _ --- (Polynomial commute commuteG1) _ --- (Fraction commute commuteG1) _ --- (SquareMatrix commute commuteG2) _ --- (UnivariatePolynomial commute commuteG2) _ --- )) _ --- (MultivariatePolynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteMultPol) _ --- (Complex commute commuteMultPol) _ --- (MultivariatePolynomial commute commuteMultPol) _ --- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ --- (Polynomial commute commuteMultPol) _ --- (Quaternion commute commuteMultPol) _ --- (Fraction commute commuteMultPol) _ --- (SquareMatrix commute commuteMultPol) _ --- (UnivariatePolynomial commute commuteMultPol) _ --- )) _ --- (Polynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteMultPol) _ --- (Complex commute commuteMultPol) _ --- (MultivariatePolynomial commute commuteMultPol) _ --- (NewDistributedMultivariatePolynomial commute commuteMultPol) _ --- (Polynomial commute commuteMultPol) _ --- (Quaternion commute commuteMultPol) _ --- (Fraction commute commuteMultPol) _ --- (SquareMatrix commute commuteMultPol) _ --- (UnivariatePolynomial commute commuteMultPol) _ --- )) _ --- (Quaternion . ( _ --- (DistributedMultivariatePolynomial commute commuteQuat2) _ --- (MultivariatePolynomial commute commuteQuat2) _ --- (NewDistributedMultivariatePolynomial commute commuteQuat2) _ --- (Polynomial commute commuteQuat1) _ --- (SquareMatrix commute commuteQuat2) _ --- (UnivariatePolynomial commute commuteQuat2) _ --- )) _ --- (SquareMatrix . ( _ --- (DistributedMultivariatePolynomial commute commuteSm2) _ --- (Complex commute commuteSm1) _ --- (MultivariatePolynomial commute commuteSm2) _ --- (NewDistributedMultivariatePolynomial commute commuteSm2) _ --- (Polynomial commute commuteSm1) _ --- (Quaternion commute commuteSm1) _ --- (SparseUnivariatePolynomial commute commuteSm1) _ --- (UnivariatePolynomial commute commuteSm2) _ --- )) _ --- (UnivariatePolynomial . ( _ --- (DistributedMultivariatePolynomial commute commuteUp2) _ --- (Complex commute commuteUp1) _ --- (MultivariatePolynomial commute commuteUp2) _ --- (NewDistributedMultivariatePolynomial commute commuteUp2) _ --- (Polynomial commute commuteUp1) _ --- (Quaternion commute commuteUp1) _ --- (Fraction commute commuteUp1) _ --- (SparseUnivariatePolynomial commute commuteUp1) _ --- (SquareMatrix commute commuteUp2) _ --- (UnivariatePolynomial commute commuteUp2) _ --- )) _ --- )) - -SETANDFILEQ($CommuteTable, '( _ - (Complex . ( _ - (DistributedMultivariatePolynomial commute commuteG2) _ - (MultivariatePolynomial commute commuteG2) _ - (HomogeneousDistributedMultivariatePolynomial commute commuteG2) _ - (Polynomial commute commuteG1) _ - (Fraction commute commuteG1) _ - (SquareMatrix commute commuteG2) _ - (UnivariatePolynomial commute commuteG2) _ - )) _ - (Polynomial . ( _ - (Complex commute commuteMultPol) _ - (MultivariatePolynomial commute commuteMultPol) _ - (HomogeneousDistributedMultivariatePolynomial commute commuteMultPol)_ - (Polynomial commute commuteMultPol) _ - (Quaternion commute commuteMultPol) _ - (Fraction commute commuteMultPol) _ - (SquareMatrix commute commuteMultPol) _ - (UnivariatePolynomial commute commuteMultPol) _ - )) _ - (SquareMatrix . ( _ - (DistributedMultivariatePolynomial commute commuteSm2) _ - (Complex commute commuteSm1) _ - (MultivariatePolynomial commute commuteSm2) _ - (HomogeneousDistributedMultivariatePolynomial commute commuteSm2)_ - (Polynomial commute commuteSm1) _ - (Quaternion commute commuteSm1) _ - (SparseUnivariatePolynomial commute commuteSm1) _ - (UnivariatePolynomial commute commuteSm2) _ - )) _ - )) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot new file mode 100644 index 00000000..0eb5a136 --- /dev/null +++ b/src/interp/i-eval.boot @@ -0,0 +1,453 @@ +-- 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. + + +import '"i-analy" +)package "BOOT" + +--% Constructor Evaluation + +$noEvalTypeMsg := nil + +evalDomain form == + if $evalDomain then + sayMSG concat('" instantiating","%b",prefix2String form,"%d") + startTimingProcess 'instantiation + newType? form => form + result := eval mkEvalable form + stopTimingProcess 'instantiation + result + +mkEvalable form == + form is [op,:argl] => + op="QUOTE" => form + op="WRAPPED" => mkEvalable devaluate argl + op="Record" => mkEvalableRecord form + op="Union" => mkEvalableUnion form + op="Mapping"=> mkEvalableMapping form + op="Enumeration" => form + loadIfNecessary op + kind:= GETDATABASE(op,'CONSTRUCTORKIND) + cosig := GETDATABASE(op, 'COSIG) => + [op,:[val for x in argl for typeFlag in rest cosig]] where val() == + typeFlag => + kind = 'category => MKQ x + VECP x => MKQ x + loadIfNecessary x + mkEvalable x + x is ['QUOTE,:.] => x + x is ['_#,y] => ['SIZE,MKQ y] + MKQ x + [op,:[mkEvalable x for x in argl]] + form=$EmptyMode => $Integer + IDENTP form and constructor?(form) => [form] + FBPIP form => BPINAME form + form + +mkEvalableMapping form == + [first form,:[mkEvalable d for d in rest form]] + +mkEvalableRecord form == + [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] + +mkEvalableUnion form == + isTaggedUnion form => + [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] + [first form,:[mkEvalable d for d in rest form]] + +evaluateType0 form == + -- Takes a parsed, unabbreviated type and evaluates it, replacing + -- type valued variables with their values, and calling bottomUp + -- on non-type valued arguemnts to the constructor + -- and finally checking to see whether the type satisfies the + -- conditions of its modemap + -- However, the input might be an attribute, not a type + -- $noEvalTypeMsg: fluid := true + domain:= isDomainValuedVariable form => domain + form = $EmptyMode => form + form = "?" => $EmptyMode + STRINGP form => form + form = "$" => form + $expandSegments : local := nil + form is ['typeOf,.] => + form' := mkAtree form + bottomUp form' + objVal getValue(form') + form is [op,:argl] => + op='CATEGORY => + argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] + form + op in '(Join Mapping) => + [op,:[evaluateType arg for arg in argl]] + op='Union => + argl and first argl is [x,.,.] and member(x,'(_: Declare)) => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + [op,:[evaluateType arg for arg in argl]] + op='Record => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + op='Enumeration => form + constructor? op => evaluateType1 form + NIL + constructor? form => + ATOM form => evaluateType [form] + throwEvalTypeMsg("S2IE0003",[form,form]) + +evaluateType form == + -- Takes a parsed, unabbreviated type and evaluates it, replacing + -- type valued variables with their values, and calling bottomUp + -- on non-type valued arguemnts to the constructor + -- and finally checking to see whether the type satisfies the + -- conditions of its modemap + domain:= isDomainValuedVariable form => domain + form = $EmptyMode => form + form = "?" => $EmptyMode + STRINGP form => form + form = "$" => form + $expandSegments : local := nil + form is ['typeOf,.] => + form' := mkAtree form + bottomUp form' + objVal getValue(form') + form is [op,:argl] => + op='CATEGORY => + argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] + form + op in '(Join Mapping) => + [op,:[evaluateType arg for arg in argl]] + op='Union => + argl and first argl is [x,.,.] and member(x,'(_: Declare)) => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + [op,:[evaluateType arg for arg in argl]] + op='Record => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + op='Enumeration => form + evaluateType1 form + constructor? form => + ATOM form => evaluateType [form] + throwEvalTypeMsg("S2IE0003",[form,form]) + throwEvalTypeMsg("S2IE0004",[form]) + +evaluateType1 form == + --evaluates the arguments passed to a constructor + [op,:argl]:= form + constructor? op => + null (sig := getConstructorSignature form) => + throwEvalTypeMsg("S2IE0005",[form]) + [.,:ml] := sig + ml := replaceSharps(ml,form) + # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) + for x in argl for m in ml for argnum in 1.. repeat + typeList := [v,:typeList] where v() == + categoryForm?(m) => + m := evaluateType MSUBSTQ(x,'_$,m) + evalCategory(x' := (evaluateType x), m) => x' + throwEvalTypeMsg("S2IE0004",[form]) + m := evaluateType m + GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and + (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => + [zt,:zv]:= z1:= getAndEvalConstructorArgument tree + (v' := coerceOrRetract(z1,m)) => objValUnwrap v' + throwKeyedMsgCannotCoerceWithValue(zv,zt,m) + if x = $EmptyMode then x := $quadSymbol + throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) + [op,:NREVERSE typeList] + throwEvalTypeMsg("S2IE0007",[op]) + +throwEvalTypeMsg(msg, args) == + $noEvalTypeMsg => spadThrow() + throwKeyedMsg(msg, args) + +makeOrdinal i == + ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) + +evaluateSignature sig == + -- calls evaluateType on a signature + sig is [ ='SIGNATURE,fun,sigl] => + ['SIGNATURE,fun, + [(t = '_$ => t; evaluateType(t)) for t in sigl]] + sig + +--% Code Evaluation + +-- This code generates, then evaluates code during the bottom up phase +-- of interpretation + +splitIntoBlocksOf200 a == + null a => nil + [[first (r:=x) for x in tails a for i in 1..200], + :splitIntoBlocksOf200 rest r] + +evalForm(op,opName,argl,mmS) == + -- applies the first applicable function + for mm in mmS until form repeat + [sig,fun,cond]:= mm + (CAR sig) = 'interpOnly => form := CAR sig + #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 + form:= + $genValue or null cond => + [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig] + [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig for c in cond] + form or null argl => + dc:= CAR sig + form := + dc='local => --[fun,:form] + atom fun => + fun in $localVars => ['SPADCALL,:form,fun] + [fun,:form,NIL] + ['SPADCALL,:form,fun] + dc is ["__FreeFunction__",:freeFun] => + ['SPADCALL,:form,freeFun] + fun is ['XLAM,xargs,:xbody] => + rec := first form + xbody is [['RECORDELT,.,ind,len]] => + optRECORDELT([CAAR xbody,rec,ind,len]) + xbody is [['SETRECORDELT,.,ind,len,.]] => + optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) + xbody is [['RECORDCOPY,.,len]] => + optRECORDCOPY([CAAR xbody,rec,len]) + ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] + dcVector := evalDomain dc + fun0 := + newType? CAAR mm => + mm' := first ncSigTransform mm + ncGetFunction(opName, first mm', rest mm') + NRTcompileEvalForm(opName,fun,dcVector) + null fun0 => throwKeyedMsg("S2IE0008",[opName]) + [bpi,:domain] := fun0 + EQ(bpi,function Undef) => + sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) + NIL + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Applying ",first fun0,'" to:"] + pp [devaluateDeeply x for x in form] + _$:fluid := domain + ['SPADCALL, :form, fun0] + not form => nil +-- not form => throwKeyedMsg("S2IE0008",[opName]) + form='interpOnly => rewriteMap(op,opName,argl) + targetType := CADR sig + if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType + evalFormMkValue(op,form,targetType) + +sideEffectedArg?(t,sig,opName) == + opString := SYMBOL_-NAME opName + (opName ^= 'setelt) and (ELT(opString, #opString-1) ^= char '_!) => nil + dc := first sig + t = dc + +getArgValue(a, t) == + atom a and not VECP a => + t' := coerceOrRetract(getBasicObject a,t) + t' and wrapped2Quote objVal t' + v := getArgValue1(a, t) => v + alt := altTypeOf(objMode getValue a, a, nil) => + t' := coerceInt(getValue a, alt) + t' := coerceOrRetract(t',t) + t' and wrapped2Quote objVal t' + nil + +getArgValue1(a,t) == + -- creates a value for a, coercing to t + t' := getValue(a) => + (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and + objValUnwrap(t') is ['MAP,:.] => + getMappingArgValue(a,t,m) + t' := coerceOrRetract(t',t) + t' and wrapped2Quote objVal t' + systemErrorHere '"getArgValue" + +getArgValue2(a,t,se?,opName) == + se? and (objMode(getValue a) ^= t) => + throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t]) + getArgValue(a,t) + +getArgValueOrThrow(x, type) == + getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type]) + +getMappingArgValue(a,t,m is ['Mapping,:ml]) == + (una := getUnname a) in $localVars => + $genValue => + name := get(una,'name,$env) + a.0 := name + mmS := selectLocalMms(a,name,rest ml, nil) + or/[mm for mm in mmS | + (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] + NIL + una + mmS := selectLocalMms(a,una,rest ml, nil) + or/[mm for mm in mmS | + (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] + NIL + +getArgValueComp2(arg, type, cond, se?, opName) == + se? and (objMode(getValue arg) ^= type) => + throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type]) + getArgValueComp(arg, type, cond) + +getArgValueComp(arg,type,cond) == + -- getArgValue for compiled case. if there is a condition then + -- v must be data to verify that coerceInteractive succeeds. + v:= getArgValue(arg,type) + null v => nil + null cond => v + v is ['QUOTE,:.] or getBasicMode v => v + n := getUnnameIfCan arg + if num := isSharpVarWithNum n then + not $compilingMap => n := 'unknownVar + alias := get($mapName,'alias,$e) + n := alias.(num - 1) + keyedMsgCompFailure("S2IE0010",[n]) + +evalFormMkValue(op,form,tm) == + val:= + u:= + $genValue => wrap timedEVALFUN form + form + objNew(u,tm) +--+ + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Value of ",op.0,'" ===> "] + pp unwrap u + putValue(op,val) + [tm] + +failCheck x == + x = '"failed" => + stopTimingProcess peekTimedName() + THROW('interpreter,objNewWrap('"failed",$String)) + x = $coerceFailure => + NIL + x + +--% Some Antique Comments About the Interpreter + +--EVAL BOOT contains the top level interface to the Scratchhpad-II +--interpreter. The Entry point into the interpreter from the parser is +--processInteractive. +--The type analysis algorithm is contained in the file BOTMUP BOOT, +--and MODSEL boot, +--the map handling routines are in MAP BOOT and NEWMAP BOOT, and +--the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. +-- +--Conventions: +-- All spad values in the interpreter are passed around in triples. +-- These are lists of three items: [value,mode,environment]. The value +-- may be wrapped (this is a pair whose CAR is the atom WRAPPED and +-- whose CDR is the value), which indicates that it is a real value, +-- or unwrapped in which case it needs to be EVALed to produce the +-- proper value. The mode is the type of value, and should always be +-- completely specified (not contain $EmptyMode). The environment +-- is always empty, and is included for historical reasons. +-- +--Modemaps: +-- Modemaps are descriptions of compiled Spad function which the +-- interpreter uses to perform type analysis. They consist of patterns +-- of types for the arguments, and conditions the types must satisfy +-- for the function to apply. For each function name there is a list +-- of modemaps in file MODEMAP DATABASE for each distinct function with +-- that name. The following is the list of the modemaps for "*" +-- (multiplication. The first modemap (the one with the labels) is for +-- module mltiplication which is multiplication of an element of a +-- module by a member of its scalar domain. +-- +-- This is the signature pattern for the modemap, it is of the form: +-- (DomainOfComputation TargetType ) +-- | +-- | This is the predicate that needs to be +-- | satisfied for the modemap to apply +-- | | +-- V | +-- /-----------/ | +-- ( ( (*1 *1 *2 *1) V +-- /-----------------------------------------------------------/ +-- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) +-- . CATDEF) <-- This is the file where the function was defined +-- ( (*1 *1 *2 *1) +-- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) +-- . CATDEF) +-- ( (*1 *1 *2 *1) +-- ( (AND +-- (isDomain *2 (NonNegativeInteger)) +-- (ofCategory *1 (AbelianMonoid))) ) +-- . CATDEF) +-- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) +-- ) +-- +--Environments: +-- Environments associate properties with atoms. +-- (see CUTIL BOOT for the exact structure of environments). +-- Some common properties are: +-- modeSet: +-- During interpretation we build a modeSet property for each node in +-- the expression. This is (in theory) a list of all the types +-- possible for the node. In the current implementation these +-- modeSets always contain a single type. +-- value: +-- Value properties are always triples. This is where the values of +-- variables are stored. We also build value properties for internal +-- nodes during the bottom up phase. +-- mode: +-- This is the declared type of an identifier. +-- +-- There are several different environments used in the interpreter: +-- $InteractiveFrame : this is the environment where the user +-- values are stored. Any side effects of evaluation of a top-level +-- expression are stored in this environment. It is always used as +-- the starting environment for interpretation. +-- $e : This is the name used for $InteractiveFrame while interpreting. +-- $env : This is local environment used by the interpreter. +-- Only temporary information (such as types of local variables is +-- stored in $env. +-- It is thrown away after evaluation of each expression. +-- +--Frequently used global variables: +-- $genValue : if true then evaluate generated code, otherwise leave +-- code unevaluated. If $genValue is false then we are compiling. +-- $op: name of the top level operator (unused except in map printing) +-- $mapList: list of maps being type analyzed, used in recursive +-- map type anlysis. +-- $compilingMap: true when compiling a map, used to detect where to +-- THROW when interpret-only is invoked +-- $compilingLoop: true when compiling a loop body, used to control +-- nesting level of interp-only loop CATCH points +-- $interpOnly: true when in interpret only mode, used to call +-- alternate forms of COLLECT and REPEAT. +-- $inCOLLECT: true when compiling a COLLECT, used only for hacked +-- stream compiler. +-- $StreamFrame: used in printing streams, it is the environment +-- where local stream variables are stored +-- $declaredMode: Weak type propagation for symbols, set in upCOERCE +-- and upLET. This variable is used to determine +-- the alternate polynomial types of Symbols. +-- $localVars: list of local variables in a map body +-- $MapArgumentTypeList: hack for stream compilation diff --git a/src/interp/i-eval.boot.pamphlet b/src/interp/i-eval.boot.pamphlet deleted file mode 100644 index ed05090d..00000000 --- a/src/interp/i-eval.boot.pamphlet +++ /dev/null @@ -1,475 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-eval.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"i-analy" -)package "BOOT" - ---% Constructor Evaluation - -$noEvalTypeMsg := nil - -evalDomain form == - if $evalDomain then - sayMSG concat('" instantiating","%b",prefix2String form,"%d") - startTimingProcess 'instantiation - newType? form => form - result := eval mkEvalable form - stopTimingProcess 'instantiation - result - -mkEvalable form == - form is [op,:argl] => - op="QUOTE" => form - op="WRAPPED" => mkEvalable devaluate argl - op="Record" => mkEvalableRecord form - op="Union" => mkEvalableUnion form - op="Mapping"=> mkEvalableMapping form - op="Enumeration" => form - loadIfNecessary op - kind:= GETDATABASE(op,'CONSTRUCTORKIND) - cosig := GETDATABASE(op, 'COSIG) => - [op,:[val for x in argl for typeFlag in rest cosig]] where val() == - typeFlag => - kind = 'category => MKQ x - VECP x => MKQ x - loadIfNecessary x - mkEvalable x - x is ['QUOTE,:.] => x - x is ['_#,y] => ['SIZE,MKQ y] - MKQ x - [op,:[mkEvalable x for x in argl]] - form=$EmptyMode => $Integer - IDENTP form and constructor?(form) => [form] - FBPIP form => BPINAME form - form - -mkEvalableMapping form == - [first form,:[mkEvalable d for d in rest form]] - -mkEvalableRecord form == - [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] - -mkEvalableUnion form == - isTaggedUnion form => - [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] - [first form,:[mkEvalable d for d in rest form]] - -evaluateType0 form == - -- Takes a parsed, unabbreviated type and evaluates it, replacing - -- type valued variables with their values, and calling bottomUp - -- on non-type valued arguemnts to the constructor - -- and finally checking to see whether the type satisfies the - -- conditions of its modemap - -- However, the input might be an attribute, not a type - -- $noEvalTypeMsg: fluid := true - domain:= isDomainValuedVariable form => domain - form = $EmptyMode => form - form = "?" => $EmptyMode - STRINGP form => form - form = "$" => form - $expandSegments : local := nil - form is ['typeOf,.] => - form' := mkAtree form - bottomUp form' - objVal getValue(form') - form is [op,:argl] => - op='CATEGORY => - argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] - form - op in '(Join Mapping) => - [op,:[evaluateType arg for arg in argl]] - op='Union => - argl and first argl is [x,.,.] and member(x,'(_: Declare)) => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - [op,:[evaluateType arg for arg in argl]] - op='Record => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - op='Enumeration => form - constructor? op => evaluateType1 form - NIL - constructor? form => - ATOM form => evaluateType [form] - throwEvalTypeMsg("S2IE0003",[form,form]) - -evaluateType form == - -- Takes a parsed, unabbreviated type and evaluates it, replacing - -- type valued variables with their values, and calling bottomUp - -- on non-type valued arguemnts to the constructor - -- and finally checking to see whether the type satisfies the - -- conditions of its modemap - domain:= isDomainValuedVariable form => domain - form = $EmptyMode => form - form = "?" => $EmptyMode - STRINGP form => form - form = "$" => form - $expandSegments : local := nil - form is ['typeOf,.] => - form' := mkAtree form - bottomUp form' - objVal getValue(form') - form is [op,:argl] => - op='CATEGORY => - argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] - form - op in '(Join Mapping) => - [op,:[evaluateType arg for arg in argl]] - op='Union => - argl and first argl is [x,.,.] and member(x,'(_: Declare)) => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - [op,:[evaluateType arg for arg in argl]] - op='Record => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - op='Enumeration => form - evaluateType1 form - constructor? form => - ATOM form => evaluateType [form] - throwEvalTypeMsg("S2IE0003",[form,form]) - throwEvalTypeMsg("S2IE0004",[form]) - -evaluateType1 form == - --evaluates the arguments passed to a constructor - [op,:argl]:= form - constructor? op => - null (sig := getConstructorSignature form) => - throwEvalTypeMsg("S2IE0005",[form]) - [.,:ml] := sig - ml := replaceSharps(ml,form) - # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) - for x in argl for m in ml for argnum in 1.. repeat - typeList := [v,:typeList] where v() == - categoryForm?(m) => - m := evaluateType MSUBSTQ(x,'_$,m) - evalCategory(x' := (evaluateType x), m) => x' - throwEvalTypeMsg("S2IE0004",[form]) - m := evaluateType m - GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and - (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => - [zt,:zv]:= z1:= getAndEvalConstructorArgument tree - (v' := coerceOrRetract(z1,m)) => objValUnwrap v' - throwKeyedMsgCannotCoerceWithValue(zv,zt,m) - if x = $EmptyMode then x := $quadSymbol - throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) - [op,:NREVERSE typeList] - throwEvalTypeMsg("S2IE0007",[op]) - -throwEvalTypeMsg(msg, args) == - $noEvalTypeMsg => spadThrow() - throwKeyedMsg(msg, args) - -makeOrdinal i == - ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) - -evaluateSignature sig == - -- calls evaluateType on a signature - sig is [ ='SIGNATURE,fun,sigl] => - ['SIGNATURE,fun, - [(t = '_$ => t; evaluateType(t)) for t in sigl]] - sig - ---% Code Evaluation - --- This code generates, then evaluates code during the bottom up phase --- of interpretation - -splitIntoBlocksOf200 a == - null a => nil - [[first (r:=x) for x in tails a for i in 1..200], - :splitIntoBlocksOf200 rest r] - -evalForm(op,opName,argl,mmS) == - -- applies the first applicable function - for mm in mmS until form repeat - [sig,fun,cond]:= mm - (CAR sig) = 'interpOnly => form := CAR sig - #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 - form:= - $genValue or null cond => - [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL - for x in argl for t in CDDR sig] - [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL - for x in argl for t in CDDR sig for c in cond] - form or null argl => - dc:= CAR sig - form := - dc='local => --[fun,:form] - atom fun => - fun in $localVars => ['SPADCALL,:form,fun] - [fun,:form,NIL] - ['SPADCALL,:form,fun] - dc is ["__FreeFunction__",:freeFun] => - ['SPADCALL,:form,freeFun] - fun is ['XLAM,xargs,:xbody] => - rec := first form - xbody is [['RECORDELT,.,ind,len]] => - optRECORDELT([CAAR xbody,rec,ind,len]) - xbody is [['SETRECORDELT,.,ind,len,.]] => - optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) - xbody is [['RECORDCOPY,.,len]] => - optRECORDCOPY([CAAR xbody,rec,len]) - ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] - dcVector := evalDomain dc - fun0 := - newType? CAAR mm => - mm' := first ncSigTransform mm - ncGetFunction(opName, first mm', rest mm') - NRTcompileEvalForm(opName,fun,dcVector) - null fun0 => throwKeyedMsg("S2IE0008",[opName]) - [bpi,:domain] := fun0 - EQ(bpi,function Undef) => - sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) - NIL - if $NRTmonitorIfTrue = true then - sayBrightlyNT ['"Applying ",first fun0,'" to:"] - pp [devaluateDeeply x for x in form] - _$:fluid := domain - ['SPADCALL, :form, fun0] - not form => nil --- not form => throwKeyedMsg("S2IE0008",[opName]) - form='interpOnly => rewriteMap(op,opName,argl) - targetType := CADR sig - if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType - evalFormMkValue(op,form,targetType) - -sideEffectedArg?(t,sig,opName) == - opString := SYMBOL_-NAME opName - (opName ^= 'setelt) and (ELT(opString, #opString-1) ^= char '_!) => nil - dc := first sig - t = dc - -getArgValue(a, t) == - atom a and not VECP a => - t' := coerceOrRetract(getBasicObject a,t) - t' and wrapped2Quote objVal t' - v := getArgValue1(a, t) => v - alt := altTypeOf(objMode getValue a, a, nil) => - t' := coerceInt(getValue a, alt) - t' := coerceOrRetract(t',t) - t' and wrapped2Quote objVal t' - nil - -getArgValue1(a,t) == - -- creates a value for a, coercing to t - t' := getValue(a) => - (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and - objValUnwrap(t') is ['MAP,:.] => - getMappingArgValue(a,t,m) - t' := coerceOrRetract(t',t) - t' and wrapped2Quote objVal t' - systemErrorHere '"getArgValue" - -getArgValue2(a,t,se?,opName) == - se? and (objMode(getValue a) ^= t) => - throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t]) - getArgValue(a,t) - -getArgValueOrThrow(x, type) == - getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type]) - -getMappingArgValue(a,t,m is ['Mapping,:ml]) == - (una := getUnname a) in $localVars => - $genValue => - name := get(una,'name,$env) - a.0 := name - mmS := selectLocalMms(a,name,rest ml, nil) - or/[mm for mm in mmS | - (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] - NIL - una - mmS := selectLocalMms(a,una,rest ml, nil) - or/[mm for mm in mmS | - (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] - NIL - -getArgValueComp2(arg, type, cond, se?, opName) == - se? and (objMode(getValue arg) ^= type) => - throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type]) - getArgValueComp(arg, type, cond) - -getArgValueComp(arg,type,cond) == - -- getArgValue for compiled case. if there is a condition then - -- v must be data to verify that coerceInteractive succeeds. - v:= getArgValue(arg,type) - null v => nil - null cond => v - v is ['QUOTE,:.] or getBasicMode v => v - n := getUnnameIfCan arg - if num := isSharpVarWithNum n then - not $compilingMap => n := 'unknownVar - alias := get($mapName,'alias,$e) - n := alias.(num - 1) - keyedMsgCompFailure("S2IE0010",[n]) - -evalFormMkValue(op,form,tm) == - val:= - u:= - $genValue => wrap timedEVALFUN form - form - objNew(u,tm) ---+ - if $NRTmonitorIfTrue = true then - sayBrightlyNT ['"Value of ",op.0,'" ===> "] - pp unwrap u - putValue(op,val) - [tm] - -failCheck x == - x = '"failed" => - stopTimingProcess peekTimedName() - THROW('interpreter,objNewWrap('"failed",$String)) - x = $coerceFailure => - NIL - x - ---% Some Antique Comments About the Interpreter - ---EVAL BOOT contains the top level interface to the Scratchhpad-II ---interpreter. The Entry point into the interpreter from the parser is ---processInteractive. ---The type analysis algorithm is contained in the file BOTMUP BOOT, ---and MODSEL boot, ---the map handling routines are in MAP BOOT and NEWMAP BOOT, and ---the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. --- ---Conventions: --- All spad values in the interpreter are passed around in triples. --- These are lists of three items: [value,mode,environment]. The value --- may be wrapped (this is a pair whose CAR is the atom WRAPPED and --- whose CDR is the value), which indicates that it is a real value, --- or unwrapped in which case it needs to be EVALed to produce the --- proper value. The mode is the type of value, and should always be --- completely specified (not contain $EmptyMode). The environment --- is always empty, and is included for historical reasons. --- ---Modemaps: --- Modemaps are descriptions of compiled Spad function which the --- interpreter uses to perform type analysis. They consist of patterns --- of types for the arguments, and conditions the types must satisfy --- for the function to apply. For each function name there is a list --- of modemaps in file MODEMAP DATABASE for each distinct function with --- that name. The following is the list of the modemaps for "*" --- (multiplication. The first modemap (the one with the labels) is for --- module mltiplication which is multiplication of an element of a --- module by a member of its scalar domain. --- --- This is the signature pattern for the modemap, it is of the form: --- (DomainOfComputation TargetType ) --- | --- | This is the predicate that needs to be --- | satisfied for the modemap to apply --- | | --- V | --- /-----------/ | --- ( ( (*1 *1 *2 *1) V --- /-----------------------------------------------------------/ --- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) --- . CATDEF) <-- This is the file where the function was defined --- ( (*1 *1 *2 *1) --- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) --- . CATDEF) --- ( (*1 *1 *2 *1) --- ( (AND --- (isDomain *2 (NonNegativeInteger)) --- (ofCategory *1 (AbelianMonoid))) ) --- . CATDEF) --- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) --- ) --- ---Environments: --- Environments associate properties with atoms. --- (see CUTIL BOOT for the exact structure of environments). --- Some common properties are: --- modeSet: --- During interpretation we build a modeSet property for each node in --- the expression. This is (in theory) a list of all the types --- possible for the node. In the current implementation these --- modeSets always contain a single type. --- value: --- Value properties are always triples. This is where the values of --- variables are stored. We also build value properties for internal --- nodes during the bottom up phase. --- mode: --- This is the declared type of an identifier. --- --- There are several different environments used in the interpreter: --- $InteractiveFrame : this is the environment where the user --- values are stored. Any side effects of evaluation of a top-level --- expression are stored in this environment. It is always used as --- the starting environment for interpretation. --- $e : This is the name used for $InteractiveFrame while interpreting. --- $env : This is local environment used by the interpreter. --- Only temporary information (such as types of local variables is --- stored in $env. --- It is thrown away after evaluation of each expression. --- ---Frequently used global variables: --- $genValue : if true then evaluate generated code, otherwise leave --- code unevaluated. If $genValue is false then we are compiling. --- $op: name of the top level operator (unused except in map printing) --- $mapList: list of maps being type analyzed, used in recursive --- map type anlysis. --- $compilingMap: true when compiling a map, used to detect where to --- THROW when interpret-only is invoked --- $compilingLoop: true when compiling a loop body, used to control --- nesting level of interp-only loop CATCH points --- $interpOnly: true when in interpret only mode, used to call --- alternate forms of COLLECT and REPEAT. --- $inCOLLECT: true when compiling a COLLECT, used only for hacked --- stream compiler. --- $StreamFrame: used in printing streams, it is the environment --- where local stream variables are stored --- $declaredMode: Weak type propagation for symbols, set in upCOERCE --- and upLET. This variable is used to determine --- the alternate polynomial types of Symbols. --- $localVars: list of local variables in a map body --- $MapArgumentTypeList: hack for stream compilation -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot new file mode 100644 index 00000000..ee1202fd --- /dev/null +++ b/src/interp/i-funsel.boot @@ -0,0 +1,1769 @@ +-- 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. + + +import '"i-coerfn" +)package "BOOT" + +$constructorExposureList := '(Boolean Integer String) + +sayFunctionSelection(op,args,target,dc,func) == + $abbreviateTypes : local := true + startTimingProcess 'debug + fsig := formatSignatureArgs args + if not LISTP fsig then fsig := LIST fsig + if func then func := bright ['"by ",func] + sayMSG concat ['%l,:bright '"Function Selection for",op,:func,'%l, + '" Arguments:",:bright fsig] + if target then sayMSG concat ['" Target type:", + :bright prefix2String target] + if dc then sayMSG concat ['" From: ", + :bright prefix2String dc] + stopTimingProcess 'debug + +sayFunctionSelectionResult(op,args,mmS) == + $abbreviateTypes : local := true + startTimingProcess 'debug + if mmS then printMms mmS + else sayMSG concat ['" -> no function",:bright op, + '"found for arguments",:bright formatSignatureArgs args] + stopTimingProcess 'debug + +selectMms(op,args,$declaredMode) == + -- selects applicable modemaps for node op and arguments args + -- if there is no local modemap, and it is not a package call, then + -- the cached function selectMms1 is called + startTimingProcess 'modemaps + n:= getUnname op + val := getValue op + opMode := objMode val + + -- see if we have a functional parameter + ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and + opMode is ['Mapping,:ta] => + imp := + val => wrapped2Quote objVal val + n + [[['local,:ta], imp , NIL]] + + ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and + opMode is ['Variable,f] => + emptyAtree op + op.0 := f + selectMms(op,args,$declaredMode) + + isSharpVarWithNum(n) and opMode is ['FunctionCalled,f] => + op.0 := f + selectMms(op,args,$declaredMode) + + types1 := getOpArgTypes(n,args) + numArgs := #args + member('(SubDomain (Domain)),types1) => NIL + member('(Domain),types1) => NIL + member($EmptyMode,types1) => NIL + + tar := getTarget op + dc := getAtree(op,'dollar) + + null dc and val and objMode(val) = $AnonymousFunction => + tree := mkAtree objValUnwrap getValue op + putTarget(tree,['Mapping,tar,:types1]) + bottomUp tree + val := getValue tree + [[['local,:rest objMode val], wrapped2Quote objVal val, NIL]] + + if (n = 'map) and (first types1 = $AnonymousFunction) + then + tree := mkAtree objValUnwrap getValue first args + ut := + tar => underDomainOf tar + NIL + ua := [underDomainOf x for x in rest types1] + member(NIL,ua) => NIL + putTarget(tree,['Mapping,ut,:ua]) + bottomUp tree + val := getValue tree + types1 := [objMode val,:rest types1] + RPLACA(args,tree) + + if numArgs = 1 and (n = "numer" or n = "denom") and + isEqualOrSubDomain(first types1,$Integer) and null dc then + dc := ['Fraction, $Integer] + putAtree(op, 'dollar, dc) + + + if $reportBottomUpFlag then sayFunctionSelection(n,types1,tar,dc,NIL) + + identType := 'Variable + for x in types1 while not $declaredMode repeat + not EQCAR(x,identType) => $declaredMode:= x + types2 := [altTypeOf(x,y,$declaredMode) for x in types1 for y in args] + + mmS:= + dc => selectDollarMms(dc,n,types1,types2) + + if n = "/" and tar = $Integer then + tar := $RationalNumber + putTarget(op,tar) + + -- now to speed up some standard selections + if not tar then + tar := defaultTarget(op,n,#types1,types1) + if tar and $reportBottomUpFlag then + sayMSG concat ['" Default target type:", + :bright prefix2String tar] + + selectLocalMms(op,n,types1,tar) or + (VECTORP op and selectMms1(n,tar,types1,types2,'T)) + if $reportBottomUpFlag then sayFunctionSelectionResult(n,types1,mmS) + stopTimingProcess 'modemaps + mmS + +-- selectMms1 is in clammed.boot + +selectMms2(op,tar,args1,args2,$Coerce) == + -- decides whether to find functions from a domain or package + -- or by general modemap evaluation + or/[STRINGP arg for arg in args1] => NIL + if tar = $EmptyMode then tar := NIL + nargs := #args1 + mmS := NIL + mmS := + -- special case map for the time being + $Coerce and (op = 'map) and (2 = nargs) and + (first(args1) is ['Variable,fun]) => + null (ud := underDomainOf CADR args1) => NIL + if tar then ut := underDomainOf(tar) + else ut := nil + null (mapMms := selectMms1(fun,ut,[ud],[NIL],true)) => NIL + mapMm := CDAAR mapMms + selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], + [NIL,CADR args2],$Coerce) + + $Coerce and (op = 'map) and (2 = nargs) and + (first(args1) is ['FunctionCalled,fun]) => + null (ud := underDomainOf CADR args1) => NIL + if tar then ut := underDomainOf(tar) + else ut := nil + funNode := mkAtreeNode fun + transferPropsToNode(fun,funNode) + null (mapMms := selectLocalMms(funNode,fun,[ud],NIL)) => NIL + mapMm := CDAAR mapMms + selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], + [NIL,CADR args2],$Coerce) + + -- get the argument domains and the target + a := nil + for x in args1 repeat if x then a := cons(x,a) + for x in args2 repeat if x then a := cons(x,a) + if tar and not isPartialMode tar then a := cons(tar,a) + + -- for typically homogeneous functions, throw in resolve too + if op in '(_= _+ _* _- ) then + r := resolveTypeList a + if r ^= nil then a := cons(r,a) + + if tar and not isPartialMode tar then + if xx := underDomainOf(tar) then a := cons(xx,a) + for x in args1 repeat + PAIRP(x) and CAR(x) in '(List Vector Stream FiniteSet Array) => + xx := underDomainOf(x) => a := cons(xx,a) + + -- now extend this list with those from the arguments to + -- any Unions, Mapping or Records + + a' := nil + a := nreverse REMDUP a + for x in a repeat + null x => 'iterate + x = '(RationalRadicals) => a' := cons($RationalNumber,a') + x is ['Union,:l] => + -- check if we have a tagged union + l and first l is [":",:.] => + for [.,.,t] in l repeat + a' := cons(t,a') + a' := append(reverse l,a') + x is ['Mapping,:l] => a' := append(reverse l,a') + x is ['Record,:l] => + a' := append(reverse [CADDR s for s in l],a') + x is ['FunctionCalled,name] => + (xm := get(name,'mode,$e)) and not isPartialMode xm => + a' := cons(xm,a') + a := append(a,REMDUP a') + a := [x for x in a | PAIRP(x)] + + -- step 1. see if we have one without coercing + a' := a + while a repeat + x:= CAR a + a:= CDR a + ATOM x => 'iterate + mmS := append(mmS, findFunctionInDomain(op,x,tar,args1,args2,NIL,NIL)) + + -- step 2. if we didn't get one, trying coercing (if we are + -- suppose to) + + if null(mmS) and $Coerce then + a := a' + while a repeat + x:= CAR a + a:= CDR a + ATOM x => 'iterate + mmS := append(mmS, + findFunctionInDomain(op,x,tar,args1,args2,$Coerce,NIL)) + + mmS or selectMmsGen(op,tar,args1,args2) + mmS and orderMms(op, mmS,args1,args2,tar) + +isAVariableType t == + t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.] + +defaultTarget(opNode,op,nargs,args) == + -- this is for efficiency. Chooses standard targets for operations + -- when no target exists. + + target := nil + + nargs = 0 => + op = 'nil => + putTarget(opNode, target := '(List (None))) + target + op = 'true or op = 'false => + putTarget(opNode, target := $Boolean) + target + op = 'pi => + putTarget(opNode, target := ['Pi]) + target + op = 'infinity => + putTarget(opNode, target := ['OnePointCompletion, $Integer]) + target + member(op, '(plusInfinity minusInfinity)) => + putTarget(opNode, target := ['OrderedCompletion, $Integer]) + target + target + + a1 := CAR args + ATOM a1 => target + a1f := QCAR a1 + + nargs = 1 => + op = 'kernel => + putTarget(opNode, target := ['Kernel, ['Expression, $Integer]]) + target + op = 'list => + putTarget(opNode, target := ['List, a1]) + target + target + + a2 := CADR args + + nargs >= 2 and op = "draw" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => + + -- this clears up some confusion over 2D and 3D graphics + + symNode := mkAtreeNode sym + transferPropsToNode(sym,symNode) + + nargs >= 3 and CADDR args is ['Segment,.] => + selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) + putTarget(opNode, target := '(ThreeDimensionalViewport)) + target + + (mms := selectLocalMms(symNode,sym,[$DoubleFloat],NIL)) => + [.,targ,:.] := CAAR mms + targ = $DoubleFloat => + putTarget(opNode, target := '(TwoDimensionalViewport)) + target + targ = ['Point, $DoubleFloat] => + putTarget(opNode, target := '(ThreeDimensionalViewport)) + target + target + + target + + nargs >= 2 and op = "makeObject" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => + -- we won't actually bother to put a target on makeObject + -- this is just to figure out what the first arg is + symNode := mkAtreeNode sym + transferPropsToNode(sym,symNode) + + nargs >= 3 and CADDR args is ['Segment,.] => + selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) + target + + selectLocalMms(symNode,sym,[$DoubleFloat],NIL) + target + + nargs = 2 => + op = "elt" => + a1 = '(BasicOperator) and a2 is ['List, ['OrderedVariableList, .]] => + ['Expression, $Integer] + target + + op = "eval" => + a1 is ['Expression,b1] and a2 is ['Equation, ['Polynomial,b2]] => + target := + canCoerce(b2, a1) => a1 + t := resolveTT(b1, b2) + (not t) or (t = $Any) => nil + resolveTT(a1, t) + if target then putTarget(opNode, target) + target + a1 is ['Equation, .] and a2 is ['Equation, .] => + target := resolveTT(a1, a2) + if target and not (target = $Any) then putTarget(opNode,target) + else target := nil + target + a1 is ['Equation, .] and a2 is ['List, a2e] and a2e is ['Equation, .] => + target := resolveTT(a1, a2e) + if target and not (target = $Any) then putTarget(opNode,target) + else target := nil + target + a2 is ['Equation, a2e] or a2 is ['List, ['Equation, a2e]] => + target := resolveTT(a1, a2e) + if target and not (target = $Any) then putTarget(opNode,target) + else target := nil + target + + op = "**" or op = "^" => + a2 = $Integer => + if (target := resolveTCat(a1,'(Field))) then + putTarget(opNode,target) + target + a1 = '(AlgebraicNumber) and (a2 = $Float or a2 = $DoubleFloat) => + target := ['Expression, a2] + putTarget(opNode,target) + target + a1 = '(AlgebraicNumber) and a2 is ['Complex, a3] and (a3 = $Float or a3 = $DoubleFloat) => + target := ['Expression, a3] + putTarget(opNode,target) + target + ((a2 = $RationalNumber) and + (typeIsASmallInteger(a1) or isEqualOrSubDomain(a1,$Integer))) => + putTarget(opNode, target := '(AlgebraicNumber)) + target + ((a2 = $RationalNumber) and (isAVariableType(a1) + or a1 is ['Polynomial,.] or a1 is ['RationalFunction,.])) => + putTarget(opNode, target := defaultTargetFE a1) + target + isAVariableType(a1) and (a2 = $PositiveInteger or a2 = $NonNegativeInteger) => + putTarget(opNode, target := '(Polynomial (Integer))) + target + isAVariableType(a2) => + putTarget(opNode, target := defaultTargetFE a1) + target + a2 is ['Polynomial, D] => + (a1 = a2) or isAVariableType(a1) + or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D) + or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => + putTarget(opNode, target := defaultTargetFE a2) + target + target + a2 is ['RationalFunction, D] => + (a1 = a2) or isAVariableType(a1) + or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D) + or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => + putTarget(opNode, target := defaultTargetFE a2) + target + target + target + + op = "/" => + isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) => + putTarget(opNode, target := $RationalNumber) + target + a1 = a2 => + if (target := resolveTCat(CAR args,'(Field))) then + putTarget(opNode,target) + target + a1 is ['Variable,.] and a2 is ['Variable,.] => + putTarget(opNode,target := mkRationalFunction '(Integer)) + target + isEqualOrSubDomain(a1,$Integer) and a2 is ['Variable,.] => + putTarget(opNode,target := mkRationalFunction '(Integer)) + target + a1 is ['Variable,.] and + a2 is ['Polynomial,D] => + putTarget(opNode,target := mkRationalFunction D) + target + target + a2 is ['Variable,.] and + a1 is ['Polynomial,D] => + putTarget(opNode,target := mkRationalFunction D) + target + target + a2 is ['Polynomial,D] and (a1 = D) => + putTarget(opNode,target := mkRationalFunction D) + target + target + + a3 := CADDR args + nargs = 3 => + op = "eval" => + a3 is ['List, a3e] => + target := resolveTT(a1, a3e) + if not (target = $Any) then putTarget(opNode,target) + else target := nil + target + + target := resolveTT(a1, a3) + if not (target = $Any) then putTarget(opNode,target) + else target := nil + target + target + +mkRationalFunction D == ['Fraction, ['Polynomial, D]] + +defaultTargetFE(a,:options) == + a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a, + [QCAR $Symbol, 'RationalRadicals, + 'Pi]) or typeIsASmallInteger(a) or isEqualOrSubDomain(a, $Integer) or + a = '(AlgebraicNumber) => + IFCAR options => [$FunctionalExpression, ['Complex, $Integer]] + [$FunctionalExpression, $Integer] + a is ['Complex,uD] => defaultTargetFE(uD, true) + a is [D,uD] and MEMQ(D, '(Polynomial RationalFunction Fraction)) => + defaultTargetFE(uD, IFCAR options) + a is [=$FunctionalExpression,.] => a + IFCAR options => [$FunctionalExpression, ['Complex, a]] + [$FunctionalExpression, a] + +altTypeOf(type,val,$declaredMode) == + (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and + (a := getMinimalVarMode(objValUnwrap getValue(val),$declaredMode)) => + a + type is ['OrderedVariableList,vl] and + INTEGERP(val1 := objValUnwrap getValue(val)) and + (a := getMinimalVarMode(vl.(val1 - 1),$declaredMode)) => + a + type = $PositiveInteger => $Integer + type = $NonNegativeInteger => $Integer + type = '(List (PositiveInteger)) => '(List (Integer)) + NIL + +getOpArgTypes(opname, args) == + l := getOpArgTypes1(opname, args) + [f(a,opname) for a in l] where + f(x,op) == + x is ['FunctionCalled,g] and op ^= 'name => + m := get(g,'mode,$e) => + m is ['Mapping,:.] => m + x + x + x + +getOpArgTypes1(opname, args) == + null args => NIL + -- special cases first + opname = 'coef and args is [b,n] => + [CAR getModeSet b, CAR getModeSetUseSubdomain n] + opname = 'monom and args is [d,c] => + [CAR getModeSetUseSubdomain d,CAR getModeSet c] + opname = 'monom and args is [v,d,c] => + [CAR getModeSet v,CAR getModeSetUseSubdomain d,CAR getModeSet c] + (opname = 'cons) and (2 = #args) and (CADR(args) = 'nil) => + ms := [CAR getModeSet x for x in args] + if CADR(ms) = '(List (None)) then + ms := [first ms,['List,first ms]] + ms + nargs := #args + v := argCouldBelongToSubdomain(opname,nargs) + mss := NIL + for i in 0..(nargs-1) for x in args repeat + ms := + v.i = 0 => CAR getModeSet x + CAR getModeSetUseSubdomain x + mss := [ms,:mss] + nreverse mss + +argCouldBelongToSubdomain(op, nargs) == + -- this returns a vector containing 0 or ^0 for each argument. + -- if ^0, this indicates that there exists a modemap for the + -- op that needs a subdomain in that position + nargs = 0 => NIL + v := GETZEROVEC nargs + isMap(op) => v + mms := getModemapsFromDatabase(op,nargs) + null mms => v + nargs:=nargs-1 + -- each signature has form + -- [domain of implementation, target, arg1, arg2, ...] + for [sig,cond,:.] in mms repeat + for t in CDDR sig for i in 0..(nargs) repeat + CONTAINEDisDomain(t,cond) => + v.i := 1 + v.i + v + +CONTAINEDisDomain(symbol,cond) == +-- looks for [isSubDomain,symbol,[domain]] in cond: returning T or NIL +-- with domain being one of PositiveInteger and NonNegativeInteger + ATOM cond => false + MEMQ(QCAR cond,'(AND OR and or)) => + or/[CONTAINEDisDomain(symbol, u) for u in QCDR cond] + EQ(QCAR cond,'isDomain) => + EQ(symbol,CADR cond) and PAIRP(dom:=CADDR cond) and + MEMQ(dom,'(PositiveInteger NonNegativeInteger)) + false + +selectDollarMms(dc,name,types1,types2) == + -- finds functions for name in domain dc + isPartialMode dc => throwKeyedMsg("S2IF0001",NIL) + mmS := findFunctionInDomain(name,dc,NIL,types1,types2,'T,'T) => + orderMms(name, mmS,types1,types2,NIL) + if $reportBottomUpFlag then sayMSG + ["%b",'" function not found in ",prefix2String dc,"%d","%l"] + NIL + +selectLocalMms(op,name,types,tar) == + -- partial rewrite, looks now for exact local modemap + mmS:= getLocalMms(name,types,tar) => mmS + obj := getValue op + obj and (objVal obj is ['MAP,:mapDef]) and + analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) + +-- next defn may be better, test when more time. RSS 3/11/94 +-- selectLocalMms(op,name,types,tar) == +-- mmS := getLocalMms(name,types,tar) +-- -- if no target, just return what we got +-- mmS and null tar => mmS +-- matchingMms := nil +-- for mm in mmS repeat +-- [., targ, :.] := mm +-- if tar = targ then matchingMms := cons(mm, matchingMms) +-- -- if we got some exact matchs on the target, return them +-- matchingMms => nreverse matchingMms +-- +-- obj := getValue op +-- obj and (objVal obj is ['MAP,:mapDef]) and +-- analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) + +getLocalMms(name,types,tar) == + -- looks for exact or subsumed local modemap in $e + mmS := NIL + for (mm:=[dcSig,:.]) in get(name,'localModemap,$e) repeat + -- check format and destructure + dcSig isnt [dc,result,:args] => NIL + -- make number of args is correct + #types ^= #args => NIL + -- check for equal or subsumed arguments + subsume := (not $useIntegerSubdomain) or (tar = result) or + get(name,'recursive,$e) + acceptableArgs := + and/[f(b,a,subsume) for a in args for b in types] where + f(x,y,subsume) == + if subsume + then isEqualOrSubDomain(x,y) + else x = y + not acceptableArgs => + -- interpreted maps are ok + dc = 'interpOnly and not($Coerce)=> mmS := [mm,:mmS] + NIL + mmS := [mm,:mmS] + nreverse mmS + +mmCost(name, sig,cond,tar,args1,args2) == + cost := mmCost0(name, sig,cond,tar,args1,args2) + res := CADR sig + res = $PositiveInteger => cost - 2 + res = $NonNegativeInteger => cost - 1 + res = $DoubleFloat => cost + 1 + cost + +mmCost0(name, sig,cond,tar,args1,args2) == + sigArgs := CDDR sig + n:= + null cond => 1 + not (or/cond) => 1 + 0 + + -- try to favor homogeneous multiplication + +--if name = "*" and 2 = #sigArgs and first sigArgs ^= first rest sigArgs then n := n + 1 + + -- because of obscure problem in evalMm, sometimes we will have extra + -- modemaps with the wrong number of arguments if we want to the one + -- with no arguments and the name is overloaded. Thus check for this. + + if args1 then + for x1 in args1 for x2 in args2 for x3 in sigArgs repeat + n := n + + isEqualOrSubDomain(x1,x3) => 0 + topcon := first deconstructT x1 + topcon2 := first deconstructT x3 + topcon = topcon2 => 3 + CAR topcon2 = 'Mapping => 2 + 4 + else if sigArgs then n := n + 100000000000 + + res := CADR sig + res=tar => 10000*n + 10000*n + 1000*domainDepth(res) + hitListOfTarget(res) + +orderMms(name, mmS,args1,args2,tar) == + -- it counts the number of necessary coercions of the argument types + -- if this isn't enough, it compares the target types + mmS and null rest mmS => mmS + mS:= NIL + N:= NIL + for mm in MSORT mmS repeat + [sig,.,cond]:= mm + b:= 'T + p:= CONS(m := mmCost(name, sig,cond,tar,args1,args2),mm) + mS:= + null mS => list p + m < CAAR mS => CONS(p,mS) + S:= mS + until b repeat + b:= null CDR S or m < CAADR S => + RPLACD(S,CONS(p,CDR S)) + S:= CDR S + mS + mmS and [CDR p for p in mS] + +domainDepth(d) == + -- computes the depth of lisp structure d + atom d => 0 + MAX(domainDepth(CAR d)+1,domainDepth(CDR d)) + +hitListOfTarget(t) == + -- assigns a number between 1 and 998 to a type t + + -- want to make it hard to go to Polynomial Pi + + t = '(Polynomial (Pi)) => 90000 + + EQ(CAR t, 'Polynomial) => 300 + EQ(CAR t, 'List) => 400 + EQ(CAR t,'Matrix) => 910 + EQ(CAR t,'UniversalSegment) => 501 + EQ(CAR t,'RationalFunction) => 900 + EQ(CAR t,'Union) => 999 + EQ(CAR t,'Expression) => 1600 + 500 + +getFunctionFromDomain(op,dc,args) == + -- finds the function op with argument types args in dc + -- complains, if no function or ambiguous + $reportBottomUpFlag:local:= NIL + member(CAR dc,$nonLisplibDomains) => + throwKeyedMsg("S2IF0002",[CAR dc]) + not constructor? CAR dc => + throwKeyedMsg("S2IF0003",[CAR dc]) + p:= findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL) => +--+ + --sig := [NIL,:args] + domain := evalDomain dc + for mm in nreverse p until b repeat + [[.,:osig],nsig,:.] := mm + b := compiledLookup(op,nsig,domain) + b or throwKeyedMsg("S2IS0023",[op,dc]) + throwKeyedMsg("S2IF0004",[op,dc]) + +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 => + #args1 ^= 1 + dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> + [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] + args1.0 ^= dc => NIL + tar and tar ^= $Expression => NIL + [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] + member(dcName,'(Record Union)) => + findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) + NIL + fun:= NIL + ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and + SL := constructSubst dc + -- if the arglist is homogeneous, first look for homogeneous + -- functions. If we don't find any, look at remaining ones + if isHomogeneousList args1 then + q := NIL + r := NIL + for mm in CDR p repeat + -- CDAR of mm is the signature argument list + if isHomogeneousList CDAR mm then q := [mm,:q] + else r := [mm,:r] + q := allOrMatchingMms(q,args1,tar,dc) + for mm in q repeat + fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) + r := reverse r + else r := CDR p + r := allOrMatchingMms(r,args1,tar,dc) + if not fun then -- consider remaining modemaps + for mm in r repeat + fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) + if not fun and $reportBottomUpFlag then + sayMSG concat + ['" -> no appropriate",:bright op,'"found in", + :bright prefix2String dc] + fun + +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 := GETL(dcName,"makeFunctionList") or + systemErrorHere '"findFunctionInCategory" + [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) + -- get list of implementations and remove sharps + maxargs := -1 + impls := nil + for [a,b,d] in funlist repeat + not EQ(a,op) => nil + d is ['XLAM,xargs,:.] => + if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) + else maxargs := MAX(maxargs,1) + impls := cons([b,nil,true,d],impls) + impls := cons([b,d,true,d],impls) + impls := NREVERSE impls + if maxargs ^= -1 then + SL:= NIL + for i in 1..maxargs repeat + impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) + impls and + SL:= constructSubst dc + for mm in impls repeat + fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) + if not fun and $reportBottomUpFlag then + sayMSG concat + ['" -> no appropriate",:bright op,'"found in", + :bright prefix2String dc] + fun + +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) + 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) + 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 + 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] + 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 + +matchTypes(pm,args1,args2) == + -- pm is a list of pattern variables, args1 a list of argument types, + -- args2 a list of polynomial types for symbols + -- the result is a match from pm to args, if one exists + for v in pm for t1 in args1 for t2 in args2 until $Subst='failed repeat + p:= ASSQ(v,$Subst) => + t:= CDR p + t=t1 => $Coerce and EQCAR(t1,'Symbol) and + (q := ASSQ(v,$SymbolType)) and t2 and + (t3 := resolveTT(CDR q, t2)) and + RPLACD(q, t3) + $Coerce => + if EQCAR(t,'Symbol) and (q := ASSQ(v,$SymbolType)) then + t := CDR q + if EQCAR(t1,'Symbol) and t2 then t1:= t2 + t0 := resolveTT(t,t1) => RPLACD(p,t0) + $Subst:= 'failed + $Subst:= 'failed + $Subst:= CONS(CONS(v,t1),$Subst) + if EQCAR(t1,'Symbol) and t2 then $SymbolType:= CONS(CONS(v,t2),$SymbolType) + +evalMm(op,tar,sig,mmC) == + -- evaluates a modemap with signature sig and condition mmC + -- the result is a list of lists [sig,slot,cond] or NIL + --if $Coerce is NIL, tar has to be the same as the computed target type +--if CONTAINED('LinearlyExplicitRingOver,mmC) then hohoho() + mS:= NIL + for st in evalMmStack mmC repeat + SL:= evalMmCond(op,sig,st) + not EQ(SL,'failed) => + SL := fixUpTypeArgs SL + sig:= [subCopy(deepSubCopy(x,SL),$Subst) for x in sig] + not containsVars sig => + isFreeFunctionFromMmCond mmC and (m := evalMmFreeFunction(op,tar,sig,mmC)) => + mS:= nconc(m,mS) + "or"/[^isValidType(arg) for arg in sig] => nil + [dc,t,:args]:= sig + $Coerce or null tar or tar=t => + mS:= nconc(findFunctionInDomain(op,dc,t,args,args,NIL,'T),mS) + mS + +evalMmFreeFunction(op,tar,sig,mmC) == + [dc,t,:args]:= sig + $Coerce or null tar or tar=t => + nilArgs := nil + for a in args repeat nilArgs := [NIL,:nilArgs] + [[[["__FreeFunction__",:dc],t,:args], [t, :args], nilArgs]] + nil + +evalMmStack(mmC) == + -- translates the modemap condition mmC into a list of stacks + mmC is ['AND,:a] => + ["NCONC"/[evalMmStackInner cond for cond in a]] + mmC is ['OR,:args] => [:evalMmStack a for a in args] + mmC is ['partial,:mmD] => evalMmStack mmD + mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] => + evalMmStack CONS('AND,[['ofCategory,pvar,c] for c in args]) + mmC is ['ofType,:.] => [NIL] + mmC is ['has,pat,x] => + MEMQ(x,'(ATTRIBUTE SIGNATURE)) => + [[['ofCategory,pat,['CATEGORY,'unknown,x]]]] + [['ofCategory,pat,x]] + [[mmC]] + +evalMmStackInner(mmC) == + mmC is ['OR,:args] => + keyedSystemError("S2GE0016", + ['"evalMmStackInner",'"OR condition nested inside an AND"]) + mmC is ['partial,:mmD] => evalMmStackInner mmD + mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] => + [['ofCategory, pvar, c] for c in args] + mmC is ['ofType,:.] => NIL + mmC is ['isAsConstant] => NIL + mmC is ['has,pat,x] => + MEMQ(x,'(ATTRIBUTE SIGNATURE)) => + [['ofCategory,pat,['CATEGORY,'unknown,x]]] + [['ofCategory,pat,x]] + [mmC] + +evalMmCond(op,sig,st) == + $insideEvalMmCondIfTrue : local := true + evalMmCond0(op,sig,st) + +evalMmCond0(op,sig,st) == + -- evaluates the nonempty list of modemap conditions st + -- the result is either 'failed or a substitution list + SL:= evalMmDom st + SL='failed => 'failed + for p in SL until p1 and not b repeat b:= + p1:= ASSQ(CAR p,$Subst) + p1 and + t1:= CDR p1 + t:= CDR p + t=t1 or + containsVars t => + if $Coerce and EQCAR(t1,'Symbol) then t1:= getSymbolType CAR p + resolveTM1(t1,t) + $Coerce and + -- if we are looking at the result of a function, the coerce + -- goes the opposite direction + (t1 = $AnonymousFunction and t is ['Mapping, :.]) => t + CAR p = CADR sig and not member(CAR p, CDDR sig) => + canCoerceFrom(t,t1) => 'T + NIL + canCoerceFrom(t1,t) => 'T + isSubDomain(t,t1) => RPLACD(p,t1) + EQCAR(t1,'Symbol) and canCoerceFrom(getSymbolType CAR p,t) + ( SL and p1 and not b and 'failed ) or evalMmCat(op,sig,st,SL) + +fixUpTypeArgs SL == + for (p := [v, :t2]) in SL repeat + t1 := LASSOC(v, $Subst) + null t1 => RPLACD(p,replaceSharpCalls t2) + RPLACD(p, coerceTypeArgs(t1, t2, SL)) + SL + +replaceSharpCalls t == + noSharpCallsHere t => t + doReplaceSharpCalls t + +doReplaceSharpCalls t == + ATOM t => t + t is ['_#, l] => #l + t is ['construct,: l] => EVAL ['LIST,:l] + [CAR t,:[ doReplaceSharpCalls u for u in CDR t]] + +noSharpCallsHere t == + t isnt [con, :args] => true + MEMQ(con,'(construct _#)) => NIL + and/[noSharpCallsHere u for u in args] + +coerceTypeArgs(t1, t2, SL) == + -- if the type t has type-valued arguments, coerce them to the new types, + -- if needed. + t1 isnt [con1, :args1] or t2 isnt [con2, :args2] => t2 + con1 ^= con2 => t2 + coSig := CDR GETDATABASE(CAR t1, 'COSIG) + and/coSig => t2 + csub1 := constructSubst t1 + csub2 := constructSubst t2 + cs1 := CDR getConstructorSignature con1 + cs2 := CDR getConstructorSignature con2 + [con1, : + [makeConstrArg(arg1, arg2, constrArg(c1,csub1,SL), + constrArg(c2,csub2,SL), cs) + for arg1 in args1 for arg2 in args2 for c1 in cs1 for c2 in cs2 + for cs in coSig]] + +constrArg(v,sl,SL) == + x := LASSOC(v,sl) => + y := LASSOC(x,SL) => y + y := LASSOC(x, $Subst) => y + x + y := LASSOC(x, $Subst) => y + v + +makeConstrArg(arg1, arg2, t1, t2, cs) == + if arg1 is ['_#, l] then arg1 := # l + if arg2 is ['_#, l] then arg2 := # l + cs => arg2 + t1 = t2 => arg2 + obj1 := objNewWrap(arg1, t1) + obj2 := coerceInt(obj1, t2) + null obj2 => throwKeyedMsgCannotCoerceWithValue(wrap arg1,t1,t2) + objValUnwrap obj2 + +evalMmDom(st) == + -- evals all isDomain(v,d) of st + SL:= NIL + for mmC in st until SL='failed repeat + mmC is ['isDomain,v,d] => + STRINGP d => SL:= 'failed + p:= ASSQ(v,SL) and not (d=CDR p) => SL:= 'failed + d1:= subCopy(d,SL) + CONSP(d1) and MEMQ(v,d1) => SL:= 'failed + SL:= augmentSub(v,d1,SL) + mmC is ['isFreeFunction,v,fun] => + SL:= augmentSub(v,subCopy(fun,SL),SL) + SL + +orderMmCatStack st == + -- tries to reorder stack so that free pattern variables appear + -- as parameters first + null(st) or null rest(st) => st + vars := DELETE_-DUPLICATES [CADR(s) for s in st | isPatternVar(CADR(s))] + null vars => st + havevars := nil + haventvars := nil + for s in st repeat + cat := CADDR s + mem := nil + for v in vars while not mem repeat + if MEMQ(v,cat) then + mem := true + havevars := cons(s,havevars) + if not mem then haventvars := cons(s,haventvars) + null havevars => st + st := nreverse nconc(haventvars,havevars) + SORT(st, function mmCatComp) + +mmCatComp(c1, c2) == + b1 := ASSQ(CADR c1, $Subst) + b2 := ASSQ(CADR c2, $Subst) + b1 and null(b2) => true + false + +evalMmCat(op,sig,stack,SL) == + -- evaluates all ofCategory's of stack as soon as possible + $hope:local:= NIL + numConds:= #stack + stack:= orderMmCatStack [mmC for mmC in stack | EQCAR(mmC,'ofCategory)] + while stack until not makingProgress repeat + st := stack + stack := NIL + makingProgress := NIL + for mmC in st repeat + S:= evalMmCat1(mmC,op, SL) + S='failed and $hope => + stack:= CONS(mmC,stack) + S = 'failed => return S + not atom S => + makingProgress:= 'T + SL:= mergeSubs(S,SL) + if stack or S='failed then 'failed else SL + +evalMmCat1(mmC is ['ofCategory,d,c],op, SL) == + -- evaluates mmC using information from the lisplib + -- d may contain variables, and the substitution list $Subst is used + -- the result is a substitution or failed + $domPvar: local := NIL + $hope:= NIL + NSL:= hasCate(d,c,SL) + NSL='failed and isPatternVar d and $Coerce and ( p:= ASSQ(d,$Subst) ) + and (EQCAR(CDR p,'Variable) or EQCAR(CDR p,'Symbol)) => + RPLACD(p,getSymbolType d) + hasCate(d,c,SL) + NSL='failed and isPatternVar d => + -- following is hack to take care of the case where we have a + -- free substitution variable with a category condition on it. + -- This would arise, for example, where a package has an argument + -- that is not in a needed modemap. After making the following + -- dummy substitutions, the package can be instantiated and the + -- modemap used. RSS 12-22-85 + -- If c is not Set, Ring or Field then the more general mechanism + dom := defaultTypeForCategory(c, SL) + null dom => + op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) + null (p := ASSQ(d,$Subst)) => + dom => + NSL := [CONS(d,dom)] + op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) + if containsVars dom then dom := resolveTM(CDR p, dom) + $Coerce and canCoerce(CDR p, dom) => + NSL := [CONS(d,dom)] + op ^= 'coerce => 'failed -- evalMmCatLastChance(d,c,SL) + NSL + +hasCate(dom,cat,SL) == + -- asks whether dom has cat under SL + -- augments substitution SL or returns 'failed + dom = $EmptyMode => NIL + isPatternVar dom => + (p:= ASSQ(dom,SL)) and ((NSL := hasCate(CDR p,cat,SL)) ^= 'failed) => + NSL + (p:= ASSQ(dom,$Subst)) or (p := ASSQ(dom, SL)) => +-- S:= hasCate(CDR p,cat,augmentSub(CAR p,CDR p,copy SL)) + S:= hasCate1(CDR p,cat,SL, dom) + not (S='failed) => S + hasCateSpecial(dom,CDR p,cat,SL) + if SL ^= 'failed then $hope:= 'T + 'failed + SL1 := [[v,:d] for [v,:d] in SL | not containsVariables d] + if SL1 then cat := subCopy(cat, SL1) + hasCaty(dom,cat,SL) + +hasCate1(dom, cat, SL, domPvar) == + $domPvar:local := domPvar + hasCate(dom, cat, SL) + +hasCateSpecial(v,dom,cat,SL) == + -- v is a pattern variable, dom it's binding under $Subst + -- tries to change dom, so that it has category cat under SL + -- the result is a substitution list or 'failed + dom is ['FactoredForm,arg] => + if isSubDomain(arg,$Integer) then arg := $Integer + d := ['FactoredRing,arg] + SL:= hasCate(arg,'(Ring),augmentSub(v,d,SL)) + SL = 'failed => 'failed + hasCaty(d,cat,SL) + EQCAR(cat,'Field) or EQCAR(cat, 'DivisionRing) => + if isSubDomain(dom,$Integer) then dom := $Integer + d:= eqType [$QuotientField, dom] + hasCaty(dom,'(IntegralDomain),augmentSub(v,d,SL)) + cat is ['PolynomialCategory, d, :.] => + dom' := ['Polynomial, d] + (containsVars d or canCoerceFrom(dom, dom')) + and hasCaty(dom', cat, augmentSub(v,dom',SL)) + isSubDomain(dom,$Integer) => + NSL:= hasCate($Integer,cat,augmentSub(v,$Integer,SL)) + NSL = 'failed => + hasCateSpecialNew(v, dom, cat, SL) + hasCaty($Integer,cat,NSL) + hasCateSpecialNew(v, dom, cat, SL) + +-- to be used in $newSystem only +hasCateSpecialNew(v,dom,cat,SL) == + fe := member(QCAR cat, '(ElementaryFunctionCategory + TrigonometricFunctionCategory ArcTrigonometricFunctionCategory + HyperbolicFunctionCategory ArcHyperbolicFunctionCategory + PrimitiveFunctionCategory SpecialFunctionCategory Evalable + CombinatorialOpsCategory TranscendentalFunctionCategory + AlgebraicallyClosedFunctionSpace ExpressionSpace + LiouvillianFunctionCategory FunctionSpace)) + alg := member(QCAR cat, '(RadicalCategory AlgebraicallyClosedField)) + fefull := fe or alg or EQCAR(cat, 'CombinatorialFunctionCategory) + partialResult := + EQCAR(dom, 'Variable) or EQCAR(dom, 'Symbol) => + CAR(cat) in + '(SemiGroup AbelianSemiGroup Monoid AbelianGroup AbelianMonoid + PartialDifferentialRing Ring InputForm) => + d := ['Polynomial, $Integer] + augmentSub(v, d, SL) + EQCAR(cat, 'Group) => + d := ['Fraction, ['Polynomial, $Integer]] + augmentSub(v, d, SL) + fefull => + d := defaultTargetFE dom + augmentSub(v, d, SL) + 'failed + isEqualOrSubDomain(dom, $Integer) => + fe => + d := defaultTargetFE $Integer + augmentSub(v, d, SL) + alg => + d := '(AlgebraicNumber) + --d := defaultTargetFE $Integer + augmentSub(v, d, SL) + 'failed + underDomainOf dom = $ComplexInteger => + d := defaultTargetFE $ComplexInteger + hasCaty(d,cat,augmentSub(v, d, SL)) + (dom = $RationalNumber) and alg => + d := '(AlgebraicNumber) + --d := defaultTargetFE $Integer + augmentSub(v, d, SL) + fefull => + d := defaultTargetFE dom + augmentSub(v, d, SL) + 'failed + partialResult = 'failed => 'failed + hasCaty(d, cat, partialResult) + +hasCaty(d,cat,SL) == + -- calls hasCat, which looks up a hashtable and returns: + -- 1. T, NIL or a (has x1 x2) condition, if cat is not parameterized + -- 2. a list of pairs (argument to cat,condition) otherwise + -- then the substitution SL is augmented, or the result is 'failed + cat is ['CATEGORY,.,:y] => hasAttSig(d,subCopy(y,constructSubst d),SL) + cat is ['SIGNATURE,foo,sig] => + hasSig(d,foo,subCopy(sig,constructSubst d),SL) + cat is ['ATTRIBUTE,a] => hasAtt(d,subCopy(a,constructSubst d),SL) + x:= hasCat(opOf d,opOf cat) => + y:= KDR cat => + S := constructSubst d + for [z,:cond] in x until not (S1='failed) repeat + S' := [[p, :mkDomPvar(p, d, z, y)] for [p,:d] in S] + if $domPvar then + dom := [CAR d, :[domArg(arg, i, z, y) for i in 0.. + for arg in CDR d]] + SL := augmentSub($domPvar, dom, copy SL) + z' := [domArg2(a, S, S') for a in z] + S1:= unifyStruct(y,z',copy SL) + if not (S1='failed) then S1:= + atom cond => S1 + ncond := subCopy(cond, S) + ncond is ['has, =d, =cat] => 'failed + hasCaty1(ncond,S1) + S1 + atom x => SL + ncond := subCopy(x, constructSubst d) + ncond is ['has, =d, =cat] => 'failed + hasCaty1(ncond, SL) + 'failed + +mkDomPvar(p, d, subs, y) == + l := MEMQ(p, $FormalMapVariableList) => + domArg(d, #$FormalMapVariableList - #l, subs, y) + d + +domArg(type, i, subs, y) == + p := MEMQ($FormalMapVariableList.i, subs) => + y.(#subs - #p) + type + +domArg2(arg, SL1, SL2) == + isSharpVar arg => subCopy(arg, SL1) + arg = '_$ and $domPvar => $domPvar + subCopy(arg, SL2) + +hasCaty1(cond,SL) == + -- cond is either a (has a b) or an OR clause of such conditions + -- SL is augmented, if cond is true, otherwise the result is 'failed + $domPvar: local := NIL + cond is ['has,a,b] => hasCate(a,b,SL) + cond is ['AND,:args] => + for x in args while not (S='failed) repeat S:= + x is ['has,a,b] => hasCate(a,b, SL) + -- next line is for an obscure bug in the table + x is [['has,a,b]] => hasCate(a,b, SL) + --'failed + hasCaty1(x, SL) + S + cond is ['OR,:args] => + for x in args until not (S='failed) repeat S:= + x is ['has,a,b] => hasCate(a,b,copy SL) + -- next line is for an obscure bug in the table + x is [['has,a,b]] => hasCate(a,b,copy SL) + --'failed + hasCaty1(x, copy SL) + S + keyedSystemError("S2GE0016", + ['"hasCaty1",'"unexpected condition from category table"]) + +hasAttSig(d,x,SL) == + -- d is domain, x a list of attributes and signatures + -- the result is an augmented SL, if d has x, 'failed otherwise + for y in x until SL='failed repeat SL:= + y is ['ATTRIBUTE,a] => hasAtt(d,a,SL) + y is ['SIGNATURE,foo,s] => hasSig(d,foo,s,SL) + keyedSystemError("S2GE0016", + ['"hasAttSig",'"unexpected form of unnamed category"]) + SL + +hasSigAnd(andCls, S0, SL) == + dead := NIL + SA := 'failed + for cls in andCls while not dead repeat + SA := + atom cls => copy SL + cls is ['has,a,b] => + hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) + keyedSystemError("S2GE0016", + ['"hasSigAnd",'"unexpected condition for signature"]) + if SA = 'failed then dead := true + SA + +hasSigOr(orCls, S0, SL) == + found := NIL + SA := 'failed + for cls in orCls until found repeat + SA := + atom cls => copy SL + cls is ['has,a,b] => + hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) + cls is ['AND,:andCls] or cls is ['and,:andCls] => + hasSigAnd(andCls, S0, SL) + keyedSystemError("S2GE0016", + ['"hasSigOr",'"unexpected condition for signature"]) + if SA ^= 'failed then found := true + SA + +hasSig(dom,foo,sig,SL) == + -- tests whether domain dom has function foo with signature sig + -- under substitution SL + $domPvar: local := nil + fun:= constructor? CAR dom => + S0:= constructSubst dom + p := ASSQ(foo,getOperationAlistFromLisplib CAR dom) => + for [x,.,cond,.] in CDR p until not (S='failed) repeat + S:= + atom cond => copy SL + cond is ['has,a,b] => + hasCate(subCopy(a,S0),subCopy(b,S0),copy SL) + cond is ['AND,:andCls] or cond is ['and,:andCls] => + hasSigAnd(andCls, S0, SL) + cond is ['OR,:orCls] or cond is ['or,:orCls] => + hasSigOr(orCls, S0, SL) + keyedSystemError("S2GE0016", + ['"hasSig",'"unexpected condition for signature"]) + not (S='failed) => S:= unifyStruct(subCopy(x,S0),sig,S) + S + 'failed + 'failed + +hasAtt(dom,att,SL) == + -- tests whether dom has attribute att under SL + -- needs S0 similar to hasSig above ?? + $domPvar: local := nil + fun:= CAR dom => + atts:= subCopy(GETDATABASE(fun,'ATTRIBUTES),constructSubst dom) => + PAIRP (u := getInfovec CAR dom) => + --UGH! New world has attributes stored as pairs not as lists!! + for [x,:cond] in atts until not (S='failed) repeat + S:= unifyStruct(x,att,copy SL) + not atom cond and not (S='failed) => S := hasCatExpression(cond,S) + S + for [x,cond] in atts until not (S='failed) repeat + S:= unifyStruct(x,att,copy SL) + not atom cond and not (S='failed) => S := hasCatExpression(cond,S) + S + 'failed + 'failed + +hasCatExpression(cond,SL) == + cond is ["OR",:l] => + or/[(y:=hasCatExpression(x,SL)) ^= 'failed for x in l] => y + cond is ["AND",:l] => + and/[(SL:= hasCatExpression(x,SL)) ^= 'failed for x in l] => SL + cond is ["has",a,b] => hasCate(a,b,SL) + keyedSystemError("S2GE0016", + ['"hasSig",'"unexpected condition for attribute"]) + +unifyStruct(s1,s2,SL) == + -- tests for equality of s1 and s2 under substitutions SL and $Subst + -- the result is a substitution list or 'failed + s1=s2 => SL + if s1 is [":",x,.] then s1:= x + if s2 is [":",x,.] then s2:= x + if ^atom s1 and CAR s1 = '_# then s1:= LENGTH CADR s1 + if ^atom s2 and CAR s2 = '_# then s2:= LENGTH CADR s2 + s1=s2 => SL + isPatternVar s1 => unifyStructVar(s1,s2,SL) + isPatternVar s2 => unifyStructVar(s2,s1,SL) + atom s1 or atom s2 => 'failed + until null s1 or null s2 or SL='failed repeat + SL:= unifyStruct(CAR s1,CAR s2,SL) + s1:= CDR s1 + s2:= CDR s2 + s1 or s2 => 'failed + SL + +unifyStructVar(v,s,SL) == + -- the first argument is a pattern variable, which is not substituted + -- by SL + CONTAINED(v,s) => 'failed + ps := LASSOC(s, SL) + s1 := (ps => ps; s) + (s0 := LASSOC(v, SL)) or (s0 := LASSOC(v,$Subst)) => + S:= unifyStruct(s0,s1,copy SL) + S='failed => + $Coerce and not atom s0 and constructor? CAR s0 => + containsVars s0 or containsVars s1 => + ns0 := subCopy(s0, SL) + ns1 := subCopy(s1, SL) + containsVars ns0 or containsVars ns1 => + $hope:= 'T + 'failed + if canCoerce(ns0, ns1) then s3 := s1 + else if canCoerce(ns1, ns0) then s3 := s0 + else s3 := nil + s3 => + if (s3 ^= s0) then SL := augmentSub(v,s3,SL) + if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) + SL + 'failed + $domPvar => + s3 := resolveTT(s0,s1) + s3 => + if (s3 ^= s0) then SL := augmentSub(v,s3,SL) + if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) + SL + 'failed +-- isSubDomain(s,s0) => augmentSub(v,s0,SL) + 'failed + 'failed + augmentSub(v,s,S) + augmentSub(v,s,SL) + +ofCategory(dom,cat) == + -- entry point to category evaluation from other points than type + -- analysis + -- the result is true or NIL + $Subst:local:= NIL + $hope:local := NIL + IDENTP dom => NIL + cat is ['Join,:cats] => and/[ofCategory(dom,c) for c in cats] + (hasCaty(dom,cat,NIL) ^= 'failed) + +printMms(mmS) == + -- mmS a list of modemap signatures + sayMSG '" " + for [sig,imp,.] in mmS for i in 1.. repeat + istr := STRCONC('"[",STRINGIMAGE i,'"]") + if QCSIZE(istr) = 3 then istr := STRCONC(istr,'" ") + sayMSG [:bright istr,'"signature: ",:formatSignature CDR sig] + CAR sig='local => + sayMSG ['" implemented: local function ",imp] + imp is ['XLAM,:.] => + sayMSG concat('" implemented: XLAM from ", + prefix2String CAR sig) + sayMSG concat('" implemented: slot ",imp, + '" from ",prefix2String CAR sig) + sayMSG '" " + +containsVars(t) == + -- tests whether term t contains a * variable + atom t => isPatternVar t + containsVars1(t) + +containsVars1(t) == + -- recursive version, which works on a list + [t1,:t2]:= t + atom t1 => + isPatternVar t1 or + atom t2 => isPatternVar t2 + containsVars1(t2) + containsVars1(t1) or + atom t2 => isPatternVar t2 + containsVars1(t2) + +isPartialMode 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 + +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 + + diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet deleted file mode 100644 index 5f5d4278..00000000 --- a/src/interp/i-funsel.boot.pamphlet +++ /dev/null @@ -1,1822 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-funsel.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -New Selection of Modemaps - -selection of applicable modemaps is done in two steps: - first it tries to find a modemap inside an argument domain, and if - this fails, by evaluation of pattern modemaps -the result is a list of functions with signatures, which have the - following form: - [sig,elt,cond] where - sig is the signature gained by evaluating the modemap condition - elt is the slot number to get the implementation - cond are runtime checks which are the results of evaluating the - modemap condition - -the following flags are used: - $Coerce is NIL, if function selection is done which requires exact - matches (e.g. for coercion functions) - if $SubDom is true, then runtime checks have to be compiled -\end{verbatim} -\section{Functions} -\subsection{isPartialMode} -[[isPartialMode]] tests whether m contains [[$EmptyMode]]. The -constant [[$EmptyMode]] (defined in bootfuns.lisp) evaluates to -[[|$EmptyMode|]]. This constants is inserted in a modemap during -compile time if the modemap is not yet complete. -<>= -isPartialMode 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. - -@ -<<*>>= -<> - -import '"i-coerfn" -)package "BOOT" - -$constructorExposureList := '(Boolean Integer String) - -sayFunctionSelection(op,args,target,dc,func) == - $abbreviateTypes : local := true - startTimingProcess 'debug - fsig := formatSignatureArgs args - if not LISTP fsig then fsig := LIST fsig - if func then func := bright ['"by ",func] - sayMSG concat ['%l,:bright '"Function Selection for",op,:func,'%l, - '" Arguments:",:bright fsig] - if target then sayMSG concat ['" Target type:", - :bright prefix2String target] - if dc then sayMSG concat ['" From: ", - :bright prefix2String dc] - stopTimingProcess 'debug - -sayFunctionSelectionResult(op,args,mmS) == - $abbreviateTypes : local := true - startTimingProcess 'debug - if mmS then printMms mmS - else sayMSG concat ['" -> no function",:bright op, - '"found for arguments",:bright formatSignatureArgs args] - stopTimingProcess 'debug - -selectMms(op,args,$declaredMode) == - -- selects applicable modemaps for node op and arguments args - -- if there is no local modemap, and it is not a package call, then - -- the cached function selectMms1 is called - startTimingProcess 'modemaps - n:= getUnname op - val := getValue op - opMode := objMode val - - -- see if we have a functional parameter - ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and - opMode is ['Mapping,:ta] => - imp := - val => wrapped2Quote objVal val - n - [[['local,:ta], imp , NIL]] - - ((isSharpVarWithNum(n) and opMode) or (val and opMode)) and - opMode is ['Variable,f] => - emptyAtree op - op.0 := f - selectMms(op,args,$declaredMode) - - isSharpVarWithNum(n) and opMode is ['FunctionCalled,f] => - op.0 := f - selectMms(op,args,$declaredMode) - - types1 := getOpArgTypes(n,args) - numArgs := #args - member('(SubDomain (Domain)),types1) => NIL - member('(Domain),types1) => NIL - member($EmptyMode,types1) => NIL - - tar := getTarget op - dc := getAtree(op,'dollar) - - null dc and val and objMode(val) = $AnonymousFunction => - tree := mkAtree objValUnwrap getValue op - putTarget(tree,['Mapping,tar,:types1]) - bottomUp tree - val := getValue tree - [[['local,:rest objMode val], wrapped2Quote objVal val, NIL]] - - if (n = 'map) and (first types1 = $AnonymousFunction) - then - tree := mkAtree objValUnwrap getValue first args - ut := - tar => underDomainOf tar - NIL - ua := [underDomainOf x for x in rest types1] - member(NIL,ua) => NIL - putTarget(tree,['Mapping,ut,:ua]) - bottomUp tree - val := getValue tree - types1 := [objMode val,:rest types1] - RPLACA(args,tree) - - if numArgs = 1 and (n = "numer" or n = "denom") and - isEqualOrSubDomain(first types1,$Integer) and null dc then - dc := ['Fraction, $Integer] - putAtree(op, 'dollar, dc) - - - if $reportBottomUpFlag then sayFunctionSelection(n,types1,tar,dc,NIL) - - identType := 'Variable - for x in types1 while not $declaredMode repeat - not EQCAR(x,identType) => $declaredMode:= x - types2 := [altTypeOf(x,y,$declaredMode) for x in types1 for y in args] - - mmS:= - dc => selectDollarMms(dc,n,types1,types2) - - if n = "/" and tar = $Integer then - tar := $RationalNumber - putTarget(op,tar) - - -- now to speed up some standard selections - if not tar then - tar := defaultTarget(op,n,#types1,types1) - if tar and $reportBottomUpFlag then - sayMSG concat ['" Default target type:", - :bright prefix2String tar] - - selectLocalMms(op,n,types1,tar) or - (VECTORP op and selectMms1(n,tar,types1,types2,'T)) - if $reportBottomUpFlag then sayFunctionSelectionResult(n,types1,mmS) - stopTimingProcess 'modemaps - mmS - --- selectMms1 is in clammed.boot - -selectMms2(op,tar,args1,args2,$Coerce) == - -- decides whether to find functions from a domain or package - -- or by general modemap evaluation - or/[STRINGP arg for arg in args1] => NIL - if tar = $EmptyMode then tar := NIL - nargs := #args1 - mmS := NIL - mmS := - -- special case map for the time being - $Coerce and (op = 'map) and (2 = nargs) and - (first(args1) is ['Variable,fun]) => - null (ud := underDomainOf CADR args1) => NIL - if tar then ut := underDomainOf(tar) - else ut := nil - null (mapMms := selectMms1(fun,ut,[ud],[NIL],true)) => NIL - mapMm := CDAAR mapMms - selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], - [NIL,CADR args2],$Coerce) - - $Coerce and (op = 'map) and (2 = nargs) and - (first(args1) is ['FunctionCalled,fun]) => - null (ud := underDomainOf CADR args1) => NIL - if tar then ut := underDomainOf(tar) - else ut := nil - funNode := mkAtreeNode fun - transferPropsToNode(fun,funNode) - null (mapMms := selectLocalMms(funNode,fun,[ud],NIL)) => NIL - mapMm := CDAAR mapMms - selectMms1(op,tar,[['Mapping,:mapMm],CADR args1], - [NIL,CADR args2],$Coerce) - - -- get the argument domains and the target - a := nil - for x in args1 repeat if x then a := cons(x,a) - for x in args2 repeat if x then a := cons(x,a) - if tar and not isPartialMode tar then a := cons(tar,a) - - -- for typically homogeneous functions, throw in resolve too - if op in '(_= _+ _* _- ) then - r := resolveTypeList a - if r ^= nil then a := cons(r,a) - - if tar and not isPartialMode tar then - if xx := underDomainOf(tar) then a := cons(xx,a) - for x in args1 repeat - PAIRP(x) and CAR(x) in '(List Vector Stream FiniteSet Array) => - xx := underDomainOf(x) => a := cons(xx,a) - - -- now extend this list with those from the arguments to - -- any Unions, Mapping or Records - - a' := nil - a := nreverse REMDUP a - for x in a repeat - null x => 'iterate - x = '(RationalRadicals) => a' := cons($RationalNumber,a') - x is ['Union,:l] => - -- check if we have a tagged union - l and first l is [":",:.] => - for [.,.,t] in l repeat - a' := cons(t,a') - a' := append(reverse l,a') - x is ['Mapping,:l] => a' := append(reverse l,a') - x is ['Record,:l] => - a' := append(reverse [CADDR s for s in l],a') - x is ['FunctionCalled,name] => - (xm := get(name,'mode,$e)) and not isPartialMode xm => - a' := cons(xm,a') - a := append(a,REMDUP a') - a := [x for x in a | PAIRP(x)] - - -- step 1. see if we have one without coercing - a' := a - while a repeat - x:= CAR a - a:= CDR a - ATOM x => 'iterate - mmS := append(mmS, findFunctionInDomain(op,x,tar,args1,args2,NIL,NIL)) - - -- step 2. if we didn't get one, trying coercing (if we are - -- suppose to) - - if null(mmS) and $Coerce then - a := a' - while a repeat - x:= CAR a - a:= CDR a - ATOM x => 'iterate - mmS := append(mmS, - findFunctionInDomain(op,x,tar,args1,args2,$Coerce,NIL)) - - mmS or selectMmsGen(op,tar,args1,args2) - mmS and orderMms(op, mmS,args1,args2,tar) - -isAVariableType t == - t is ['Variable,.] or t = $Symbol or t is ['OrderedVariableList,.] - -defaultTarget(opNode,op,nargs,args) == - -- this is for efficiency. Chooses standard targets for operations - -- when no target exists. - - target := nil - - nargs = 0 => - op = 'nil => - putTarget(opNode, target := '(List (None))) - target - op = 'true or op = 'false => - putTarget(opNode, target := $Boolean) - target - op = 'pi => - putTarget(opNode, target := ['Pi]) - target - op = 'infinity => - putTarget(opNode, target := ['OnePointCompletion, $Integer]) - target - member(op, '(plusInfinity minusInfinity)) => - putTarget(opNode, target := ['OrderedCompletion, $Integer]) - target - target - - a1 := CAR args - ATOM a1 => target - a1f := QCAR a1 - - nargs = 1 => - op = 'kernel => - putTarget(opNode, target := ['Kernel, ['Expression, $Integer]]) - target - op = 'list => - putTarget(opNode, target := ['List, a1]) - target - target - - a2 := CADR args - - nargs >= 2 and op = "draw" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => - - -- this clears up some confusion over 2D and 3D graphics - - symNode := mkAtreeNode sym - transferPropsToNode(sym,symNode) - - nargs >= 3 and CADDR args is ['Segment,.] => - selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) - putTarget(opNode, target := '(ThreeDimensionalViewport)) - target - - (mms := selectLocalMms(symNode,sym,[$DoubleFloat],NIL)) => - [.,targ,:.] := CAAR mms - targ = $DoubleFloat => - putTarget(opNode, target := '(TwoDimensionalViewport)) - target - targ = ['Point, $DoubleFloat] => - putTarget(opNode, target := '(ThreeDimensionalViewport)) - target - target - - target - - nargs >= 2 and op = "makeObject" and a1 is ['FunctionCalled,sym] and a2 is ['Segment,.] => - -- we won't actually bother to put a target on makeObject - -- this is just to figure out what the first arg is - symNode := mkAtreeNode sym - transferPropsToNode(sym,symNode) - - nargs >= 3 and CADDR args is ['Segment,.] => - selectLocalMms(symNode,sym,[$DoubleFloat, $DoubleFloat],NIL) - target - - selectLocalMms(symNode,sym,[$DoubleFloat],NIL) - target - - nargs = 2 => - op = "elt" => - a1 = '(BasicOperator) and a2 is ['List, ['OrderedVariableList, .]] => - ['Expression, $Integer] - target - - op = "eval" => - a1 is ['Expression,b1] and a2 is ['Equation, ['Polynomial,b2]] => - target := - canCoerce(b2, a1) => a1 - t := resolveTT(b1, b2) - (not t) or (t = $Any) => nil - resolveTT(a1, t) - if target then putTarget(opNode, target) - target - a1 is ['Equation, .] and a2 is ['Equation, .] => - target := resolveTT(a1, a2) - if target and not (target = $Any) then putTarget(opNode,target) - else target := nil - target - a1 is ['Equation, .] and a2 is ['List, a2e] and a2e is ['Equation, .] => - target := resolveTT(a1, a2e) - if target and not (target = $Any) then putTarget(opNode,target) - else target := nil - target - a2 is ['Equation, a2e] or a2 is ['List, ['Equation, a2e]] => - target := resolveTT(a1, a2e) - if target and not (target = $Any) then putTarget(opNode,target) - else target := nil - target - - op = "**" or op = "^" => - a2 = $Integer => - if (target := resolveTCat(a1,'(Field))) then - putTarget(opNode,target) - target - a1 = '(AlgebraicNumber) and (a2 = $Float or a2 = $DoubleFloat) => - target := ['Expression, a2] - putTarget(opNode,target) - target - a1 = '(AlgebraicNumber) and a2 is ['Complex, a3] and (a3 = $Float or a3 = $DoubleFloat) => - target := ['Expression, a3] - putTarget(opNode,target) - target - ((a2 = $RationalNumber) and - (typeIsASmallInteger(a1) or isEqualOrSubDomain(a1,$Integer))) => - putTarget(opNode, target := '(AlgebraicNumber)) - target - ((a2 = $RationalNumber) and (isAVariableType(a1) - or a1 is ['Polynomial,.] or a1 is ['RationalFunction,.])) => - putTarget(opNode, target := defaultTargetFE a1) - target - isAVariableType(a1) and (a2 = $PositiveInteger or a2 = $NonNegativeInteger) => - putTarget(opNode, target := '(Polynomial (Integer))) - target - isAVariableType(a2) => - putTarget(opNode, target := defaultTargetFE a1) - target - a2 is ['Polynomial, D] => - (a1 = a2) or isAVariableType(a1) - or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D) - or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => - putTarget(opNode, target := defaultTargetFE a2) - target - target - a2 is ['RationalFunction, D] => - (a1 = a2) or isAVariableType(a1) - or ((a1 is ['RationalFunction, D1]) and (D1 = D)) or (a1 = D) - or ((a1 is [=$QuotientField, D1]) and (D1 = a1)) => - putTarget(opNode, target := defaultTargetFE a2) - target - target - target - - op = "/" => - isEqualOrSubDomain(a1, $Integer) and isEqualOrSubDomain(a2, $Integer) => - putTarget(opNode, target := $RationalNumber) - target - a1 = a2 => - if (target := resolveTCat(CAR args,'(Field))) then - putTarget(opNode,target) - target - a1 is ['Variable,.] and a2 is ['Variable,.] => - putTarget(opNode,target := mkRationalFunction '(Integer)) - target - isEqualOrSubDomain(a1,$Integer) and a2 is ['Variable,.] => - putTarget(opNode,target := mkRationalFunction '(Integer)) - target - a1 is ['Variable,.] and - a2 is ['Polynomial,D] => - putTarget(opNode,target := mkRationalFunction D) - target - target - a2 is ['Variable,.] and - a1 is ['Polynomial,D] => - putTarget(opNode,target := mkRationalFunction D) - target - target - a2 is ['Polynomial,D] and (a1 = D) => - putTarget(opNode,target := mkRationalFunction D) - target - target - - a3 := CADDR args - nargs = 3 => - op = "eval" => - a3 is ['List, a3e] => - target := resolveTT(a1, a3e) - if not (target = $Any) then putTarget(opNode,target) - else target := nil - target - - target := resolveTT(a1, a3) - if not (target = $Any) then putTarget(opNode,target) - else target := nil - target - target - -mkRationalFunction D == ['Fraction, ['Polynomial, D]] - -defaultTargetFE(a,:options) == - a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a, - [QCAR $Symbol, 'RationalRadicals, - 'Pi]) or typeIsASmallInteger(a) or isEqualOrSubDomain(a, $Integer) or - a = '(AlgebraicNumber) => - IFCAR options => [$FunctionalExpression, ['Complex, $Integer]] - [$FunctionalExpression, $Integer] - a is ['Complex,uD] => defaultTargetFE(uD, true) - a is [D,uD] and MEMQ(D, '(Polynomial RationalFunction Fraction)) => - defaultTargetFE(uD, IFCAR options) - a is [=$FunctionalExpression,.] => a - IFCAR options => [$FunctionalExpression, ['Complex, a]] - [$FunctionalExpression, a] - -altTypeOf(type,val,$declaredMode) == - (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and - (a := getMinimalVarMode(objValUnwrap getValue(val),$declaredMode)) => - a - type is ['OrderedVariableList,vl] and - INTEGERP(val1 := objValUnwrap getValue(val)) and - (a := getMinimalVarMode(vl.(val1 - 1),$declaredMode)) => - a - type = $PositiveInteger => $Integer - type = $NonNegativeInteger => $Integer - type = '(List (PositiveInteger)) => '(List (Integer)) - NIL - -getOpArgTypes(opname, args) == - l := getOpArgTypes1(opname, args) - [f(a,opname) for a in l] where - f(x,op) == - x is ['FunctionCalled,g] and op ^= 'name => - m := get(g,'mode,$e) => - m is ['Mapping,:.] => m - x - x - x - -getOpArgTypes1(opname, args) == - null args => NIL - -- special cases first - opname = 'coef and args is [b,n] => - [CAR getModeSet b, CAR getModeSetUseSubdomain n] - opname = 'monom and args is [d,c] => - [CAR getModeSetUseSubdomain d,CAR getModeSet c] - opname = 'monom and args is [v,d,c] => - [CAR getModeSet v,CAR getModeSetUseSubdomain d,CAR getModeSet c] - (opname = 'cons) and (2 = #args) and (CADR(args) = 'nil) => - ms := [CAR getModeSet x for x in args] - if CADR(ms) = '(List (None)) then - ms := [first ms,['List,first ms]] - ms - nargs := #args - v := argCouldBelongToSubdomain(opname,nargs) - mss := NIL - for i in 0..(nargs-1) for x in args repeat - ms := - v.i = 0 => CAR getModeSet x - CAR getModeSetUseSubdomain x - mss := [ms,:mss] - nreverse mss - -argCouldBelongToSubdomain(op, nargs) == - -- this returns a vector containing 0 or ^0 for each argument. - -- if ^0, this indicates that there exists a modemap for the - -- op that needs a subdomain in that position - nargs = 0 => NIL - v := GETZEROVEC nargs - isMap(op) => v - mms := getModemapsFromDatabase(op,nargs) - null mms => v - nargs:=nargs-1 - -- each signature has form - -- [domain of implementation, target, arg1, arg2, ...] - for [sig,cond,:.] in mms repeat - for t in CDDR sig for i in 0..(nargs) repeat - CONTAINEDisDomain(t,cond) => - v.i := 1 + v.i - v - -CONTAINEDisDomain(symbol,cond) == --- looks for [isSubDomain,symbol,[domain]] in cond: returning T or NIL --- with domain being one of PositiveInteger and NonNegativeInteger - ATOM cond => false - MEMQ(QCAR cond,'(AND OR and or)) => - or/[CONTAINEDisDomain(symbol, u) for u in QCDR cond] - EQ(QCAR cond,'isDomain) => - EQ(symbol,CADR cond) and PAIRP(dom:=CADDR cond) and - MEMQ(dom,'(PositiveInteger NonNegativeInteger)) - false - -selectDollarMms(dc,name,types1,types2) == - -- finds functions for name in domain dc - isPartialMode dc => throwKeyedMsg("S2IF0001",NIL) - mmS := findFunctionInDomain(name,dc,NIL,types1,types2,'T,'T) => - orderMms(name, mmS,types1,types2,NIL) - if $reportBottomUpFlag then sayMSG - ["%b",'" function not found in ",prefix2String dc,"%d","%l"] - NIL - -selectLocalMms(op,name,types,tar) == - -- partial rewrite, looks now for exact local modemap - mmS:= getLocalMms(name,types,tar) => mmS - obj := getValue op - obj and (objVal obj is ['MAP,:mapDef]) and - analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) - --- next defn may be better, test when more time. RSS 3/11/94 --- selectLocalMms(op,name,types,tar) == --- mmS := getLocalMms(name,types,tar) --- -- if no target, just return what we got --- mmS and null tar => mmS --- matchingMms := nil --- for mm in mmS repeat --- [., targ, :.] := mm --- if tar = targ then matchingMms := cons(mm, matchingMms) --- -- if we got some exact matchs on the target, return them --- matchingMms => nreverse matchingMms --- --- obj := getValue op --- obj and (objVal obj is ['MAP,:mapDef]) and --- analyzeMap(op,types,mapDef,tar) and getLocalMms(name,types,tar) - -getLocalMms(name,types,tar) == - -- looks for exact or subsumed local modemap in $e - mmS := NIL - for (mm:=[dcSig,:.]) in get(name,'localModemap,$e) repeat - -- check format and destructure - dcSig isnt [dc,result,:args] => NIL - -- make number of args is correct - #types ^= #args => NIL - -- check for equal or subsumed arguments - subsume := (not $useIntegerSubdomain) or (tar = result) or - get(name,'recursive,$e) - acceptableArgs := - and/[f(b,a,subsume) for a in args for b in types] where - f(x,y,subsume) == - if subsume - then isEqualOrSubDomain(x,y) - else x = y - not acceptableArgs => - -- interpreted maps are ok - dc = 'interpOnly and not($Coerce)=> mmS := [mm,:mmS] - NIL - mmS := [mm,:mmS] - nreverse mmS - -mmCost(name, sig,cond,tar,args1,args2) == - cost := mmCost0(name, sig,cond,tar,args1,args2) - res := CADR sig - res = $PositiveInteger => cost - 2 - res = $NonNegativeInteger => cost - 1 - res = $DoubleFloat => cost + 1 - cost - -mmCost0(name, sig,cond,tar,args1,args2) == - sigArgs := CDDR sig - n:= - null cond => 1 - not (or/cond) => 1 - 0 - - -- try to favor homogeneous multiplication - ---if name = "*" and 2 = #sigArgs and first sigArgs ^= first rest sigArgs then n := n + 1 - - -- because of obscure problem in evalMm, sometimes we will have extra - -- modemaps with the wrong number of arguments if we want to the one - -- with no arguments and the name is overloaded. Thus check for this. - - if args1 then - for x1 in args1 for x2 in args2 for x3 in sigArgs repeat - n := n + - isEqualOrSubDomain(x1,x3) => 0 - topcon := first deconstructT x1 - topcon2 := first deconstructT x3 - topcon = topcon2 => 3 - CAR topcon2 = 'Mapping => 2 - 4 - else if sigArgs then n := n + 100000000000 - - res := CADR sig - res=tar => 10000*n - 10000*n + 1000*domainDepth(res) + hitListOfTarget(res) - -orderMms(name, mmS,args1,args2,tar) == - -- it counts the number of necessary coercions of the argument types - -- if this isn't enough, it compares the target types - mmS and null rest mmS => mmS - mS:= NIL - N:= NIL - for mm in MSORT mmS repeat - [sig,.,cond]:= mm - b:= 'T - p:= CONS(m := mmCost(name, sig,cond,tar,args1,args2),mm) - mS:= - null mS => list p - m < CAAR mS => CONS(p,mS) - S:= mS - until b repeat - b:= null CDR S or m < CAADR S => - RPLACD(S,CONS(p,CDR S)) - S:= CDR S - mS - mmS and [CDR p for p in mS] - -domainDepth(d) == - -- computes the depth of lisp structure d - atom d => 0 - MAX(domainDepth(CAR d)+1,domainDepth(CDR d)) - -hitListOfTarget(t) == - -- assigns a number between 1 and 998 to a type t - - -- want to make it hard to go to Polynomial Pi - - t = '(Polynomial (Pi)) => 90000 - - EQ(CAR t, 'Polynomial) => 300 - EQ(CAR t, 'List) => 400 - EQ(CAR t,'Matrix) => 910 - EQ(CAR t,'UniversalSegment) => 501 - EQ(CAR t,'RationalFunction) => 900 - EQ(CAR t,'Union) => 999 - EQ(CAR t,'Expression) => 1600 - 500 - -getFunctionFromDomain(op,dc,args) == - -- finds the function op with argument types args in dc - -- complains, if no function or ambiguous - $reportBottomUpFlag:local:= NIL - member(CAR dc,$nonLisplibDomains) => - throwKeyedMsg("S2IF0002",[CAR dc]) - not constructor? CAR dc => - throwKeyedMsg("S2IF0003",[CAR dc]) - p:= findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL) => ---+ - --sig := [NIL,:args] - domain := evalDomain dc - for mm in nreverse p until b repeat - [[.,:osig],nsig,:.] := mm - b := compiledLookup(op,nsig,domain) - b or throwKeyedMsg("S2IS0023",[op,dc]) - throwKeyedMsg("S2IF0004",[op,dc]) - -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 => - #args1 ^= 1 - dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> - [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] - args1.0 ^= dc => NIL - tar and tar ^= $Expression => NIL - [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] - member(dcName,'(Record Union)) => - findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) - NIL - fun:= NIL - ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and - SL := constructSubst dc - -- if the arglist is homogeneous, first look for homogeneous - -- functions. If we don't find any, look at remaining ones - if isHomogeneousList args1 then - q := NIL - r := NIL - for mm in CDR p repeat - -- CDAR of mm is the signature argument list - if isHomogeneousList CDAR mm then q := [mm,:q] - else r := [mm,:r] - q := allOrMatchingMms(q,args1,tar,dc) - for mm in q repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - r := reverse r - else r := CDR p - r := allOrMatchingMms(r,args1,tar,dc) - if not fun then -- consider remaining modemaps - for mm in r repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - if not fun and $reportBottomUpFlag then - sayMSG concat - ['" -> no appropriate",:bright op,'"found in", - :bright prefix2String dc] - fun - -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 := GETL(dcName,"makeFunctionList") or - systemErrorHere '"findFunctionInCategory" - [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) - -- get list of implementations and remove sharps - maxargs := -1 - impls := nil - for [a,b,d] in funlist repeat - not EQ(a,op) => nil - d is ['XLAM,xargs,:.] => - if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) - else maxargs := MAX(maxargs,1) - impls := cons([b,nil,true,d],impls) - impls := cons([b,d,true,d],impls) - impls := NREVERSE impls - if maxargs ^= -1 then - SL:= NIL - for i in 1..maxargs repeat - impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) - impls and - SL:= constructSubst dc - for mm in impls repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - if not fun and $reportBottomUpFlag then - sayMSG concat - ['" -> no appropriate",:bright op,'"found in", - :bright prefix2String dc] - fun - -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) - 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) - 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 - 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] - 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 - -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-intern.boot b/src/interp/i-intern.boot new file mode 100644 index 00000000..c2cd8a84 --- /dev/null +++ b/src/interp/i-intern.boot @@ -0,0 +1,455 @@ +-- 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. + + +import '"i-object" +import '"ptrees" +)package "BOOT" + +$useParserSrcPos := NIL +$transferParserSrcPos := NIL + +-- Making Trees + +mkAtree x == + -- maker of attrib tree from parser form + mkAtree1 mkAtreeExpandMacros x + +mkAtreeWithSrcPos(form, posnForm) == + posnForm and $useParserSrcPos => pf2Atree(posnForm) + transferSrcPosInfo(posnForm, mkAtree form) + +mkAtree1WithSrcPos(form, posnForm) == + transferSrcPosInfo(posnForm, mkAtree1 form) + +mkAtreeNodeWithSrcPos(form, posnForm) == + transferSrcPosInfo(posnForm, mkAtreeNode form) + +transferSrcPosInfo(pf, atree) == + not (pf and $transferParserSrcPos) => atree + pos := pfPosOrNopos(pf) + pfNoPosition?(pos) => atree + + -- following is a hack because parser code for getting filename + -- seems wrong. + fn := lnPlaceOfOrigin poGetLineObject(pos) + if NULL fn or fn = '"strings" then fn := '"console" + + putSrcPos(atree, fn, pfSourceText(pf), pfLinePosn(pos), pfCharPosn(pos)) + atree + +mkAtreeExpandMacros x == + -- handle macro expansion. if the macros have args we require that + -- we match the correct number of args + if x isnt ["MDEF",:.] and x isnt ["DEF",["macro",:.],:.] then + atom x and (m := isInterpMacro x) => + [args,:body] := m + args => "doNothing" + x := body + x is [op,:argl] => + op = "QUOTE" => "doNothing" + op = "where" and argl is [before,after] => + -- in a where clause, what follows "where" (the "after" parm + -- above) might be a local macro, so do not expand the "before" + -- part yet + x := [op,before,mkAtreeExpandMacros after] + argl := [mkAtreeExpandMacros a for a in argl] + (m := isInterpMacro op) => + [args,:body] := m + #args = #argl => + sl := [[a,:s] for a in args for s in argl] + x := SUBLISNQ(sl,body) + null args => x := [body,:argl] + x := [op,:argl] + x := [mkAtreeExpandMacros op,:argl] + x + +mkAtree1 x == + -- first special handler for making attrib tree + null x => throwKeyedMsg("S2IP0005",['"NIL"]) + VECP x => x + atom x => + x in '(noBranch noMapVal) => x + x in '(nil true false) => mkAtree2([x],x,NIL) + x = '_/throwAway => + -- don't want to actually compute this + tree := mkAtree1 '(void) + putValue(tree,objNewWrap(voidValue(),$Void)) + putModeSet(tree,[$Void]) + tree + getBasicMode x => + v := mkAtreeNode $immediateDataSymbol + putValue(v,getBasicObject x) + v + IDENTP x => mkAtreeNode x + keyedSystemError("S2II0002",[x]) + x is [op,:argl] => mkAtree2(x,op,argl) + systemErrorHere '"mkAtree1" + +-- mkAtree2 and mkAtree3 were created because mkAtree1 got so big + +mkAtree2(x,op,argl) == + nargl := #argl + (op= "-") and (nargl = 1) and (INTEGERP CAR argl) => + mkAtree1(MINUS CAR argl) + op=":" and argl is [y,z] => [mkAtreeNode "Declare",:argl] + op="COLLECT" => [mkAtreeNode op,:transformCollect argl] + op= "break" => + argl is [.,val] => + if val = '$NoValue then val := '(void) + [mkAtreeNode op,mkAtree1 val] + [mkAtreeNode op,mkAtree1 '(void)] + op= "return" => + argl is [val] => + if val = '$NoValue then val := '(void) + [mkAtreeNode op,mkAtree1 val] + [mkAtreeNode op,mkAtree1 '(void)] + op="exit" => mkAtree1 CADR argl + op = "QUOTE" => [mkAtreeNode op,:argl] + op="SEGMENT" => + argl is [a] => [mkAtreeNode op, mkAtree1 a] + z := + null argl.1 => nil + mkAtree1 argl.1 + [mkAtreeNode op, mkAtree1 argl.0,z] + op in '(pretend is isnt) => + [mkAtreeNode op,mkAtree1 first argl,:rest argl] + op = "::" => + [mkAtreeNode "COERCE",mkAtree1 first argl,CADR argl] + x is ["@", expr, type] => + t := evaluateType unabbrev type + t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] => + mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args] + t = '(DoubleFloat) and INTEGERP expr => + v := mkAtreeNode $immediateDataSymbol + putValue(v,getBasicObject float expr) + v + t = '(Float) and INTEGERP expr => + mkAtree1 ["::", expr, t] + typeIsASmallInteger(t) and INTEGERP expr => + mkAtree1 ["::", expr, t] + [mkAtreeNode 'TARGET,mkAtree1 expr, type] + (op="case") and (nargl = 2) => + [mkAtreeNode "case",mkAtree1 first argl,unabbrev CADR argl] + op="REPEAT" => [mkAtreeNode op,:transformREPEAT argl] + op="LET" and argl is [['construct,:.],rhs] => + [mkAtreeNode "LET",first argl,mkAtree1 rhs] + op="LET" and argl is [[":",a,.],rhs] => + mkAtree1 ["SEQ",first argl,["LET",a,rhs]] + op is ['_$elt,D,op1] => + op1 is "=" => + a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]] + [mkAtreeNode "Dollar",D,a'] + [mkAtreeNode "Dollar",D,mkAtree1 [op1,:argl]] + op='_$elt => + argl is [D,a] => + INTEGERP a => + a = 0 => mkAtree1 [['_$elt,D,'Zero]] + a = 1 => mkAtree1 [['_$elt,D,'One]] + t := evaluateType unabbrev [D] + typeIsASmallInteger(t) and SINTP a => + v := mkAtreeNode $immediateDataSymbol + putValue(v,objNewWrap(a, t)) + v + mkAtree1 ["*",a,[['_$elt,D,'One]]] + [mkAtreeNode "Dollar",D,mkAtree1 a] + keyedSystemError("S2II0003",['"$",argl, + '"not qualifying an operator"]) + mkAtree3(x,op,argl) + +mkAtree3(x,op,argl) == + op="REDUCE" and argl is [op1,axis,body] => + [mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body] + op="has" => [mkAtreeNode op, :argl] + op="|" => [mkAtreeNode "AlgExtension",:[mkAtree1 arg for arg in argl]] + op="=" => [mkAtreeNode "equation",:[mkAtree1 arg for arg in argl]] + op="not" and argl is [["=",lhs,rhs]] => + [mkAtreeNode "not",[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]] + op="in" and argl is [var ,["SEGMENT",lb,ul]] => + upTest:= + null ul => NIL + mkLessOrEqual(var,ul) + lowTest:=mkLessOrEqual(lb,var) + z := + ul => ['and,lowTest,upTest] + lowTest + mkAtree1 z + x is ["IF",p,"noBranch",a] => mkAtree1 ["IF",["not",p],a,"noBranch"] + x is ["RULEDEF",:.] => [mkAtreeNode "RULEDEF",:CDR x] + x is ["MDEF",sym,junk1,junk2,val] => + -- new macros look like macro f == or macro f(x) === + -- so transform into that format + mkAtree1 ["DEF",["macro",sym],junk1,junk2,val] + x is ["~=",a,b] => mkAtree1 ["not",["=",a,b]] + x is ["+->",funargs,funbody] => + if funbody is [":",body,type] then + types := [type] + funbody := body + else types := [NIL] + v := collectDefTypesAndPreds funargs + types := [:types,:v.1] + [mkAtreeNode "ADEF",[v.0,types,[NIL for a in types],funbody], + if v.2 then v.2 else true, false] + x is ['ADEF,arg,:r] => + r := mkAtreeValueOf r + v := + null arg => VECTOR(NIL,NIL,NIL) + PAIRP arg and rest arg and first arg^= "|" => + collectDefTypesAndPreds ['Tuple,:arg] + null rest arg => collectDefTypesAndPreds first arg + collectDefTypesAndPreds arg + [types,:r'] := r + at := [fn(x,y) for x in rest types for y in v.1] + r := [[first types,:at],:r'] + [mkAtreeNode "ADEF",[v.0,:r],if v.2 then v.2 else true,false] + x is ["where",before,after] => + [mkAtreeNode "where",before,mkAtree1 after] + x is ["DEF",["macro",form],.,.,body] => + [mkAtreeNode "MDEF",form,body] + x is ["DEF",a,:r] => + r := mkAtreeValueOf r + a is [op,:arg] => + v := + null arg => VECTOR(NIL,NIL,NIL) + PAIRP arg and rest arg and first arg^= "|" => + collectDefTypesAndPreds ['Tuple,:arg] + null rest arg => collectDefTypesAndPreds first arg + collectDefTypesAndPreds arg + [types,:r'] := r + -- see case for ADEF above for defn of fn + at := [fn(x,y) for x in rest types for y in v.1] + r := [[first types,:at],:r'] + [mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false] + [mkAtreeNode 'DEF,[a,:r],true,false] +--x is ['when,y,pred] => +-- y isnt ['DEF,a,:r] => +-- keyedSystemError("S2II0003",['"when",y,'"improper argument form"]) +-- a is [op,p1,:pr] => +-- null pr => mkAtree1 ['DEF,[op,["|",p1,pred]],:r] +-- mkAtree1 ['DEF,[op,["|",['Tuple,p1,:pr],pred]],:r] +-- [mkAtreeNode 'DEF, CDR y,pred,false] +--x is ['otherwise,u] => +-- throwMessage '" otherwise is no longer supported." + z := + getBasicMode op => + v := mkAtreeNode $immediateDataSymbol + putValue(v,getBasicObject op) + v + atom op => mkAtreeNode op + mkAtree1 op + [z,:[mkAtree1 y for y in argl]] + where + fn(a,b) == + a and b => + if a = b then a + else throwMessage '" double declaration of parameter" + a or b + +collectDefTypesAndPreds args == + -- given an arglist to a DEF-like form, this function returns + -- a vector of three things: + -- slot 0: just the variables + -- slot 1: the type declarations on the variables + -- slot 2: a predicate for all arguments + pred := types := vars := NIL + junk := + IDENTP args => + types := [NIL] + vars := [args] + args is [":",var,type] => + types := [type] + var is ["|",var',p] => + vars := [var'] + pred := addPred(pred,p) + vars := [var] + args is ["|",var,p] => + pred := addPred(pred,p) + var is [":",var',type] => + types := [type] + vars := [var'] + var is ['Tuple,:.] or var is ["|",:.] => + v := collectDefTypesAndPreds var + vars := [:vars,:v.0] + types := [:types,:v.1] + pred := addPred(pred,v.2) + vars := [var] + types := [NIL] + args is ['Tuple,:args'] => + for a in args' repeat + v := collectDefTypesAndPreds a + vars := [:vars,first v.0] + types := [:types,first v.1] + pred := addPred(pred,v.2) + types := [NIL] + vars := [args] + VECTOR(vars,types,pred) + where + addPred(old,new) == + null new => old + null old => new + ['and,old,new] + +mkAtreeValueOf l == + -- scans for ['valueOf,atom] + not CONTAINED("valueOf",l) => l + mkAtreeValueOf1 l + +mkAtreeValueOf1 l == + null l or atom l or null rest l => l + l is ["valueOf",u] and IDENTP u => + v := mkAtreeNode $immediateDataSymbol + putValue(v,get(u,"value",$InteractiveFrame) or + objNewWrap(u,['Variable,u])) + v + [mkAtreeValueOf1 x for x in l] + +mkLessOrEqual(lhs,rhs) == ["not",["<",rhs,lhs]] + +atree2EvaluatedTree x == atree2Tree1(x,true) + +atree2Tree1(x,evalIfTrue) == + (triple := getValue x) and objMode(triple) ^= $EmptyMode => + coerceOrCroak(triple,$OutputForm,$mapName) + isLeaf x => + VECP x => x.0 + x + [atree2Tree1(y,evalIfTrue) for y in x] + +--% Environment Utilities + +-- getValueFromEnvironment(x,mode) == +-- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v +-- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v +-- throwKeyedMsg("S2IE0001",[x]) +getValueFromEnvironment(x,mode) == + $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v + $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v + null(v := coerceInt(objNew(x, ['Variable, x]), mode)) => + throwKeyedMsg("S2IE0001",[x]) + objValUnwrap v + +getValueFromSpecificEnvironment(id,mode,e) == + PAIRP e => + u := get(id,'value,e) => + objMode(u) = $EmptyMode => + systemErrorHere '"getValueFromSpecificEnvironment" + v := objValUnwrap u + mode isnt ['Mapping,:mapSig] => v + v isnt ['MAP,:.] => v + v' := coerceInt(u,mode) + null v' => throwKeyedMsg("S2IC0002",[objMode u,mode]) + objValUnwrap v' + + m := get(id,'mode,e) => + -- See if we can make it into declared mode from symbolic form + -- For example, (x : P[x] I; x + 1) + if isPartialMode(m) then m' := resolveTM(['Variable,id],m) + else m' := m + m' and + (u := coerceInteractive(objNewWrap(id,['Variable,id]),m')) => + objValUnwrap u + + throwKeyedMsg("S2IE0002",[id,m]) + $failure + $failure + +addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) == + -- change proplist of var in e destructively + u := ASSQ(var,curContour) => + RPLACD(u,proplist) + e + RPLAC(CAAR e,[[var,:proplist],:curContour]) + e + +augProplistInteractive(proplist,prop,val) == + u := ASSQ(prop,proplist) => + RPLACD(u,val) + proplist + [[prop,:val],:proplist] + +getFlag x == get("--flags--",x,$e) + +putFlag(flag,value) == + $e := put ("--flags--", flag, value, $e) + +getI(x,prop) == get(x,prop,$InteractiveFrame) + +putI(x,prop,val) == ($InteractiveFrame := put(x,prop,val,$InteractiveFrame)) + +getIProplist x == getProplist(x,$InteractiveFrame) + +removeBindingI x == + RPLAC(CAAR $InteractiveFrame,deleteAssocWOC(x,CAAR $InteractiveFrame)) + +rempropI(x,prop) == + id:= + atom x => x + first x + getI(id,prop) => + recordNewValue(id,prop,NIL) + recordOldValue(id,prop,getI(id,prop)) + $InteractiveFrame:= remprop(id,prop,$InteractiveFrame) + +remprop(x,prop,e) == + u:= ASSOC(prop,pl:= getProplist(x,e)) => + e:= addBinding(x,DELASC(first u,pl),e) + e + e + +fastSearchCurrentEnv(x,currentEnv) == + u:= QLASSQ(x,CAR currentEnv) => u + while (currentEnv:= QCDR currentEnv) repeat + u:= QLASSQ(x,CAR currentEnv) => u + +putIntSymTab(x,prop,val,e) == + null atom x => putIntSymTab(first x,prop,val,e) + pl0 := pl := search(x,e) + pl := + null pl => [[prop,:val]] + u := ASSQ(prop,pl) => + RPLACD(u,val) + pl + lp := LASTPAIR pl + u := [[prop,:val]] + RPLACD(lp,u) + pl + EQ(pl0,pl) => e + addIntSymTabBinding(x,pl,e) + +addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) == + -- change proplist of var in e destructively + u := ASSQ(var,curContour) => + RPLACD(u,proplist) + e + RPLAC(CAAR e,[[var,:proplist],:curContour]) + e + + diff --git a/src/interp/i-intern.boot.pamphlet b/src/interp/i-intern.boot.pamphlet deleted file mode 100644 index aabd6a7e..00000000 --- a/src/interp/i-intern.boot.pamphlet +++ /dev/null @@ -1,478 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-intern.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"i-object" -import '"ptrees" -)package "BOOT" - -$useParserSrcPos := NIL -$transferParserSrcPos := NIL - --- Making Trees - -mkAtree x == - -- maker of attrib tree from parser form - mkAtree1 mkAtreeExpandMacros x - -mkAtreeWithSrcPos(form, posnForm) == - posnForm and $useParserSrcPos => pf2Atree(posnForm) - transferSrcPosInfo(posnForm, mkAtree form) - -mkAtree1WithSrcPos(form, posnForm) == - transferSrcPosInfo(posnForm, mkAtree1 form) - -mkAtreeNodeWithSrcPos(form, posnForm) == - transferSrcPosInfo(posnForm, mkAtreeNode form) - -transferSrcPosInfo(pf, atree) == - not (pf and $transferParserSrcPos) => atree - pos := pfPosOrNopos(pf) - pfNoPosition?(pos) => atree - - -- following is a hack because parser code for getting filename - -- seems wrong. - fn := lnPlaceOfOrigin poGetLineObject(pos) - if NULL fn or fn = '"strings" then fn := '"console" - - putSrcPos(atree, fn, pfSourceText(pf), pfLinePosn(pos), pfCharPosn(pos)) - atree - -mkAtreeExpandMacros x == - -- handle macro expansion. if the macros have args we require that - -- we match the correct number of args - if x isnt ["MDEF",:.] and x isnt ["DEF",["macro",:.],:.] then - atom x and (m := isInterpMacro x) => - [args,:body] := m - args => "doNothing" - x := body - x is [op,:argl] => - op = "QUOTE" => "doNothing" - op = "where" and argl is [before,after] => - -- in a where clause, what follows "where" (the "after" parm - -- above) might be a local macro, so do not expand the "before" - -- part yet - x := [op,before,mkAtreeExpandMacros after] - argl := [mkAtreeExpandMacros a for a in argl] - (m := isInterpMacro op) => - [args,:body] := m - #args = #argl => - sl := [[a,:s] for a in args for s in argl] - x := SUBLISNQ(sl,body) - null args => x := [body,:argl] - x := [op,:argl] - x := [mkAtreeExpandMacros op,:argl] - x - -mkAtree1 x == - -- first special handler for making attrib tree - null x => throwKeyedMsg("S2IP0005",['"NIL"]) - VECP x => x - atom x => - x in '(noBranch noMapVal) => x - x in '(nil true false) => mkAtree2([x],x,NIL) - x = '_/throwAway => - -- don't want to actually compute this - tree := mkAtree1 '(void) - putValue(tree,objNewWrap(voidValue(),$Void)) - putModeSet(tree,[$Void]) - tree - getBasicMode x => - v := mkAtreeNode $immediateDataSymbol - putValue(v,getBasicObject x) - v - IDENTP x => mkAtreeNode x - keyedSystemError("S2II0002",[x]) - x is [op,:argl] => mkAtree2(x,op,argl) - systemErrorHere '"mkAtree1" - --- mkAtree2 and mkAtree3 were created because mkAtree1 got so big - -mkAtree2(x,op,argl) == - nargl := #argl - (op= "-") and (nargl = 1) and (INTEGERP CAR argl) => - mkAtree1(MINUS CAR argl) - op=":" and argl is [y,z] => [mkAtreeNode "Declare",:argl] - op="COLLECT" => [mkAtreeNode op,:transformCollect argl] - op= "break" => - argl is [.,val] => - if val = '$NoValue then val := '(void) - [mkAtreeNode op,mkAtree1 val] - [mkAtreeNode op,mkAtree1 '(void)] - op= "return" => - argl is [val] => - if val = '$NoValue then val := '(void) - [mkAtreeNode op,mkAtree1 val] - [mkAtreeNode op,mkAtree1 '(void)] - op="exit" => mkAtree1 CADR argl - op = "QUOTE" => [mkAtreeNode op,:argl] - op="SEGMENT" => - argl is [a] => [mkAtreeNode op, mkAtree1 a] - z := - null argl.1 => nil - mkAtree1 argl.1 - [mkAtreeNode op, mkAtree1 argl.0,z] - op in '(pretend is isnt) => - [mkAtreeNode op,mkAtree1 first argl,:rest argl] - op = "::" => - [mkAtreeNode "COERCE",mkAtree1 first argl,CADR argl] - x is ["@", expr, type] => - t := evaluateType unabbrev type - t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] => - mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args] - t = '(DoubleFloat) and INTEGERP expr => - v := mkAtreeNode $immediateDataSymbol - putValue(v,getBasicObject float expr) - v - t = '(Float) and INTEGERP expr => - mkAtree1 ["::", expr, t] - typeIsASmallInteger(t) and INTEGERP expr => - mkAtree1 ["::", expr, t] - [mkAtreeNode 'TARGET,mkAtree1 expr, type] - (op="case") and (nargl = 2) => - [mkAtreeNode "case",mkAtree1 first argl,unabbrev CADR argl] - op="REPEAT" => [mkAtreeNode op,:transformREPEAT argl] - op="LET" and argl is [['construct,:.],rhs] => - [mkAtreeNode "LET",first argl,mkAtree1 rhs] - op="LET" and argl is [[":",a,.],rhs] => - mkAtree1 ["SEQ",first argl,["LET",a,rhs]] - op is ['_$elt,D,op1] => - op1 is "=" => - a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]] - [mkAtreeNode "Dollar",D,a'] - [mkAtreeNode "Dollar",D,mkAtree1 [op1,:argl]] - op='_$elt => - argl is [D,a] => - INTEGERP a => - a = 0 => mkAtree1 [['_$elt,D,'Zero]] - a = 1 => mkAtree1 [['_$elt,D,'One]] - t := evaluateType unabbrev [D] - typeIsASmallInteger(t) and SINTP a => - v := mkAtreeNode $immediateDataSymbol - putValue(v,objNewWrap(a, t)) - v - mkAtree1 ["*",a,[['_$elt,D,'One]]] - [mkAtreeNode "Dollar",D,mkAtree1 a] - keyedSystemError("S2II0003",['"$",argl, - '"not qualifying an operator"]) - mkAtree3(x,op,argl) - -mkAtree3(x,op,argl) == - op="REDUCE" and argl is [op1,axis,body] => - [mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body] - op="has" => [mkAtreeNode op, :argl] - op="|" => [mkAtreeNode "AlgExtension",:[mkAtree1 arg for arg in argl]] - op="=" => [mkAtreeNode "equation",:[mkAtree1 arg for arg in argl]] - op="not" and argl is [["=",lhs,rhs]] => - [mkAtreeNode "not",[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]] - op="in" and argl is [var ,["SEGMENT",lb,ul]] => - upTest:= - null ul => NIL - mkLessOrEqual(var,ul) - lowTest:=mkLessOrEqual(lb,var) - z := - ul => ['and,lowTest,upTest] - lowTest - mkAtree1 z - x is ["IF",p,"noBranch",a] => mkAtree1 ["IF",["not",p],a,"noBranch"] - x is ["RULEDEF",:.] => [mkAtreeNode "RULEDEF",:CDR x] - x is ["MDEF",sym,junk1,junk2,val] => - -- new macros look like macro f == or macro f(x) === - -- so transform into that format - mkAtree1 ["DEF",["macro",sym],junk1,junk2,val] - x is ["~=",a,b] => mkAtree1 ["not",["=",a,b]] - x is ["+->",funargs,funbody] => - if funbody is [":",body,type] then - types := [type] - funbody := body - else types := [NIL] - v := collectDefTypesAndPreds funargs - types := [:types,:v.1] - [mkAtreeNode "ADEF",[v.0,types,[NIL for a in types],funbody], - if v.2 then v.2 else true, false] - x is ['ADEF,arg,:r] => - r := mkAtreeValueOf r - v := - null arg => VECTOR(NIL,NIL,NIL) - PAIRP arg and rest arg and first arg^= "|" => - collectDefTypesAndPreds ['Tuple,:arg] - null rest arg => collectDefTypesAndPreds first arg - collectDefTypesAndPreds arg - [types,:r'] := r - at := [fn(x,y) for x in rest types for y in v.1] - r := [[first types,:at],:r'] - [mkAtreeNode "ADEF",[v.0,:r],if v.2 then v.2 else true,false] - x is ["where",before,after] => - [mkAtreeNode "where",before,mkAtree1 after] - x is ["DEF",["macro",form],.,.,body] => - [mkAtreeNode "MDEF",form,body] - x is ["DEF",a,:r] => - r := mkAtreeValueOf r - a is [op,:arg] => - v := - null arg => VECTOR(NIL,NIL,NIL) - PAIRP arg and rest arg and first arg^= "|" => - collectDefTypesAndPreds ['Tuple,:arg] - null rest arg => collectDefTypesAndPreds first arg - collectDefTypesAndPreds arg - [types,:r'] := r - -- see case for ADEF above for defn of fn - at := [fn(x,y) for x in rest types for y in v.1] - r := [[first types,:at],:r'] - [mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false] - [mkAtreeNode 'DEF,[a,:r],true,false] ---x is ['when,y,pred] => --- y isnt ['DEF,a,:r] => --- keyedSystemError("S2II0003",['"when",y,'"improper argument form"]) --- a is [op,p1,:pr] => --- null pr => mkAtree1 ['DEF,[op,["|",p1,pred]],:r] --- mkAtree1 ['DEF,[op,["|",['Tuple,p1,:pr],pred]],:r] --- [mkAtreeNode 'DEF, CDR y,pred,false] ---x is ['otherwise,u] => --- throwMessage '" otherwise is no longer supported." - z := - getBasicMode op => - v := mkAtreeNode $immediateDataSymbol - putValue(v,getBasicObject op) - v - atom op => mkAtreeNode op - mkAtree1 op - [z,:[mkAtree1 y for y in argl]] - where - fn(a,b) == - a and b => - if a = b then a - else throwMessage '" double declaration of parameter" - a or b - -collectDefTypesAndPreds args == - -- given an arglist to a DEF-like form, this function returns - -- a vector of three things: - -- slot 0: just the variables - -- slot 1: the type declarations on the variables - -- slot 2: a predicate for all arguments - pred := types := vars := NIL - junk := - IDENTP args => - types := [NIL] - vars := [args] - args is [":",var,type] => - types := [type] - var is ["|",var',p] => - vars := [var'] - pred := addPred(pred,p) - vars := [var] - args is ["|",var,p] => - pred := addPred(pred,p) - var is [":",var',type] => - types := [type] - vars := [var'] - var is ['Tuple,:.] or var is ["|",:.] => - v := collectDefTypesAndPreds var - vars := [:vars,:v.0] - types := [:types,:v.1] - pred := addPred(pred,v.2) - vars := [var] - types := [NIL] - args is ['Tuple,:args'] => - for a in args' repeat - v := collectDefTypesAndPreds a - vars := [:vars,first v.0] - types := [:types,first v.1] - pred := addPred(pred,v.2) - types := [NIL] - vars := [args] - VECTOR(vars,types,pred) - where - addPred(old,new) == - null new => old - null old => new - ['and,old,new] - -mkAtreeValueOf l == - -- scans for ['valueOf,atom] - not CONTAINED("valueOf",l) => l - mkAtreeValueOf1 l - -mkAtreeValueOf1 l == - null l or atom l or null rest l => l - l is ["valueOf",u] and IDENTP u => - v := mkAtreeNode $immediateDataSymbol - putValue(v,get(u,"value",$InteractiveFrame) or - objNewWrap(u,['Variable,u])) - v - [mkAtreeValueOf1 x for x in l] - -mkLessOrEqual(lhs,rhs) == ["not",["<",rhs,lhs]] - -atree2EvaluatedTree x == atree2Tree1(x,true) - -atree2Tree1(x,evalIfTrue) == - (triple := getValue x) and objMode(triple) ^= $EmptyMode => - coerceOrCroak(triple,$OutputForm,$mapName) - isLeaf x => - VECP x => x.0 - x - [atree2Tree1(y,evalIfTrue) for y in x] - ---% Environment Utilities - --- getValueFromEnvironment(x,mode) == --- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v --- $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v --- throwKeyedMsg("S2IE0001",[x]) -getValueFromEnvironment(x,mode) == - $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v - $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e)) => v - null(v := coerceInt(objNew(x, ['Variable, x]), mode)) => - throwKeyedMsg("S2IE0001",[x]) - objValUnwrap v - -getValueFromSpecificEnvironment(id,mode,e) == - PAIRP e => - u := get(id,'value,e) => - objMode(u) = $EmptyMode => - systemErrorHere '"getValueFromSpecificEnvironment" - v := objValUnwrap u - mode isnt ['Mapping,:mapSig] => v - v isnt ['MAP,:.] => v - v' := coerceInt(u,mode) - null v' => throwKeyedMsg("S2IC0002",[objMode u,mode]) - objValUnwrap v' - - m := get(id,'mode,e) => - -- See if we can make it into declared mode from symbolic form - -- For example, (x : P[x] I; x + 1) - if isPartialMode(m) then m' := resolveTM(['Variable,id],m) - else m' := m - m' and - (u := coerceInteractive(objNewWrap(id,['Variable,id]),m')) => - objValUnwrap u - - throwKeyedMsg("S2IE0002",[id,m]) - $failure - $failure - -addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) == - -- change proplist of var in e destructively - u := ASSQ(var,curContour) => - RPLACD(u,proplist) - e - RPLAC(CAAR e,[[var,:proplist],:curContour]) - e - -augProplistInteractive(proplist,prop,val) == - u := ASSQ(prop,proplist) => - RPLACD(u,val) - proplist - [[prop,:val],:proplist] - -getFlag x == get("--flags--",x,$e) - -putFlag(flag,value) == - $e := put ("--flags--", flag, value, $e) - -getI(x,prop) == get(x,prop,$InteractiveFrame) - -putI(x,prop,val) == ($InteractiveFrame := put(x,prop,val,$InteractiveFrame)) - -getIProplist x == getProplist(x,$InteractiveFrame) - -removeBindingI x == - RPLAC(CAAR $InteractiveFrame,deleteAssocWOC(x,CAAR $InteractiveFrame)) - -rempropI(x,prop) == - id:= - atom x => x - first x - getI(id,prop) => - recordNewValue(id,prop,NIL) - recordOldValue(id,prop,getI(id,prop)) - $InteractiveFrame:= remprop(id,prop,$InteractiveFrame) - -remprop(x,prop,e) == - u:= ASSOC(prop,pl:= getProplist(x,e)) => - e:= addBinding(x,DELASC(first u,pl),e) - e - e - -fastSearchCurrentEnv(x,currentEnv) == - u:= QLASSQ(x,CAR currentEnv) => u - while (currentEnv:= QCDR currentEnv) repeat - u:= QLASSQ(x,CAR currentEnv) => u - -putIntSymTab(x,prop,val,e) == - null atom x => putIntSymTab(first x,prop,val,e) - pl0 := pl := search(x,e) - pl := - null pl => [[prop,:val]] - u := ASSQ(prop,pl) => - RPLACD(u,val) - pl - lp := LASTPAIR pl - u := [[prop,:val]] - RPLACD(lp,u) - pl - EQ(pl0,pl) => e - addIntSymTabBinding(x,pl,e) - -addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) == - -- change proplist of var in e destructively - u := ASSQ(var,curContour) => - RPLACD(u,proplist) - e - RPLAC(CAAR e,[[var,:proplist],:curContour]) - e - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot new file mode 100644 index 00000000..7a4a3eb1 --- /dev/null +++ b/src/interp/i-map.boot @@ -0,0 +1,1162 @@ +-- 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. + + +import '"i-object" +)package "BOOT" + +--% User Function Creation and Analysis Code + +$mapTarget := nil +$mapReturnTypes := nil +$mapName := 'noMapName +$mapThrowCount := 0 -- times a "return" occurs in map +$compilingMap := NIL +$definingMap := NIL + +--% Generating internal names for functions + +$specialMapNameSuffix := NIL + +makeInternalMapName(userName,numArgs,numMms,extraPart) == + name := CONCAT('"*",STRINGIMAGE numArgs,'";", + object2String userName,'";",STRINGIMAGE numMms,'";", + object2String frameName first $interpreterFrameRing ) + if extraPart then name := CONCAT(name,'";",extraPart) + if $specialMapNameSuffix then + name := CONCAT(name,'";",$specialMapNameSuffix) + INTERN name + +isInternalMapName name == + -- this only returns true or false as a "best guess" + (not IDENTP(name)) or (name = "*") or (name = "**") => false + sz := SIZE (name' := PNAME name) + (sz < 7) or (char("*") ^= name'.0) => false + null DIGITP name'.1 => false + null STRPOS('"_;",name',1,NIL) => false + -- good enough + true + +makeInternalMapMinivectorName(name) == + STRINGP name => + INTERN STRCONC(name,'";MV") + INTERN STRCONC(PNAME name,'";MV") + +mkCacheName(name) == INTERNL(STRINGIMAGE name,'";AL") + +mkAuxiliaryName(name) == INTERNL(STRINGIMAGE name,'";AUX") + +--% Adding a function definition + +isMapExpr x == x is ['MAP,:.] + +isMap x == + y := get(x,'value,$InteractiveFrame) => + objVal y is ['MAP,:.] => x + +addDefMap(['DEF,lhs,mapsig,.,rhs],pred) == + -- Create a new map, add to an existing one, or define a variable + -- compute the dependencies for a map + + -- next check is for bad forms on the lhs of the ==, such as + -- numbers, constants. + if not PAIRP lhs then + op := lhs + putHist(op,'isInterpreterRule,true,$e) + putHist(op,'isInterpreterFunction,false,$e) + lhs := [lhs] + else + -- this is a function definition. If it has been declared + -- previously, make sure it is Mapping. + op := first lhs + (oldMode := get(op,'mode,$e)) and oldMode isnt ['Mapping,:.] => + throwKeyedMsg("S2IM0001",[op,oldMode]) + putHist(op,'isInterpreterRule,false,$e) + putHist(op,'isInterpreterFunction,true,$e) + + (NUMBERP(op) or op in '(true false nil % %%)) => + throwKeyedMsg("S2IM0002",[lhs]) + + -- verify a constructor abbreviation is not used on the lhs + op ^= (op' := unabbrev op) => throwKeyedMsg("S2IM0003",[op,op']) + + -- get the formal parameters. These should only be atomic symbols + -- that are not numbers. + parameters := [p for p in rest lhs | IDENTP(p)] + + -- see if a signature has been given. if anything in mapsig is NIL, + -- then declaration was omitted. + someDecs := nil + allDecs := true + mapmode := ['Mapping] + $env:local := [[NIL]] + $eval:local := true --generate code-- don't just type analyze + $genValue:local := true --evaluate all generated code + for d in mapsig repeat + if d then + someDecs := true + d' := evaluateType unabbrev d + isPartialMode d' => throwKeyedMsg("S2IM0004",NIL) +-- tree := mkAtree d' +-- null (d' := isType tree) => throwKeyedMsg("S2IM0005",[d]) + mapmode := [d',:mapmode] + else allDecs := false + if allDecs then + mapmode := nreverse mapmode + putHist(op,'mode,mapmode,$e) + sayKeyedMsg("S2IM0006",[formatOpSignature(op,rest mapmode)]) + else if someDecs then throwKeyedMsg("S2IM0007",[op]) + + -- if map is declared, check that signature arg count is the + -- same as what is given. + if get(op,'mode,$e) is ['Mapping,.,:mapargs] then + EQCAR(rhs,'rules) => + 0 ^= (numargs := # rest lhs) => + throwKeyedMsg("S2IM0027",[numargs,op]) + # rest lhs ^= # mapargs => throwKeyedMsg("S2IM0008",[op]) + --get all the user variables in the map definition. This is a multi + --step process as this should not include recursive calls to the map + --itself, or the formal parameters + userVariables1 := getUserIdentifiersIn rhs + $freeVars: local := NIL + $localVars: local := NIL + for parm in parameters repeat mkLocalVar($mapName,parm) + userVariables2 := setDifference(userVariables1,findLocalVars(op,rhs)) + userVariables3 := setDifference(userVariables2, parameters) + userVariables4 := REMDUP setDifference (userVariables3, [op]) + + --figure out the new dependencies for the new map (what it depends on) + newDependencies := makeNewDependencies (op, userVariables4) + putDependencies (op, newDependencies) + clearDependencies(op,'T) + addMap(lhs,rhs,pred) + +addMap(lhs,rhs,pred) == + [op,:argl] := lhs + $sl: local:= nil + formalArgList:= [mkFormalArg(makeArgumentIntoNumber x,s) + for x in argl for s in $FormalMapVariableList] + argList:= + [fn for x in formalArgList] where + fn() == + if x is ["SUCHTHAT",s,p] then (predList:= [p,:predList]; x:= s) + x + mkMapAlias(op,argl) + argPredList:= NREVERSE predList + finalPred := +-- handle g(a,T)==a+T confusion between pred=T and T variable + MKPF((pred and (pred ^= 'T) => [:argPredList,SUBLISNQ($sl,pred)]; argPredList),"and") + body:= SUBLISNQ($sl,rhs) + oldMap := + (obj := get(op,'value,$InteractiveFrame)) => objVal obj + NIL + newMap := augmentMap(op,argList,finalPred,body,oldMap) + null newMap => + sayRemoveFunctionOrValue op + putHist(op,'alias,nil,$e) + " " -- clears value--- see return from addDefMap in tree2Atree1 + if get(op,'isInterpreterRule,$e) then type := ['RuleCalled,op] + else type := ['FunctionCalled,op] + recursive := + depthOfRecursion(op,newMap) = 0 => false + true + putHist(op,'recursive,recursive,$e) + objNew(newMap,type) + +augmentMap(op,args,pred,body,oldMap) == + pattern:= makePattern(args,pred) + newMap:=deleteMap(op,pattern,oldMap) + body=" " => + if newMap=oldMap then + sayMSG ['" Cannot find part of",:bright op,'"to delete."] + newMap --just delete rule if body is + entry:= [pattern,:body] + resultMap:= + newMap is ["MAP",:tail] => ["MAP",:tail,entry] + ["MAP",entry] + resultMap + +deleteMap(op,pattern,map) == + map is ["MAP",:tail] => + newMap:= ['MAP,:[x for x in tail | w]] where w() == + x is [=pattern,:replacement] => sayDroppingFunctions(op,[x]) + true + null rest newMap => nil + newMap + NIL + +getUserIdentifiersIn body == + null body => nil + IDENTP body => + isSharpVarWithNum body => nil + body=" " => nil + [body] + body is ["WRAPPED",:.] => nil + (body is ["COLLECT",:itl,body1]) or (body is ['REPEAT,:itl,body1]) => + userIds := + S_+(getUserIdentifiersInIterators itl,getUserIdentifiersIn body1) + S_-(userIds,getIteratorIds itl) + body is [op,:l] => + argIdList:= "append"/[getUserIdentifiersIn y for y in l] + bodyIdList := + CONSP op or not (GETL(op,'Nud) or GETL(op,'Led) or GETL(op,'up))=> + NCONC(getUserIdentifiersIn op, argIdList) + argIdList + REMDUP bodyIdList + +getUserIdentifiersInIterators itl == + for x in itl repeat + x is ["STEP",i,:l] => + varList:= [:"append"/[getUserIdentifiersIn y for y in l],:varList] + x is ["IN",.,y] => varList:= [:getUserIdentifiersIn y,:varList] + x is ["ON",.,y] => varList:= [:getUserIdentifiersIn y,:varList] + x is [op,a] and op in '(_| WHILE UNTIL) => + varList:= [:getUserIdentifiersIn a,:varList] + keyedSystemError("S2GE0016",['"getUserIdentifiersInIterators", + '"unknown iterator construct"]) + REMDUP varList + +getIteratorIds itl == + for x in itl repeat + x is ["STEP",i,:.] => varList:= [i,:varList] + x is ["IN",y,:.] => varList:= [y,:varList] + x is ["ON",y,:.] => varList:= [y,:varList] + nil + varList + +makeArgumentIntoNumber x == + x=$Zero => 0 + x=$One => 1 + atom x => x + x is ["-",n] and NUMBERP n => -n + [removeZeroOne first x,:removeZeroOne rest x] + +mkMapAlias(op,argl) == + u:= mkAliasList argl + newAlias := + alias:= get(op,"alias",$e) => [(y => y; x) for x in alias for y in u] + u + $e:= putHist(op,"alias",newAlias,$e) + +mkAliasList l == fn(l,nil) where fn(l,acc) == + null l => NREVERSE acc + not IDENTP first l or first l in acc => fn(rest l,[nil,:acc]) + fn(rest l,[first l,:acc]) + +args2Tuple args == + args is [first,:rest] => + null rest => first + ["Tuple",:args] + nil + +makePattern(args,pred) == + nargs:= #args + nargs = 1 => + pred is ["=","#1",n] => n + addPatternPred("#1",pred) + u:= canMakeTuple(nargs,pred) => u + addPatternPred(["Tuple",:TAKE(nargs,$FormalMapVariableList)],pred) + +addPatternPred(arg,pred) == + pred=true => arg + ["|",arg,pred] + +canMakeTuple(nargs,pred) == + pred is ["and",:l] and nargs=#l and + (u:= [(x is ["=",=y,a] => a; return nil) + for y in $FormalMapVariableList for x in orderList l]) => + ["Tuple",:u] + +sayRemoveFunctionOrValue x == + (obj := getValue x) and (md := objMode obj) => + md = $EmptyMode => + sayMessage ['" ",:bright x,'"now has no function parts."] + sayMessage ['" value for",:bright x,'"has been removed."] + sayMessage ['" ",:bright x,'"has no value so this does nothing."] + +sayDroppingFunctions(op,l) == + sayKeyedMsg("S2IM0017",[#l,op]) + if $displayDroppedMap then + for [pattern,:replacement] in l repeat + displaySingleRule(op,pattern,replacement) + nil + +makeRuleForm(op,pattern)== + pattern is ["Tuple",:l] => [op,:l] + [op,:pattern] + +mkFormalArg(x,s) == + isConstantArgument x => ["SUCHTHAT",s,["=",s,x]] + isPatternArgument x => ["SUCHTHAT",s,["is",s,x]] + IDENTP x => + y:= LASSOC(x,$sl) => ["SUCHTHAT",s,["=",s,y]] + $sl:= [[x,:s],:$sl] + s + ['SUCHTHAT,s,["=",s,x]] + +isConstantArgument x == + NUMBERP x => x + x is ["QUOTE",.] => x + +isPatternArgument x == x is ["construct",:.] + +--% Map dependencies + +makeNewDependencies (op, userVariables) == + null userVariables => nil + --add the new dependencies + [[(first userVariables),op], + :makeNewDependencies (op, rest userVariables)] + +putDependencies (op, dependencies) == + oldDependencies := getFlag "$dependencies" + --remove the obsolete dependencies: all those that applied to the + --old definition, but may not apply here. If they do, they'll be + --in the list of new dependencies anyway + oldDependencies := removeObsoleteDependencies (op, oldDependencies) where + removeObsoleteDependencies (op, oldDep) == + null oldDep => nil + op = rest first oldDep => + removeObsoleteDependencies (op, rest oldDep) + [first oldDep,:removeObsoleteDependencies (op, rest oldDep)] + --Create the list of dependencies to output. This will be all the + --old dependencies that are still applicable, and all the new ones + --that have just been generated. Remember that the list of + --dependencies does not just include those for the map just being + --defined, but includes those for all maps and variables that exist + newDependencies := union (dependencies, oldDependencies) + putFlag ("$dependencies", newDependencies) + +clearDependencies(x,clearLocalModemapsIfTrue) == + $dependencies: local:= COPY getFlag "$dependencies" + clearDep1(x,nil,nil,$dependencies) + +clearDep1(x,toDoList,doneList,depList) == + x in doneList => nil + clearCache x + newDone:= [x,:doneList] + until null a repeat + a:= ASSQ(x,depList) + a => + depList:= delete(a,depList) + toDoList:= union(toDoList, + setDifference(CDR a,doneList)) + toDoList is [a,:res] => clearDep1(a,res,newDone,depList) + 'done + +--% Formatting and displaying maps + +displayRule(op,rule) == + null rule => nil + mathprint ["CONCAT","Definition: ", rule] + nil + +outputFormat(x,m) == + -- this is largely junk and is being phased out + IDENTP m => x + m=$OutputForm or m=$EmptyMode => x + categoryForm?(m) => x + isMapExpr x => x + containsVars x => x + atom(x) and CAR(m) = 'List => x + (x is ['construct,:.]) and m = '(List (Expression)) => x + T:= coerceInteractive(objNewWrap(x,maximalSuperType(m)), + $OutputForm) or return x + objValUnwrap T + +displaySingleRule($op,pattern,replacement) == + mathprint ['MAP,[pattern,:replacement]] + +displayMap(headingIfTrue,$op,map) == + mathprint + headingIfTrue => ['CONCAT,PNAME "value: ",map] + map + +simplifyMapPattern (x,alias) == + for a in alias + for m in $FormalMapVariableList | a and ^CONTAINED(a,x) repeat + x:= substitute(a,m,x) + [lhs,:rhs]:= x + rhs := simplifyMapConstructorRefs rhs + x := [lhs,:rhs] + lhs is ["|",y,pred] => + pred:= predTran pred + sl:= getEqualSublis pred => + y':= SUBLIS(sl,y) + pred:= unTrivialize SUBLIS(sl,pred) where unTrivialize x == + x is [op,:l] and op in '(_and _or) => + MKPF([unTrivialize y for y in l],op) + x is [op,a,=a] and op in '(_= is)=> true + x + rhs':= SUBLIS(sl,rhs) + pred=true => [y',:rhs'] + [["PAREN",["|",y',pred]],:rhs'] + pred=true => [y,:rhs] + [["PAREN",["|",y,pred]],:rhs] + lhs=true => ["true",:rhs] + x + +simplifyMapConstructorRefs form == + -- try to linear format constructor names + ATOM form => form + [op,:args] := form + op in '(exit SEQ) => + [op,:[simplifyMapConstructorRefs a for a in args]] + op in '(REPEAT) => + [op,first args,:[simplifyMapConstructorRefs a for a in rest args]] + op in '(_: _:_: _@) => + args is [obj,dom] => + dom' := prefix2String dom + --if ATOM dom' then dom' := [dom'] + --[op,obj,APPLY('CONCAT,dom')] + dom'' := + ATOM dom' => dom' + NULL CDR dom' => CAR dom' + APPLY('CONCAT, dom') + [op,obj, dom''] + form + form + +predTran x == + x is ["IF",a,b,c] => + c = "false" => MKPF([predTran a,predTran b],"and") + b = "true" => MKPF([predTran a,predTran c],"or") + b = "false" and c = "true" => ["not",predTran a] + x + x + +getEqualSublis pred == fn(pred,nil) where fn(x,sl) == + (x:= SUBLIS(sl,x)) is [op,:l] and op in '(_and _or) => + for y in l repeat sl:= fn(y,sl) + sl + x is ["is",a,b] => [[a,:b],:sl] + x is ["=",a,b] => + IDENTP a and not CONTAINED(a,b) => [[a,:b],:sl] + IDENTP b and not CONTAINED(b,a) => [[b,:a],:sl] + sl + sl + +--% User function analysis + +mapCatchName mapname == + INTERN STRCONC('"$",STRINGIMAGE mapname,'"CatchMapIdentifier$") + +analyzeMap(op,argTypes,mapDef, tar) == + -- Top level enty point for map type analysis. Sets up catch point + -- for interpret-code mode. + $compilingMap:local := true + $definingMap:local := true + $minivector : local := nil -- later becomes value of $minivectorName + $mapThrowCount : local := 0 -- number of "return"s encountered + $mapReturnTypes : local := nil -- list of types from returns + $repeatLabel : local := nil -- for loops; see upREPEAT + $breakCount : local := 0 -- breaks from loops; ditto + $mapTarget : local := tar + $interpOnly: local := NIL + $mapName : local := op.0 + if get($mapName,'recursive,$e) then + argTypes := [f t for t in argTypes] where + f x == + isEqualOrSubDomain(x,$Integer) => $Integer + x + mapAndArgTypes := [$mapName,:argTypes] + member(mapAndArgTypes,$analyzingMapList) => + -- if the map is declared, return the target type + (getMode op) is ['Mapping,target,:.] => target + throwKeyedMsg("S2IM0009", + [$mapName,['" ", map for [map,:.] in $analyzingMapList]]) + PUSH(mapAndArgTypes,$analyzingMapList) + mapDef := mapDefsWithCorrectArgCount(#argTypes, mapDef) + null mapDef => (POP $analyzingMapList; nil) + + UNWIND_-PROTECT(x:=CATCH('mapCompiler,analyzeMap0(op,argTypes,mapDef)), + POP $analyzingMapList) + x='tryInterpOnly => + opName:=getUnname op + fun := mkInterpFun(op,opName,argTypes) + if getMode op isnt ['Mapping,:sig] then + sig := [nil,:[nil for type in argTypes]] + $e:=putHist(opName,'localModemap, + [[['interpOnly,:sig],fun,NIL]],$e) + x + +analyzeMap0(op,argTypes,mapDef) == + -- Type analyze and compile a map. Returns the target type of the map. + -- only called if there is no applicable compiled map + $MapArgumentTypeList:local:= argTypes + numMapArgs mapDef ^= #argTypes => nil + ((m:=getMode op) is ['Mapping,:sig]) or (m and (sig:=[m])) => + -- op has mapping property only if user has declared the signature + analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) + analyzeUndeclaredMap(getUnname op,argTypes,mapDef,$mapList) + +compFailure msg == + -- Called when compilation fails in such a way that interpret-code + -- mode might be of some use. + not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) + if $reportInterpOnly then + sayMSG msg + sayMSG '" We will attempt to interpret the code." + null $compilingMap => THROW('loopCompiler,'tryInterpOnly) + THROW('mapCompiler,'tryInterpOnly) + +mkInterpFun(op,opName,argTypes) == + -- creates a function form to put in fun slot of interp-only + -- local modemaps + getMode op isnt ['Mapping,:sig] => nil + parms := [var for type in argTypes for var in $FormalMapVariableList] + arglCode := ['LIST,:[argCode for type in argTypes + for argName in parms]] where argCode() == + ['putValueValue,['mkAtreeNode,MKQ argName], + objNewCode(['wrap,argName],type)] + funName := GENSYM() + body:=['rewriteMap1,MKQ opName,arglCode,MKQ sig] + putMapCode(opName,body,sig,funName,parms,false) + genMapCode(opName,body,sig,funName,parms,false) + funName + +rewriteMap(op,opName,argl) == + -- interpret-code handler for maps. Recursively calls the interpreter + -- on the body of the map. + not $genValue => + get(opName,'mode,$e) isnt ['Mapping,:sig] => + compFailure ['" Cannot compile map:",:bright opName] + arglCode := ['LIST,:[argCode for arg in argl for argName in + $FormalMapVariableList]] where argCode() == + ['putValueValue,['mkAtreeNode,MKQ argName], + objNewCode(['wrap,wrapped2Quote(objVal getValue arg)], + getMode arg)] + putValue(op,objNew(['rewriteMap1,MKQ opName,arglCode,MKQ sig], + CAR sig)) + putModeSet(op,[CAR sig]) + rewriteMap0(op,opName,argl) + +putBodyInEnv(opName, numArgs) == + val := get(opName, 'value, $e) + val is [.,'MAP, :bod] => + $e := putHist(opName, 'mapBody, combineMapParts + mapDefsWithCorrectArgCount(numArgs, bod), $e) + 'failed + +removeBodyFromEnv(opName) == + $e := putHist(opName, 'mapBody, nil, $e) + + +rewriteMap0(op,opName,argl) == + -- $genValue case of map rewriting + putBodyInEnv(opName, #argl) + if (s := get(opName,'mode,$e)) then + tar := CADR s + argTypes := CDDR s + else + tar:= nil + argTypes:= nil + get(opName,'mode,$e) is ['Mapping,tar,:argTypes] + $env: local := [[NIL]] + for arg in argl + for var in $FormalMapVariableList repeat + if argTypes then + t := CAR argTypes + argTypes:= CDR argTypes + val := + t is ['Mapping,:.] => getValue arg + coerceInteractive(getValue arg,t) + else + val:= getValue arg + $env:=put(var,'value,val,$env) + if VECP arg then $env := put(var,'name,getUnname arg,$env) + (m := getMode arg) => $env := put(var,'mode,m,$env) + null (val:= interpMap(opName,tar)) => + throwKeyedMsg("S2IM0010",[opName]) + putValue(op,val) + removeBodyFromEnv(opName) + ms := putModeSet(op,[objMode val]) + +rewriteMap1(opName,argl,sig) == + -- compiled case of map rewriting + putBodyInEnv(opName, #argl) + if sig then + tar:= CAR sig + argTypes:= CDR sig + else + tar:= nil + argTypes:= nil + evArgl := NIL + for arg in reverse argl repeat + v := getValue arg + evArgl := [objNew(objVal v, objMode v),:evArgl] + $env : local := [[NIL]] + for arg in argl for evArg in evArgl + for var in $FormalMapVariableList repeat + if argTypes then + t:=CAR argTypes + argTypes:= CDR argTypes + val := + t is ['Mapping,:.] => evArg + coerceInteractive(evArg,t) + else + val:= evArg + $env:=put(var,'value,val,$env) + if VECP arg then $env := put(var,'name,getUnname arg,$env) + (m := getMode arg) => $env := put(var,'mode,m,$env) + val:= interpMap(opName,tar) + removeBodyFromEnv(opName) + objValUnwrap(val) + +interpMap(opName,tar) == + -- call the interpreter recursively on map body + $genValue : local:= true + $interpMapTag : local := nil + $interpOnly : local := true + $localVars : local := NIL + for lvar in get(opName,'localVars,$e) repeat mkLocalVar(opName,lvar) + $mapName : local := opName + $mapTarget : local := tar + body:= get(opName,'mapBody,$e) + savedTimerStack := COPY $timedNameStack + catchName := mapCatchName $mapName + c := CATCH(catchName, interpret1(body,tar,nil)) +-- $interpMapTag and $interpMapTag ^= mapCatchName $mapName => +-- THROW($interpMapTag,c) + while savedTimerStack ^= $timedNameStack repeat + stopTimingProcess peekTimedName() + c -- better be a triple + +analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) == + -- analyzes and compiles maps with declared signatures. argTypes + -- is a list of types of the arguments, sig is the declared signature + -- mapDef is the stored form of the map body. + opName := getUnname op + $mapList:=[opName,:$mapList] + $mapTarget := CAR sig + (mmS:= get(opName,'localModemap,$e)) and + (mm:= or/[mm for (mm:=[[.,:mmSig],:.]) in mmS | mmSig=sig]) => + compileCoerceMap(opName,argTypes,mm) + -- The declared map needs to be compiled + compileDeclaredMap(opName,sig,mapDef) + argTypes ^= CDR sig => + analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) + CAR sig + +compileDeclaredMap(op,sig,mapDef) == + -- Type analyzes and compiles a map with a declared signature. + -- creates a local modemap and puts it into the environment + $localVars: local := nil + $freeVars: local := nil + $env:local:= [[NIL]] + parms:=[var for var in $FormalMapVariableList for m in CDR sig] + for m in CDR sig for var in parms repeat + $env:= put(var,'mode,m,$env) + body:= getMapBody(op,mapDef) + for lvar in parms repeat mkLocalVar($mapName,lvar) + for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) + name := makeLocalModemap(op,sig) + val := compileBody(body,CAR sig) + isRecursive := (depthOfRecursion(op,body) > 0) + putMapCode(op,objVal val,sig,name,parms,isRecursive) + genMapCode(op,objVal val,sig,name,parms,isRecursive) + CAR sig + +putMapCode(op,code,sig,name,parms,isRecursive) == + -- saves the generated code and some other information about the + -- function + codeInfo := VECTOR(op,code,sig,name,parms,isRecursive) + allCode := [codeInfo,:get(op,'generatedCode,$e)] + $e := putHist(op,'generatedCode,allCode,$e) + op + +makeLocalModemap(op,sig) == + -- create a local modemap for op with sig, and put it into $e + if (currentMms := get(op,'localModemap,$e)) then + untraceMapSubNames [CADAR currentMms] + newName := makeInternalMapName(op,#sig-1,1+#currentMms,NIL) + newMm := [['local,:sig],newName,nil] + mms := [newMm,:currentMms] + $e := putHist(op,'localModemap,mms,$e) + newName + +genMapCode(op,body,sig,fnName,parms,isRecursive) == + -- calls the lisp compiler on the body of a map + if lmm:= get(op,'localModemap,$InteractiveFrame) then + untraceMapSubNames [CADAR lmm] + op0 := + ( n := isSharpVarWithNum op ) => STRCONC('"") + op + if get(op,'isInterpreterRule,$e) then + sayKeyedMsg("S2IM0014",[op0,(PAIRP sig =>prefix2String CAR sig;'"?")]) + else sayKeyedMsg("S2IM0015",[op0,formatSignature sig]) + $whereCacheList := [op,:$whereCacheList] + + -- RSS: 6-21-94 + -- The following code ensures that local variables really are local + -- to a function. We will unnecessarily generate preliminary LETs for + -- loop variables and variables that do have LET expressions, but that + -- can be finessed later. + + locals := SETDIFFERENCE(COPY $localVars, parms) + if locals then + lets := [['LET, l, ''UNINITIALIZED__VARIABLE, op] for l in locals] + body := ['PROGN, :lets, body] + + reportFunctionCompilation(op,fnName,parms, + wrapMapBodyWithCatch flattenCOND body,isRecursive) + +compileBody(body,target) == + -- recursively calls the interpreter on the map body + -- returns a triple with the LISP code for body in the value cell + $insideCompileBodyIfTrue: local := true + $genValue: local := false + $declaredMode:local := target + $eval:local:= true + r := interpret1(body,target,nil) + +compileCoerceMap(op,argTypes,mm) == + -- compiles call to user-declared map where the arguments need + -- to be coerced. mm is the modemap for the declared map. + $insideCompileBodyIfTrue: local := true + $genValue: local := false + [[.,:sig],imp,.]:= mm + parms:= [var for var in $FormalMapVariableList for t in CDR sig] + name:= makeLocalModemap(op,[CAR sig,:argTypes]) + argCode := [objVal(coerceInteractive(objNew(arg,t1),t2) or + throwKeyedMsg("S2IC0001",[arg,$mapName,t1,t2])) + for t1 in argTypes for t2 in CDR sig for arg in parms] + $insideCompileBodyIfTrue := false + parms:= [:parms,'envArg] + body := ['SPADCALL,:argCode,['LIST,['function,imp]]] + minivectorName := makeInternalMapMinivectorName(name) + $minivectorNames := [[op,:minivectorName],:$minivectorNames] + body := SUBST(minivectorName,"$$$",body) + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,minivectorName] + SET(minivectorName,LIST2REFVEC $minivector) + compileInteractive [name,['LAMBDA,parms,body]] + CAR sig + +depthOfRecursion(opName,body) == + -- returns the "depth" of recursive calls of opName in body + mapRecurDepth(opName,nil,body) + +mapRecurDepth(opName,opList,body) == + -- walks over the map body counting depth of recursive calls + -- expanding the bodies of maps called in body + atom body => 0 + body is [op,:argl] => + argc:= + atom argl => 0 + argl => "MAX"/[mapRecurDepth(opName,opList,x) for x in argl] + 0 + op in opList => argc + op=opName => 1 + argc + (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => + mapRecurDepth(opName,[op,:opList],getMapBody(op,mapDef)) + + argc + argc + keyedSystemError("S2GE0016",['"mapRecurDepth", + '"unknown function form"]) + +analyzeUndeclaredMap(op,argTypes,mapDef,$mapList) == + -- Computes the signature of the map named op, and compiles the body + $freeVars:local := NIL + $localVars: local := NIL + $env:local:= [[NIL]] + $mapList := [op,:$mapList] + parms:=[var for var in $FormalMapVariableList for m in argTypes] + for m in argTypes for var in parms repeat + put(var,'autoDeclare,'T,$env) + put(var,'mode,m,$env) + body:= getMapBody(op,mapDef) + for lvar in parms repeat mkLocalVar($mapName,lvar) + for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) + (n:= depthOfRecursion(op,body)) = 0 => + analyzeNonRecursiveMap(op,argTypes,body,parms) + analyzeRecursiveMap(op,argTypes,body,parms,n) + +analyzeNonRecursiveMap(op,argTypes,body,parms) == + -- analyze and compile a non-recursive map definition + T := compileBody(body,$mapTarget) + if $mapThrowCount > 0 then + t := objMode T + b := and/[(t = rt) for rt in $mapReturnTypes] + not b => + t := resolveTypeListAny [t,:$mapReturnTypes] + if not $mapTarget then $mapTarget := t + T := compileBody(body,$mapTarget) + sig := [objMode T,:argTypes] + name:= makeLocalModemap(op,sig) + putMapCode(op,objVal T,sig,name,parms,false) + genMapCode(op,objVal T,sig,name,parms,false) + objMode(T) + +analyzeRecursiveMap(op,argTypes,body,parms,n) == + -- analyze and compile a non-recursive map definition + -- makes guess at signature by analyzing non-recursive part of body + -- then re-analyzes the entire body until the signature doesn't change + localMapInfo := saveDependentMapInfo(op, CDR $mapList) + tar := CATCH('interpreter,analyzeNonRecur(op,body,$localVars)) + for i in 0..n until not sigChanged repeat + sigChanged:= false + name := makeLocalModemap(op,sig:=[tar,:argTypes]) + code := compileBody(body,$mapTarget) + objMode(code) ^= tar => + sigChanged:= true + tar := objMode(code) + restoreDependentMapInfo(op, CDR $mapList, localMapInfo) + sigChanged => throwKeyedMsg("S2IM0011",[op]) + putMapCode(op,objVal code,sig,name,parms,true) + genMapCode(op,objVal code,sig,name,parms,true) + tar + +saveDependentMapInfo(op,opList) == + not (op in opList) => + lmml := [[op, :get(op, 'localModemap, $e)]] + gcl := [[op, :get(op, 'generatedCode, $e)]] + for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat + [lmml', :gcl'] := saveDependentMapInfo(dep2, [op, :opList]) + lmms := nconc(lmml', lmml) + gcl := nconc(gcl', gcl) + [lmms, :gcl] + nil + +restoreDependentMapInfo(op, opList, [lmml,:gcl]) == + not (op in opList) => + clearDependentMaps(op,opList) + for [op, :lmm] in lmml repeat + $e := putHist(op,'localModemap,lmm,$e) + for [op, :gc] in gcl repeat + $e := putHist(op,'generatedCode,gc,$e) + +clearDependentMaps(op,opList) == + -- clears the local modemaps of all the maps that depend on op + not (op in opList) => + $e := putHist(op,'localModemap,nil,$e) + $e := putHist(op,'generatedCode,nil,$e) + for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat + clearDependentMaps(dep2,[op,:opList]) + +analyzeNonRecur(op,body,$localVars) == + -- type analyze the non-recursive part of a map body + nrp := nonRecursivePart(op,body) + for lvar in findLocalVars(op,nrp) repeat mkLocalVar($mapName,lvar) + objMode(compileBody(nrp,$mapTarget)) + +nonRecursivePart(opName, funBody) == + -- takes funBody, which is the parse tree of the definition of + -- a function, and returns a list of the parts + -- of the function which are not recursive in the name opName + body:= expandRecursiveBody([opName], funBody) + ((nrp:=nonRecursivePart1(opName, body)) ^= 'noMapVal) => nrp + throwKeyedMsg("S2IM0012",[opName]) + +expandRecursiveBody(alreadyExpanded, body) == + -- replaces calls to other maps with their bodies + atom body => + (obj := get(body,'value,$e)) and objVal obj is ['MAP,:mapDef] and + ((numMapArgs mapDef) = 0) => getMapBody(body,mapDef) + body + body is [op,:argl] => + not (op in alreadyExpanded) => + (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => + newBody:= getMapBody(op,mapDef) + for arg in argl for var in $FormalMapVariableList repeat + newBody:=MSUBST(arg,var,newBody) + expandRecursiveBody([op,:alreadyExpanded],newBody) + [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] + [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] + keyedSystemError("S2GE0016",['"expandRecursiveBody", + '"unknown form of function body"]) + +nonRecursivePart1(opName, funBody) == + -- returns a function body which contains only the parts of funBody + -- which do not call the function opName + funBody is ['IF,a,b,c] => + nra:=nonRecursivePart1(opName,a) + nra = 'noMapVal => 'noMapVal + nrb:=nonRecursivePart1(opName,b) + nrc:=nonRecursivePart1(opName,c) + not (nrb in '(noMapVal noBranch)) => ['IF,nra,nrb,nrc] + not (nrc in '(noMapVal noBranch)) => ['IF,['not,nra],nrc,nrb] + 'noMapVal + not containsOp(funBody,'IF) => + notCalled(opName,funBody) => funBody + 'noMapVal + funBody is [op,:argl] => + op=opName => 'noMapVal + args:= [nonRecursivePart1(opName,arg) for arg in argl] + MEMQ('noMapVal,args) => 'noMapVal + [op,:args] + funBody + +containsOp(body,op) == + -- true IFF body contains an op statement + body is [ =op,:.] => true + body is [.,:argl] => or/[containsOp(arg,op) for arg in argl] + false + +notCalled(opName,form) == + -- returns true if opName is not called in the form + atom form => true + form is [op,:argl] => + op=opName => false + and/[notCalled(opName,x) for x in argl] + keyedSystemError("S2GE0016",['"notCalled", + '"unknown form of function body"]) + +mapDefsWithCorrectArgCount(n, mapDef) == + [def for def in mapDef | (numArgs CAR def) = n] + +numMapArgs(mapDef is [[args,:.],:.]) == + -- returns the number of arguemnts to the map whose body is mapDef + numArgs args + +numArgs args == + args is ['_|,a,:.] => numArgs a + args is ['Tuple,:argl] => #argl + null args => 0 + 1 + +combineMapParts(mapTail) == + -- transforms a piece-wise function definition into an if-then-else + -- statement. Uses noBranch to indicate undefined branch + null mapTail => 'noMapVal + mapTail is [[cond,:part],:restMap] => + isSharpVarWithNum cond or (cond is ['Tuple,:args] and + and/[isSharpVarWithNum arg for arg in args]) or (null cond) => part + ['IF,mkMapPred cond,part,combineMapParts restMap] + keyedSystemError("S2GE0016",['"combineMapParts", + '"unknown function form"]) + +mkMapPred cond == + -- create the predicate on map arguments, derived from "when" clauses + cond is ['_|,args,pred] => mapPredTran pred + cond is ['Tuple,:vals] => + mkValueCheck(vals,1) + mkValCheck(cond,1) + +mkValueCheck(vals,i) == + -- creates predicate for specific value check (i.e f 1 == 1) + vals is [val] => mkValCheck(val,i) + ['and,mkValCheck(first vals,i),mkValueCheck(rest vals,i+1)] + +mkValCheck(val,i) == + -- create equality check for map predicates + isSharpVarWithNum val => 'true + ['_=,mkSharpVar i,val] + +mkSharpVar i == + -- create #i + INTERN CONCAT('"#",STRINGIMAGE i) + +mapPredTran pred == + -- transforms "x in i..j" to "x>=i and x<=j" + pred is ['in,var,['SEGMENT,lb]] => mkLessOrEqual(lb,var) + pred is ['in,var,['SEGMENT,lb,ub]] => + null ub => mkLessOrEqual(lb,var) + ['and,mkLessOrEqual(lb,var),mkLessOrEqual(var,ub)] + pred + +findLocalVars(op,form) == + -- analyzes form for local and free variables, and returns the list + -- of locals + findLocalVars1(op,form) + $localVars + +findLocalVars1(op,form) == + -- sets the two lists $localVars and $freeVars + atom form => + not IDENTP form or isSharpVarWithNum form => nil + isLocalVar(form) or isFreeVar(form) => nil + mkFreeVar($mapName,form) + form is ['local, :vars] => + for x in vars repeat + ATOM x => mkLocalVar(op, x) + form is ['free, :vars] => + for x in vars repeat + ATOM x => mkFreeVar(op, x) + form is ['LET,a,b] => + (a is ['Tuple,:vars]) and (b is ['Tuple,:vals]) => + for var in vars for val in vals repeat + findLocalVars1(op,['LET,var,val]) + a is ['construct,:pat] => + for var in listOfVariables pat repeat mkLocalVar(op,var) + findLocalVars1(op,b) + (atom a) or (a is ['_:,a,.]) => + mkLocalVar(op,a) + findLocalVars1(op,b) + findLocalVars(op,b) + for x in a repeat findLocalVars1(op,x) + form is ['_:,a,.] => + mkLocalVar(op,a) + form is ['is,l,pattern] => + findLocalVars1(op,l) + for var in listOfVariables CDR pattern repeat mkLocalVar(op,var) + form is [oper,:itrl,body] and MEMQ(oper,'(REPEAT COLLECT)) => + findLocalsInLoop(op,itrl,body) + form is [y,:argl] => + y is 'Record => nil + for x in argl repeat findLocalVars1(op,x) + keyedSystemError("S2IM0020",[op]) + +findLocalsInLoop(op,itrl,body) == + for it in itrl repeat + it is ['STEP,index,lower,step,:upperList] => + mkLocalVar(op,index) + findLocalVars1(op,lower) + for up in upperList repeat findLocalVars1(op,up) + it is ['IN,index,s] => + mkLocalVar(op,index) ; findLocalVars1(op,s) + it is ['WHILE,b] => + findLocalVars1(op,b) + it is ['_|,pred] => + findLocalVars1(op,pred) + findLocalVars1(op,body) + for it in itrl repeat + it is [op,b] and (op in '(UNTIL)) => + findLocalVars1(op,b) + +isLocalVar(var) == member(var,$localVars) + +mkLocalVar(op,var) == + -- add var to the local variable list + isFreeVar(var) => $localVars + $localVars:= insert(var,$localVars) + +isFreeVar(var) == member(var,$freeVars) + +mkFreeVar(op,var) == + -- op here for symmetry with mkLocalVar + $freeVars:= insert(var,$freeVars) + +listOfVariables pat == + -- return a list of the variables in pat, which is an "is" pattern + IDENTP pat => (pat='_. => nil ; [pat]) + pat is ['_:,var] or pat is ['_=,var] => + (var='_. => NIL ; [var]) + PAIRP pat => REMDUP [:listOfVariables p for p in pat] + nil + +getMapBody(op,mapDef) == + -- looks in $e for a map body; if not found it computes then stores it + get(op,'mapBody,$e) or + combineMapParts mapDef +-- $e:= putHist(op,'mapBody,body:= combineMapParts mapDef,$e) +-- body + +getLocalVars(op,body) == + -- looks in $e for local vars; if not found, computes then stores them + get(op,'localVars,$e) or + $e:= putHist(op,'localVars,lv:=findLocalVars(op,body),$e) + lv + +-- DO NOT BELIEVE ALL OF THE FOLLOWING (IT IS OLD) + +-- VARIABLES. Variables may or may not have a mode property. If +-- present, any value which is assigned or generated by that variable +-- is first coerced to that mode before being assigned or returned. +-- +-- +-- Variables are given a triple [val,m,e] as a "value" property on +-- its property list in the environment. The expression val has the +-- forms: +-- +-- (WRAPPED . y) --value of x is y (don't re-evaluate) +-- y --anything else --value of x is obtained by evaluating y +-- +-- A wrapped expression is created by an assignment. In the second +-- case, y can never contain embedded wrapped expressions. The mode +-- part m of the triple is the type of y in the wrapped case and is +-- consistent with the declared mode if given. The mode part of an +-- unwrapped value is always $EmptyMode. The e part is usually NIL +-- but may be used to hold a partial closure. +-- +-- Effect of changes. A rule can be built up for a variable by +-- successive rules involving conditional expressions. However, once +-- a value is assigned to the variable or an unconditional definition +-- is given, any existing value is replaced by the new entry. When +-- the mode of a variable is declared, an wrapped value is coerced to +-- the new mode; if this is not possible, the user is notified that +-- the current value is discarded and why. When the mode is +-- redeclared and an upwrapped value is present, the value is +-- retained; the only other effect is to coerce any cached values +-- from the old mode to the new one. +-- +-- Caches. When a variable x is evaluated and re-evaluation occurs, +-- the triple produced by that evaluation is stored under "cache" on +-- the property list of x. This cached triple is cleared whenever any +-- of the variables which x's value depend upon change. Dependencies +-- are stored on $dependencies whose value has the form [[a b ..] ..] +-- to indicate that when a is changed, b .. must have all cached +-- values destroyed. In the case of parameterized forms which are +-- represented by maps, we currently can cache values only when the +-- compiler option is turned on by )on c s meaning "on compiler with +-- the save option". When f is compiled as f;1, it then has an alist +-- f;1;AL which records these values. If f depends globally on a's +-- value, all cached values of all local functions defined for f have +-- to be declared. If a's mode should change, then all compilations +-- of f must be thrown away. +-- +-- PARAMETERIZED FORMS. These always have values [val,m,e] where val +-- are "maps". +-- +-- The structure of maps: +-- (MAP (pattern . rewrite) ...) where +-- pattern has forms: arg-pattern +-- (Tuple arg-pattern ...) +-- rewrite has forms: (WRAPPED . value) --don't re-evaluate +-- computational object --don't (bother to) +-- re-evaluate +-- anything else --yes, re-evaluate +-- +-- When assigning values to a map, each new value must have a type +-- which is consistent with those already assigned. Initially, type +-- of MAP is $EmptyMode. When the map is first assigned a value, the +-- type of the MAP is RPLACDed to be (Mapping target source ..). +-- When the map is next assigned, the type of both source and target +-- is upgraded to be consistent with those values already computed. +-- Of course, if new and old source and target are identical, nothing +-- need happen to existing entries. However, if the new and old are +-- different, all existing entries of the map are coerce to the new +-- data type. +-- +-- Mode analysis. This is done on the bottomUp phase of the process. +-- If a function has been given a mapping declaration, this map is +-- placed in as the mode of the map under the "value" property of the +-- variable. Of course, these modes may be partial types in case a +-- mode analysis is still necessary. If no mapping declaration, a +-- total mode analysis of the function, given its input arguments, is +-- done. This will result a signature involving types only. +-- +-- If the compiler is on, the function is then compiled given this +-- signature involving types. If the map is value of a variable f, a +-- function is given name f;1, f is given a "localModemap" property +-- with modemap ((dummy target source ..) (T f;1)) so that the next +-- time f is applied to arguments which coerce to the source +-- arguments of this local modemap, f;1 will be invoked. diff --git a/src/interp/i-map.boot.pamphlet b/src/interp/i-map.boot.pamphlet deleted file mode 100644 index c64a4318..00000000 --- a/src/interp/i-map.boot.pamphlet +++ /dev/null @@ -1,1188 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-map.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"i-object" -)package "BOOT" - ---% User Function Creation and Analysis Code - -$mapTarget := nil -$mapReturnTypes := nil -$mapName := 'noMapName -$mapThrowCount := 0 -- times a "return" occurs in map -$compilingMap := NIL -$definingMap := NIL - ---% Generating internal names for functions - -$specialMapNameSuffix := NIL - -makeInternalMapName(userName,numArgs,numMms,extraPart) == - name := CONCAT('"*",STRINGIMAGE numArgs,'";", - object2String userName,'";",STRINGIMAGE numMms,'";", - object2String frameName first $interpreterFrameRing ) - if extraPart then name := CONCAT(name,'";",extraPart) - if $specialMapNameSuffix then - name := CONCAT(name,'";",$specialMapNameSuffix) - INTERN name - -isInternalMapName name == - -- this only returns true or false as a "best guess" - (not IDENTP(name)) or (name = "*") or (name = "**") => false - sz := SIZE (name' := PNAME name) - (sz < 7) or (char("*") ^= name'.0) => false - null DIGITP name'.1 => false - null STRPOS('"_;",name',1,NIL) => false - -- good enough - true - -makeInternalMapMinivectorName(name) == - STRINGP name => - INTERN STRCONC(name,'";MV") - INTERN STRCONC(PNAME name,'";MV") - -mkCacheName(name) == INTERNL(STRINGIMAGE name,'";AL") - -mkAuxiliaryName(name) == INTERNL(STRINGIMAGE name,'";AUX") - ---% Adding a function definition - -isMapExpr x == x is ['MAP,:.] - -isMap x == - y := get(x,'value,$InteractiveFrame) => - objVal y is ['MAP,:.] => x - -addDefMap(['DEF,lhs,mapsig,.,rhs],pred) == - -- Create a new map, add to an existing one, or define a variable - -- compute the dependencies for a map - - -- next check is for bad forms on the lhs of the ==, such as - -- numbers, constants. - if not PAIRP lhs then - op := lhs - putHist(op,'isInterpreterRule,true,$e) - putHist(op,'isInterpreterFunction,false,$e) - lhs := [lhs] - else - -- this is a function definition. If it has been declared - -- previously, make sure it is Mapping. - op := first lhs - (oldMode := get(op,'mode,$e)) and oldMode isnt ['Mapping,:.] => - throwKeyedMsg("S2IM0001",[op,oldMode]) - putHist(op,'isInterpreterRule,false,$e) - putHist(op,'isInterpreterFunction,true,$e) - - (NUMBERP(op) or op in '(true false nil % %%)) => - throwKeyedMsg("S2IM0002",[lhs]) - - -- verify a constructor abbreviation is not used on the lhs - op ^= (op' := unabbrev op) => throwKeyedMsg("S2IM0003",[op,op']) - - -- get the formal parameters. These should only be atomic symbols - -- that are not numbers. - parameters := [p for p in rest lhs | IDENTP(p)] - - -- see if a signature has been given. if anything in mapsig is NIL, - -- then declaration was omitted. - someDecs := nil - allDecs := true - mapmode := ['Mapping] - $env:local := [[NIL]] - $eval:local := true --generate code-- don't just type analyze - $genValue:local := true --evaluate all generated code - for d in mapsig repeat - if d then - someDecs := true - d' := evaluateType unabbrev d - isPartialMode d' => throwKeyedMsg("S2IM0004",NIL) --- tree := mkAtree d' --- null (d' := isType tree) => throwKeyedMsg("S2IM0005",[d]) - mapmode := [d',:mapmode] - else allDecs := false - if allDecs then - mapmode := nreverse mapmode - putHist(op,'mode,mapmode,$e) - sayKeyedMsg("S2IM0006",[formatOpSignature(op,rest mapmode)]) - else if someDecs then throwKeyedMsg("S2IM0007",[op]) - - -- if map is declared, check that signature arg count is the - -- same as what is given. - if get(op,'mode,$e) is ['Mapping,.,:mapargs] then - EQCAR(rhs,'rules) => - 0 ^= (numargs := # rest lhs) => - throwKeyedMsg("S2IM0027",[numargs,op]) - # rest lhs ^= # mapargs => throwKeyedMsg("S2IM0008",[op]) - --get all the user variables in the map definition. This is a multi - --step process as this should not include recursive calls to the map - --itself, or the formal parameters - userVariables1 := getUserIdentifiersIn rhs - $freeVars: local := NIL - $localVars: local := NIL - for parm in parameters repeat mkLocalVar($mapName,parm) - userVariables2 := setDifference(userVariables1,findLocalVars(op,rhs)) - userVariables3 := setDifference(userVariables2, parameters) - userVariables4 := REMDUP setDifference (userVariables3, [op]) - - --figure out the new dependencies for the new map (what it depends on) - newDependencies := makeNewDependencies (op, userVariables4) - putDependencies (op, newDependencies) - clearDependencies(op,'T) - addMap(lhs,rhs,pred) - -addMap(lhs,rhs,pred) == - [op,:argl] := lhs - $sl: local:= nil - formalArgList:= [mkFormalArg(makeArgumentIntoNumber x,s) - for x in argl for s in $FormalMapVariableList] - argList:= - [fn for x in formalArgList] where - fn() == - if x is ["SUCHTHAT",s,p] then (predList:= [p,:predList]; x:= s) - x - mkMapAlias(op,argl) - argPredList:= NREVERSE predList - finalPred := --- handle g(a,T)==a+T confusion between pred=T and T variable - MKPF((pred and (pred ^= 'T) => [:argPredList,SUBLISNQ($sl,pred)]; argPredList),"and") - body:= SUBLISNQ($sl,rhs) - oldMap := - (obj := get(op,'value,$InteractiveFrame)) => objVal obj - NIL - newMap := augmentMap(op,argList,finalPred,body,oldMap) - null newMap => - sayRemoveFunctionOrValue op - putHist(op,'alias,nil,$e) - " " -- clears value--- see return from addDefMap in tree2Atree1 - if get(op,'isInterpreterRule,$e) then type := ['RuleCalled,op] - else type := ['FunctionCalled,op] - recursive := - depthOfRecursion(op,newMap) = 0 => false - true - putHist(op,'recursive,recursive,$e) - objNew(newMap,type) - -augmentMap(op,args,pred,body,oldMap) == - pattern:= makePattern(args,pred) - newMap:=deleteMap(op,pattern,oldMap) - body=" " => - if newMap=oldMap then - sayMSG ['" Cannot find part of",:bright op,'"to delete."] - newMap --just delete rule if body is - entry:= [pattern,:body] - resultMap:= - newMap is ["MAP",:tail] => ["MAP",:tail,entry] - ["MAP",entry] - resultMap - -deleteMap(op,pattern,map) == - map is ["MAP",:tail] => - newMap:= ['MAP,:[x for x in tail | w]] where w() == - x is [=pattern,:replacement] => sayDroppingFunctions(op,[x]) - true - null rest newMap => nil - newMap - NIL - -getUserIdentifiersIn body == - null body => nil - IDENTP body => - isSharpVarWithNum body => nil - body=" " => nil - [body] - body is ["WRAPPED",:.] => nil - (body is ["COLLECT",:itl,body1]) or (body is ['REPEAT,:itl,body1]) => - userIds := - S_+(getUserIdentifiersInIterators itl,getUserIdentifiersIn body1) - S_-(userIds,getIteratorIds itl) - body is [op,:l] => - argIdList:= "append"/[getUserIdentifiersIn y for y in l] - bodyIdList := - CONSP op or not (GETL(op,'Nud) or GETL(op,'Led) or GETL(op,'up))=> - NCONC(getUserIdentifiersIn op, argIdList) - argIdList - REMDUP bodyIdList - -getUserIdentifiersInIterators itl == - for x in itl repeat - x is ["STEP",i,:l] => - varList:= [:"append"/[getUserIdentifiersIn y for y in l],:varList] - x is ["IN",.,y] => varList:= [:getUserIdentifiersIn y,:varList] - x is ["ON",.,y] => varList:= [:getUserIdentifiersIn y,:varList] - x is [op,a] and op in '(_| WHILE UNTIL) => - varList:= [:getUserIdentifiersIn a,:varList] - keyedSystemError("S2GE0016",['"getUserIdentifiersInIterators", - '"unknown iterator construct"]) - REMDUP varList - -getIteratorIds itl == - for x in itl repeat - x is ["STEP",i,:.] => varList:= [i,:varList] - x is ["IN",y,:.] => varList:= [y,:varList] - x is ["ON",y,:.] => varList:= [y,:varList] - nil - varList - -makeArgumentIntoNumber x == - x=$Zero => 0 - x=$One => 1 - atom x => x - x is ["-",n] and NUMBERP n => -n - [removeZeroOne first x,:removeZeroOne rest x] - -mkMapAlias(op,argl) == - u:= mkAliasList argl - newAlias := - alias:= get(op,"alias",$e) => [(y => y; x) for x in alias for y in u] - u - $e:= putHist(op,"alias",newAlias,$e) - -mkAliasList l == fn(l,nil) where fn(l,acc) == - null l => NREVERSE acc - not IDENTP first l or first l in acc => fn(rest l,[nil,:acc]) - fn(rest l,[first l,:acc]) - -args2Tuple args == - args is [first,:rest] => - null rest => first - ["Tuple",:args] - nil - -makePattern(args,pred) == - nargs:= #args - nargs = 1 => - pred is ["=","#1",n] => n - addPatternPred("#1",pred) - u:= canMakeTuple(nargs,pred) => u - addPatternPred(["Tuple",:TAKE(nargs,$FormalMapVariableList)],pred) - -addPatternPred(arg,pred) == - pred=true => arg - ["|",arg,pred] - -canMakeTuple(nargs,pred) == - pred is ["and",:l] and nargs=#l and - (u:= [(x is ["=",=y,a] => a; return nil) - for y in $FormalMapVariableList for x in orderList l]) => - ["Tuple",:u] - -sayRemoveFunctionOrValue x == - (obj := getValue x) and (md := objMode obj) => - md = $EmptyMode => - sayMessage ['" ",:bright x,'"now has no function parts."] - sayMessage ['" value for",:bright x,'"has been removed."] - sayMessage ['" ",:bright x,'"has no value so this does nothing."] - -sayDroppingFunctions(op,l) == - sayKeyedMsg("S2IM0017",[#l,op]) - if $displayDroppedMap then - for [pattern,:replacement] in l repeat - displaySingleRule(op,pattern,replacement) - nil - -makeRuleForm(op,pattern)== - pattern is ["Tuple",:l] => [op,:l] - [op,:pattern] - -mkFormalArg(x,s) == - isConstantArgument x => ["SUCHTHAT",s,["=",s,x]] - isPatternArgument x => ["SUCHTHAT",s,["is",s,x]] - IDENTP x => - y:= LASSOC(x,$sl) => ["SUCHTHAT",s,["=",s,y]] - $sl:= [[x,:s],:$sl] - s - ['SUCHTHAT,s,["=",s,x]] - -isConstantArgument x == - NUMBERP x => x - x is ["QUOTE",.] => x - -isPatternArgument x == x is ["construct",:.] - ---% Map dependencies - -makeNewDependencies (op, userVariables) == - null userVariables => nil - --add the new dependencies - [[(first userVariables),op], - :makeNewDependencies (op, rest userVariables)] - -putDependencies (op, dependencies) == - oldDependencies := getFlag "$dependencies" - --remove the obsolete dependencies: all those that applied to the - --old definition, but may not apply here. If they do, they'll be - --in the list of new dependencies anyway - oldDependencies := removeObsoleteDependencies (op, oldDependencies) where - removeObsoleteDependencies (op, oldDep) == - null oldDep => nil - op = rest first oldDep => - removeObsoleteDependencies (op, rest oldDep) - [first oldDep,:removeObsoleteDependencies (op, rest oldDep)] - --Create the list of dependencies to output. This will be all the - --old dependencies that are still applicable, and all the new ones - --that have just been generated. Remember that the list of - --dependencies does not just include those for the map just being - --defined, but includes those for all maps and variables that exist - newDependencies := union (dependencies, oldDependencies) - putFlag ("$dependencies", newDependencies) - -clearDependencies(x,clearLocalModemapsIfTrue) == - $dependencies: local:= COPY getFlag "$dependencies" - clearDep1(x,nil,nil,$dependencies) - -clearDep1(x,toDoList,doneList,depList) == - x in doneList => nil - clearCache x - newDone:= [x,:doneList] - until null a repeat - a:= ASSQ(x,depList) - a => - depList:= delete(a,depList) - toDoList:= union(toDoList, - setDifference(CDR a,doneList)) - toDoList is [a,:res] => clearDep1(a,res,newDone,depList) - 'done - ---% Formatting and displaying maps - -displayRule(op,rule) == - null rule => nil - mathprint ["CONCAT","Definition: ", rule] - nil - -outputFormat(x,m) == - -- this is largely junk and is being phased out - IDENTP m => x - m=$OutputForm or m=$EmptyMode => x - categoryForm?(m) => x - isMapExpr x => x - containsVars x => x - atom(x) and CAR(m) = 'List => x - (x is ['construct,:.]) and m = '(List (Expression)) => x - T:= coerceInteractive(objNewWrap(x,maximalSuperType(m)), - $OutputForm) or return x - objValUnwrap T - -displaySingleRule($op,pattern,replacement) == - mathprint ['MAP,[pattern,:replacement]] - -displayMap(headingIfTrue,$op,map) == - mathprint - headingIfTrue => ['CONCAT,PNAME "value: ",map] - map - -simplifyMapPattern (x,alias) == - for a in alias - for m in $FormalMapVariableList | a and ^CONTAINED(a,x) repeat - x:= substitute(a,m,x) - [lhs,:rhs]:= x - rhs := simplifyMapConstructorRefs rhs - x := [lhs,:rhs] - lhs is ["|",y,pred] => - pred:= predTran pred - sl:= getEqualSublis pred => - y':= SUBLIS(sl,y) - pred:= unTrivialize SUBLIS(sl,pred) where unTrivialize x == - x is [op,:l] and op in '(_and _or) => - MKPF([unTrivialize y for y in l],op) - x is [op,a,=a] and op in '(_= is)=> true - x - rhs':= SUBLIS(sl,rhs) - pred=true => [y',:rhs'] - [["PAREN",["|",y',pred]],:rhs'] - pred=true => [y,:rhs] - [["PAREN",["|",y,pred]],:rhs] - lhs=true => ["true",:rhs] - x - -simplifyMapConstructorRefs form == - -- try to linear format constructor names - ATOM form => form - [op,:args] := form - op in '(exit SEQ) => - [op,:[simplifyMapConstructorRefs a for a in args]] - op in '(REPEAT) => - [op,first args,:[simplifyMapConstructorRefs a for a in rest args]] - op in '(_: _:_: _@) => - args is [obj,dom] => - dom' := prefix2String dom - --if ATOM dom' then dom' := [dom'] - --[op,obj,APPLY('CONCAT,dom')] - dom'' := - ATOM dom' => dom' - NULL CDR dom' => CAR dom' - APPLY('CONCAT, dom') - [op,obj, dom''] - form - form - -predTran x == - x is ["IF",a,b,c] => - c = "false" => MKPF([predTran a,predTran b],"and") - b = "true" => MKPF([predTran a,predTran c],"or") - b = "false" and c = "true" => ["not",predTran a] - x - x - -getEqualSublis pred == fn(pred,nil) where fn(x,sl) == - (x:= SUBLIS(sl,x)) is [op,:l] and op in '(_and _or) => - for y in l repeat sl:= fn(y,sl) - sl - x is ["is",a,b] => [[a,:b],:sl] - x is ["=",a,b] => - IDENTP a and not CONTAINED(a,b) => [[a,:b],:sl] - IDENTP b and not CONTAINED(b,a) => [[b,:a],:sl] - sl - sl - ---% User function analysis - -mapCatchName mapname == - INTERN STRCONC('"$",STRINGIMAGE mapname,'"CatchMapIdentifier$") - -analyzeMap(op,argTypes,mapDef, tar) == - -- Top level enty point for map type analysis. Sets up catch point - -- for interpret-code mode. - $compilingMap:local := true - $definingMap:local := true - $minivector : local := nil -- later becomes value of $minivectorName - $mapThrowCount : local := 0 -- number of "return"s encountered - $mapReturnTypes : local := nil -- list of types from returns - $repeatLabel : local := nil -- for loops; see upREPEAT - $breakCount : local := 0 -- breaks from loops; ditto - $mapTarget : local := tar - $interpOnly: local := NIL - $mapName : local := op.0 - if get($mapName,'recursive,$e) then - argTypes := [f t for t in argTypes] where - f x == - isEqualOrSubDomain(x,$Integer) => $Integer - x - mapAndArgTypes := [$mapName,:argTypes] - member(mapAndArgTypes,$analyzingMapList) => - -- if the map is declared, return the target type - (getMode op) is ['Mapping,target,:.] => target - throwKeyedMsg("S2IM0009", - [$mapName,['" ", map for [map,:.] in $analyzingMapList]]) - PUSH(mapAndArgTypes,$analyzingMapList) - mapDef := mapDefsWithCorrectArgCount(#argTypes, mapDef) - null mapDef => (POP $analyzingMapList; nil) - - UNWIND_-PROTECT(x:=CATCH('mapCompiler,analyzeMap0(op,argTypes,mapDef)), - POP $analyzingMapList) - x='tryInterpOnly => - opName:=getUnname op - fun := mkInterpFun(op,opName,argTypes) - if getMode op isnt ['Mapping,:sig] then - sig := [nil,:[nil for type in argTypes]] - $e:=putHist(opName,'localModemap, - [[['interpOnly,:sig],fun,NIL]],$e) - x - -analyzeMap0(op,argTypes,mapDef) == - -- Type analyze and compile a map. Returns the target type of the map. - -- only called if there is no applicable compiled map - $MapArgumentTypeList:local:= argTypes - numMapArgs mapDef ^= #argTypes => nil - ((m:=getMode op) is ['Mapping,:sig]) or (m and (sig:=[m])) => - -- op has mapping property only if user has declared the signature - analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) - analyzeUndeclaredMap(getUnname op,argTypes,mapDef,$mapList) - -compFailure msg == - -- Called when compilation fails in such a way that interpret-code - -- mode might be of some use. - not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) - if $reportInterpOnly then - sayMSG msg - sayMSG '" We will attempt to interpret the code." - null $compilingMap => THROW('loopCompiler,'tryInterpOnly) - THROW('mapCompiler,'tryInterpOnly) - -mkInterpFun(op,opName,argTypes) == - -- creates a function form to put in fun slot of interp-only - -- local modemaps - getMode op isnt ['Mapping,:sig] => nil - parms := [var for type in argTypes for var in $FormalMapVariableList] - arglCode := ['LIST,:[argCode for type in argTypes - for argName in parms]] where argCode() == - ['putValueValue,['mkAtreeNode,MKQ argName], - objNewCode(['wrap,argName],type)] - funName := GENSYM() - body:=['rewriteMap1,MKQ opName,arglCode,MKQ sig] - putMapCode(opName,body,sig,funName,parms,false) - genMapCode(opName,body,sig,funName,parms,false) - funName - -rewriteMap(op,opName,argl) == - -- interpret-code handler for maps. Recursively calls the interpreter - -- on the body of the map. - not $genValue => - get(opName,'mode,$e) isnt ['Mapping,:sig] => - compFailure ['" Cannot compile map:",:bright opName] - arglCode := ['LIST,:[argCode for arg in argl for argName in - $FormalMapVariableList]] where argCode() == - ['putValueValue,['mkAtreeNode,MKQ argName], - objNewCode(['wrap,wrapped2Quote(objVal getValue arg)], - getMode arg)] - putValue(op,objNew(['rewriteMap1,MKQ opName,arglCode,MKQ sig], - CAR sig)) - putModeSet(op,[CAR sig]) - rewriteMap0(op,opName,argl) - -putBodyInEnv(opName, numArgs) == - val := get(opName, 'value, $e) - val is [.,'MAP, :bod] => - $e := putHist(opName, 'mapBody, combineMapParts - mapDefsWithCorrectArgCount(numArgs, bod), $e) - 'failed - -removeBodyFromEnv(opName) == - $e := putHist(opName, 'mapBody, nil, $e) - - -rewriteMap0(op,opName,argl) == - -- $genValue case of map rewriting - putBodyInEnv(opName, #argl) - if (s := get(opName,'mode,$e)) then - tar := CADR s - argTypes := CDDR s - else - tar:= nil - argTypes:= nil - get(opName,'mode,$e) is ['Mapping,tar,:argTypes] - $env: local := [[NIL]] - for arg in argl - for var in $FormalMapVariableList repeat - if argTypes then - t := CAR argTypes - argTypes:= CDR argTypes - val := - t is ['Mapping,:.] => getValue arg - coerceInteractive(getValue arg,t) - else - val:= getValue arg - $env:=put(var,'value,val,$env) - if VECP arg then $env := put(var,'name,getUnname arg,$env) - (m := getMode arg) => $env := put(var,'mode,m,$env) - null (val:= interpMap(opName,tar)) => - throwKeyedMsg("S2IM0010",[opName]) - putValue(op,val) - removeBodyFromEnv(opName) - ms := putModeSet(op,[objMode val]) - -rewriteMap1(opName,argl,sig) == - -- compiled case of map rewriting - putBodyInEnv(opName, #argl) - if sig then - tar:= CAR sig - argTypes:= CDR sig - else - tar:= nil - argTypes:= nil - evArgl := NIL - for arg in reverse argl repeat - v := getValue arg - evArgl := [objNew(objVal v, objMode v),:evArgl] - $env : local := [[NIL]] - for arg in argl for evArg in evArgl - for var in $FormalMapVariableList repeat - if argTypes then - t:=CAR argTypes - argTypes:= CDR argTypes - val := - t is ['Mapping,:.] => evArg - coerceInteractive(evArg,t) - else - val:= evArg - $env:=put(var,'value,val,$env) - if VECP arg then $env := put(var,'name,getUnname arg,$env) - (m := getMode arg) => $env := put(var,'mode,m,$env) - val:= interpMap(opName,tar) - removeBodyFromEnv(opName) - objValUnwrap(val) - -interpMap(opName,tar) == - -- call the interpreter recursively on map body - $genValue : local:= true - $interpMapTag : local := nil - $interpOnly : local := true - $localVars : local := NIL - for lvar in get(opName,'localVars,$e) repeat mkLocalVar(opName,lvar) - $mapName : local := opName - $mapTarget : local := tar - body:= get(opName,'mapBody,$e) - savedTimerStack := COPY $timedNameStack - catchName := mapCatchName $mapName - c := CATCH(catchName, interpret1(body,tar,nil)) --- $interpMapTag and $interpMapTag ^= mapCatchName $mapName => --- THROW($interpMapTag,c) - while savedTimerStack ^= $timedNameStack repeat - stopTimingProcess peekTimedName() - c -- better be a triple - -analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) == - -- analyzes and compiles maps with declared signatures. argTypes - -- is a list of types of the arguments, sig is the declared signature - -- mapDef is the stored form of the map body. - opName := getUnname op - $mapList:=[opName,:$mapList] - $mapTarget := CAR sig - (mmS:= get(opName,'localModemap,$e)) and - (mm:= or/[mm for (mm:=[[.,:mmSig],:.]) in mmS | mmSig=sig]) => - compileCoerceMap(opName,argTypes,mm) - -- The declared map needs to be compiled - compileDeclaredMap(opName,sig,mapDef) - argTypes ^= CDR sig => - analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) - CAR sig - -compileDeclaredMap(op,sig,mapDef) == - -- Type analyzes and compiles a map with a declared signature. - -- creates a local modemap and puts it into the environment - $localVars: local := nil - $freeVars: local := nil - $env:local:= [[NIL]] - parms:=[var for var in $FormalMapVariableList for m in CDR sig] - for m in CDR sig for var in parms repeat - $env:= put(var,'mode,m,$env) - body:= getMapBody(op,mapDef) - for lvar in parms repeat mkLocalVar($mapName,lvar) - for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) - name := makeLocalModemap(op,sig) - val := compileBody(body,CAR sig) - isRecursive := (depthOfRecursion(op,body) > 0) - putMapCode(op,objVal val,sig,name,parms,isRecursive) - genMapCode(op,objVal val,sig,name,parms,isRecursive) - CAR sig - -putMapCode(op,code,sig,name,parms,isRecursive) == - -- saves the generated code and some other information about the - -- function - codeInfo := VECTOR(op,code,sig,name,parms,isRecursive) - allCode := [codeInfo,:get(op,'generatedCode,$e)] - $e := putHist(op,'generatedCode,allCode,$e) - op - -makeLocalModemap(op,sig) == - -- create a local modemap for op with sig, and put it into $e - if (currentMms := get(op,'localModemap,$e)) then - untraceMapSubNames [CADAR currentMms] - newName := makeInternalMapName(op,#sig-1,1+#currentMms,NIL) - newMm := [['local,:sig],newName,nil] - mms := [newMm,:currentMms] - $e := putHist(op,'localModemap,mms,$e) - newName - -genMapCode(op,body,sig,fnName,parms,isRecursive) == - -- calls the lisp compiler on the body of a map - if lmm:= get(op,'localModemap,$InteractiveFrame) then - untraceMapSubNames [CADAR lmm] - op0 := - ( n := isSharpVarWithNum op ) => STRCONC('"") - op - if get(op,'isInterpreterRule,$e) then - sayKeyedMsg("S2IM0014",[op0,(PAIRP sig =>prefix2String CAR sig;'"?")]) - else sayKeyedMsg("S2IM0015",[op0,formatSignature sig]) - $whereCacheList := [op,:$whereCacheList] - - -- RSS: 6-21-94 - -- The following code ensures that local variables really are local - -- to a function. We will unnecessarily generate preliminary LETs for - -- loop variables and variables that do have LET expressions, but that - -- can be finessed later. - - locals := SETDIFFERENCE(COPY $localVars, parms) - if locals then - lets := [['LET, l, ''UNINITIALIZED__VARIABLE, op] for l in locals] - body := ['PROGN, :lets, body] - - reportFunctionCompilation(op,fnName,parms, - wrapMapBodyWithCatch flattenCOND body,isRecursive) - -compileBody(body,target) == - -- recursively calls the interpreter on the map body - -- returns a triple with the LISP code for body in the value cell - $insideCompileBodyIfTrue: local := true - $genValue: local := false - $declaredMode:local := target - $eval:local:= true - r := interpret1(body,target,nil) - -compileCoerceMap(op,argTypes,mm) == - -- compiles call to user-declared map where the arguments need - -- to be coerced. mm is the modemap for the declared map. - $insideCompileBodyIfTrue: local := true - $genValue: local := false - [[.,:sig],imp,.]:= mm - parms:= [var for var in $FormalMapVariableList for t in CDR sig] - name:= makeLocalModemap(op,[CAR sig,:argTypes]) - argCode := [objVal(coerceInteractive(objNew(arg,t1),t2) or - throwKeyedMsg("S2IC0001",[arg,$mapName,t1,t2])) - for t1 in argTypes for t2 in CDR sig for arg in parms] - $insideCompileBodyIfTrue := false - parms:= [:parms,'envArg] - body := ['SPADCALL,:argCode,['LIST,['function,imp]]] - minivectorName := makeInternalMapMinivectorName(name) - $minivectorNames := [[op,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - compileInteractive [name,['LAMBDA,parms,body]] - CAR sig - -depthOfRecursion(opName,body) == - -- returns the "depth" of recursive calls of opName in body - mapRecurDepth(opName,nil,body) - -mapRecurDepth(opName,opList,body) == - -- walks over the map body counting depth of recursive calls - -- expanding the bodies of maps called in body - atom body => 0 - body is [op,:argl] => - argc:= - atom argl => 0 - argl => "MAX"/[mapRecurDepth(opName,opList,x) for x in argl] - 0 - op in opList => argc - op=opName => 1 + argc - (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => - mapRecurDepth(opName,[op,:opList],getMapBody(op,mapDef)) - + argc - argc - keyedSystemError("S2GE0016",['"mapRecurDepth", - '"unknown function form"]) - -analyzeUndeclaredMap(op,argTypes,mapDef,$mapList) == - -- Computes the signature of the map named op, and compiles the body - $freeVars:local := NIL - $localVars: local := NIL - $env:local:= [[NIL]] - $mapList := [op,:$mapList] - parms:=[var for var in $FormalMapVariableList for m in argTypes] - for m in argTypes for var in parms repeat - put(var,'autoDeclare,'T,$env) - put(var,'mode,m,$env) - body:= getMapBody(op,mapDef) - for lvar in parms repeat mkLocalVar($mapName,lvar) - for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) - (n:= depthOfRecursion(op,body)) = 0 => - analyzeNonRecursiveMap(op,argTypes,body,parms) - analyzeRecursiveMap(op,argTypes,body,parms,n) - -analyzeNonRecursiveMap(op,argTypes,body,parms) == - -- analyze and compile a non-recursive map definition - T := compileBody(body,$mapTarget) - if $mapThrowCount > 0 then - t := objMode T - b := and/[(t = rt) for rt in $mapReturnTypes] - not b => - t := resolveTypeListAny [t,:$mapReturnTypes] - if not $mapTarget then $mapTarget := t - T := compileBody(body,$mapTarget) - sig := [objMode T,:argTypes] - name:= makeLocalModemap(op,sig) - putMapCode(op,objVal T,sig,name,parms,false) - genMapCode(op,objVal T,sig,name,parms,false) - objMode(T) - -analyzeRecursiveMap(op,argTypes,body,parms,n) == - -- analyze and compile a non-recursive map definition - -- makes guess at signature by analyzing non-recursive part of body - -- then re-analyzes the entire body until the signature doesn't change - localMapInfo := saveDependentMapInfo(op, CDR $mapList) - tar := CATCH('interpreter,analyzeNonRecur(op,body,$localVars)) - for i in 0..n until not sigChanged repeat - sigChanged:= false - name := makeLocalModemap(op,sig:=[tar,:argTypes]) - code := compileBody(body,$mapTarget) - objMode(code) ^= tar => - sigChanged:= true - tar := objMode(code) - restoreDependentMapInfo(op, CDR $mapList, localMapInfo) - sigChanged => throwKeyedMsg("S2IM0011",[op]) - putMapCode(op,objVal code,sig,name,parms,true) - genMapCode(op,objVal code,sig,name,parms,true) - tar - -saveDependentMapInfo(op,opList) == - not (op in opList) => - lmml := [[op, :get(op, 'localModemap, $e)]] - gcl := [[op, :get(op, 'generatedCode, $e)]] - for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat - [lmml', :gcl'] := saveDependentMapInfo(dep2, [op, :opList]) - lmms := nconc(lmml', lmml) - gcl := nconc(gcl', gcl) - [lmms, :gcl] - nil - -restoreDependentMapInfo(op, opList, [lmml,:gcl]) == - not (op in opList) => - clearDependentMaps(op,opList) - for [op, :lmm] in lmml repeat - $e := putHist(op,'localModemap,lmm,$e) - for [op, :gc] in gcl repeat - $e := putHist(op,'generatedCode,gc,$e) - -clearDependentMaps(op,opList) == - -- clears the local modemaps of all the maps that depend on op - not (op in opList) => - $e := putHist(op,'localModemap,nil,$e) - $e := putHist(op,'generatedCode,nil,$e) - for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat - clearDependentMaps(dep2,[op,:opList]) - -analyzeNonRecur(op,body,$localVars) == - -- type analyze the non-recursive part of a map body - nrp := nonRecursivePart(op,body) - for lvar in findLocalVars(op,nrp) repeat mkLocalVar($mapName,lvar) - objMode(compileBody(nrp,$mapTarget)) - -nonRecursivePart(opName, funBody) == - -- takes funBody, which is the parse tree of the definition of - -- a function, and returns a list of the parts - -- of the function which are not recursive in the name opName - body:= expandRecursiveBody([opName], funBody) - ((nrp:=nonRecursivePart1(opName, body)) ^= 'noMapVal) => nrp - throwKeyedMsg("S2IM0012",[opName]) - -expandRecursiveBody(alreadyExpanded, body) == - -- replaces calls to other maps with their bodies - atom body => - (obj := get(body,'value,$e)) and objVal obj is ['MAP,:mapDef] and - ((numMapArgs mapDef) = 0) => getMapBody(body,mapDef) - body - body is [op,:argl] => - not (op in alreadyExpanded) => - (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => - newBody:= getMapBody(op,mapDef) - for arg in argl for var in $FormalMapVariableList repeat - newBody:=MSUBST(arg,var,newBody) - expandRecursiveBody([op,:alreadyExpanded],newBody) - [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] - [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] - keyedSystemError("S2GE0016",['"expandRecursiveBody", - '"unknown form of function body"]) - -nonRecursivePart1(opName, funBody) == - -- returns a function body which contains only the parts of funBody - -- which do not call the function opName - funBody is ['IF,a,b,c] => - nra:=nonRecursivePart1(opName,a) - nra = 'noMapVal => 'noMapVal - nrb:=nonRecursivePart1(opName,b) - nrc:=nonRecursivePart1(opName,c) - not (nrb in '(noMapVal noBranch)) => ['IF,nra,nrb,nrc] - not (nrc in '(noMapVal noBranch)) => ['IF,['not,nra],nrc,nrb] - 'noMapVal - not containsOp(funBody,'IF) => - notCalled(opName,funBody) => funBody - 'noMapVal - funBody is [op,:argl] => - op=opName => 'noMapVal - args:= [nonRecursivePart1(opName,arg) for arg in argl] - MEMQ('noMapVal,args) => 'noMapVal - [op,:args] - funBody - -containsOp(body,op) == - -- true IFF body contains an op statement - body is [ =op,:.] => true - body is [.,:argl] => or/[containsOp(arg,op) for arg in argl] - false - -notCalled(opName,form) == - -- returns true if opName is not called in the form - atom form => true - form is [op,:argl] => - op=opName => false - and/[notCalled(opName,x) for x in argl] - keyedSystemError("S2GE0016",['"notCalled", - '"unknown form of function body"]) - -mapDefsWithCorrectArgCount(n, mapDef) == - [def for def in mapDef | (numArgs CAR def) = n] - -numMapArgs(mapDef is [[args,:.],:.]) == - -- returns the number of arguemnts to the map whose body is mapDef - numArgs args - -numArgs args == - args is ['_|,a,:.] => numArgs a - args is ['Tuple,:argl] => #argl - null args => 0 - 1 - -combineMapParts(mapTail) == - -- transforms a piece-wise function definition into an if-then-else - -- statement. Uses noBranch to indicate undefined branch - null mapTail => 'noMapVal - mapTail is [[cond,:part],:restMap] => - isSharpVarWithNum cond or (cond is ['Tuple,:args] and - and/[isSharpVarWithNum arg for arg in args]) or (null cond) => part - ['IF,mkMapPred cond,part,combineMapParts restMap] - keyedSystemError("S2GE0016",['"combineMapParts", - '"unknown function form"]) - -mkMapPred cond == - -- create the predicate on map arguments, derived from "when" clauses - cond is ['_|,args,pred] => mapPredTran pred - cond is ['Tuple,:vals] => - mkValueCheck(vals,1) - mkValCheck(cond,1) - -mkValueCheck(vals,i) == - -- creates predicate for specific value check (i.e f 1 == 1) - vals is [val] => mkValCheck(val,i) - ['and,mkValCheck(first vals,i),mkValueCheck(rest vals,i+1)] - -mkValCheck(val,i) == - -- create equality check for map predicates - isSharpVarWithNum val => 'true - ['_=,mkSharpVar i,val] - -mkSharpVar i == - -- create #i - INTERN CONCAT('"#",STRINGIMAGE i) - -mapPredTran pred == - -- transforms "x in i..j" to "x>=i and x<=j" - pred is ['in,var,['SEGMENT,lb]] => mkLessOrEqual(lb,var) - pred is ['in,var,['SEGMENT,lb,ub]] => - null ub => mkLessOrEqual(lb,var) - ['and,mkLessOrEqual(lb,var),mkLessOrEqual(var,ub)] - pred - -findLocalVars(op,form) == - -- analyzes form for local and free variables, and returns the list - -- of locals - findLocalVars1(op,form) - $localVars - -findLocalVars1(op,form) == - -- sets the two lists $localVars and $freeVars - atom form => - not IDENTP form or isSharpVarWithNum form => nil - isLocalVar(form) or isFreeVar(form) => nil - mkFreeVar($mapName,form) - form is ['local, :vars] => - for x in vars repeat - ATOM x => mkLocalVar(op, x) - form is ['free, :vars] => - for x in vars repeat - ATOM x => mkFreeVar(op, x) - form is ['LET,a,b] => - (a is ['Tuple,:vars]) and (b is ['Tuple,:vals]) => - for var in vars for val in vals repeat - findLocalVars1(op,['LET,var,val]) - a is ['construct,:pat] => - for var in listOfVariables pat repeat mkLocalVar(op,var) - findLocalVars1(op,b) - (atom a) or (a is ['_:,a,.]) => - mkLocalVar(op,a) - findLocalVars1(op,b) - findLocalVars(op,b) - for x in a repeat findLocalVars1(op,x) - form is ['_:,a,.] => - mkLocalVar(op,a) - form is ['is,l,pattern] => - findLocalVars1(op,l) - for var in listOfVariables CDR pattern repeat mkLocalVar(op,var) - form is [oper,:itrl,body] and MEMQ(oper,'(REPEAT COLLECT)) => - findLocalsInLoop(op,itrl,body) - form is [y,:argl] => - y is 'Record => nil - for x in argl repeat findLocalVars1(op,x) - keyedSystemError("S2IM0020",[op]) - -findLocalsInLoop(op,itrl,body) == - for it in itrl repeat - it is ['STEP,index,lower,step,:upperList] => - mkLocalVar(op,index) - findLocalVars1(op,lower) - for up in upperList repeat findLocalVars1(op,up) - it is ['IN,index,s] => - mkLocalVar(op,index) ; findLocalVars1(op,s) - it is ['WHILE,b] => - findLocalVars1(op,b) - it is ['_|,pred] => - findLocalVars1(op,pred) - findLocalVars1(op,body) - for it in itrl repeat - it is [op,b] and (op in '(UNTIL)) => - findLocalVars1(op,b) - -isLocalVar(var) == member(var,$localVars) - -mkLocalVar(op,var) == - -- add var to the local variable list - isFreeVar(var) => $localVars - $localVars:= insert(var,$localVars) - -isFreeVar(var) == member(var,$freeVars) - -mkFreeVar(op,var) == - -- op here for symmetry with mkLocalVar - $freeVars:= insert(var,$freeVars) - -listOfVariables pat == - -- return a list of the variables in pat, which is an "is" pattern - IDENTP pat => (pat='_. => nil ; [pat]) - pat is ['_:,var] or pat is ['_=,var] => - (var='_. => NIL ; [var]) - PAIRP pat => REMDUP [:listOfVariables p for p in pat] - nil - -getMapBody(op,mapDef) == - -- looks in $e for a map body; if not found it computes then stores it - get(op,'mapBody,$e) or - combineMapParts mapDef --- $e:= putHist(op,'mapBody,body:= combineMapParts mapDef,$e) --- body - -getLocalVars(op,body) == - -- looks in $e for local vars; if not found, computes then stores them - get(op,'localVars,$e) or - $e:= putHist(op,'localVars,lv:=findLocalVars(op,body),$e) - lv - --- DO NOT BELIEVE ALL OF THE FOLLOWING (IT IS OLD) - --- VARIABLES. Variables may or may not have a mode property. If --- present, any value which is assigned or generated by that variable --- is first coerced to that mode before being assigned or returned. --- --- --- Variables are given a triple [val,m,e] as a "value" property on --- its property list in the environment. The expression val has the --- forms: --- --- (WRAPPED . y) --value of x is y (don't re-evaluate) --- y --anything else --value of x is obtained by evaluating y --- --- A wrapped expression is created by an assignment. In the second --- case, y can never contain embedded wrapped expressions. The mode --- part m of the triple is the type of y in the wrapped case and is --- consistent with the declared mode if given. The mode part of an --- unwrapped value is always $EmptyMode. The e part is usually NIL --- but may be used to hold a partial closure. --- --- Effect of changes. A rule can be built up for a variable by --- successive rules involving conditional expressions. However, once --- a value is assigned to the variable or an unconditional definition --- is given, any existing value is replaced by the new entry. When --- the mode of a variable is declared, an wrapped value is coerced to --- the new mode; if this is not possible, the user is notified that --- the current value is discarded and why. When the mode is --- redeclared and an upwrapped value is present, the value is --- retained; the only other effect is to coerce any cached values --- from the old mode to the new one. --- --- Caches. When a variable x is evaluated and re-evaluation occurs, --- the triple produced by that evaluation is stored under "cache" on --- the property list of x. This cached triple is cleared whenever any --- of the variables which x's value depend upon change. Dependencies --- are stored on $dependencies whose value has the form [[a b ..] ..] --- to indicate that when a is changed, b .. must have all cached --- values destroyed. In the case of parameterized forms which are --- represented by maps, we currently can cache values only when the --- compiler option is turned on by )on c s meaning "on compiler with --- the save option". When f is compiled as f;1, it then has an alist --- f;1;AL which records these values. If f depends globally on a's --- value, all cached values of all local functions defined for f have --- to be declared. If a's mode should change, then all compilations --- of f must be thrown away. --- --- PARAMETERIZED FORMS. These always have values [val,m,e] where val --- are "maps". --- --- The structure of maps: --- (MAP (pattern . rewrite) ...) where --- pattern has forms: arg-pattern --- (Tuple arg-pattern ...) --- rewrite has forms: (WRAPPED . value) --don't re-evaluate --- computational object --don't (bother to) --- re-evaluate --- anything else --yes, re-evaluate --- --- When assigning values to a map, each new value must have a type --- which is consistent with those already assigned. Initially, type --- of MAP is $EmptyMode. When the map is first assigned a value, the --- type of the MAP is RPLACDed to be (Mapping target source ..). --- When the map is next assigned, the type of both source and target --- is upgraded to be consistent with those values already computed. --- Of course, if new and old source and target are identical, nothing --- need happen to existing entries. However, if the new and old are --- different, all existing entries of the map are coerce to the new --- data type. --- --- Mode analysis. This is done on the bottomUp phase of the process. --- If a function has been given a mapping declaration, this map is --- placed in as the mode of the map under the "value" property of the --- variable. Of course, these modes may be partial types in case a --- mode analysis is still necessary. If no mapping declaration, a --- total mode analysis of the function, given its input arguments, is --- done. This will result a signature involving types only. --- --- If the compiler is on, the function is then compiled given this --- signature involving types. If the map is value of a variable f, a --- function is given name f;1, f is given a "localModemap" property --- with modemap ((dummy target source ..) (T f;1)) so that the next --- time f is applied to arguments which coerce to the source --- arguments of this local modemap, f;1 will be invoked. -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-resolv.boot b/src/interp/i-resolv.boot new file mode 100644 index 00000000..ec359b1c --- /dev/null +++ b/src/interp/i-resolv.boot @@ -0,0 +1,800 @@ +-- 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. + + +import '"i-object" +)package "BOOT" + +resolveTypeList u == + u is [a,:tail] => + + -- if the list consists entirely of variables then keep it explicit + allVars := + a is ['Variable,v] => [v] + nil + while allVars for b in tail repeat + allVars := + b is ['Variable,v] => insert(v, allVars) + nil + allVars => + null rest allVars => ['Variable, first allVars] + ['OrderedVariableList,nreverse allVars] + + for md in tail repeat + a := resolveTT(md,a) + null a => return nil + a + throwKeyedMsg("S2IR0002",NIL) + +-- resolveTT is in CLAMMED BOOT + +resolveTypeListAny tl == + rt := resolveTypeList tl + null rt => $Any + rt + +resolveTTAny(t1,t2) == + (t3 := resolveTT(t1, t2)) => t3 + $Any + +resolveTT1(t1,t2) == + -- this is the main symmetric resolve + -- first it looks for equal constructors on both sides + -- then it tries to use a rewrite rule + -- and finally it builds up a tower + t1=t2 => t1 + (t1 = '$NoValueMode) or (t2 = '$NoValueMode) => NIL + (t1 = $Void) or (t2 = $Void) => $Void + (t1 = $Any) or (t2 = $Any) => $Any + t1 = '(Exit) => t2 + t2 = '(Exit) => t1 + t1 is ['Union,:.] => resolveTTUnion(t1,t2) + t2 is ['Union,:.] => resolveTTUnion(t2,t1) + STRINGP(t1) => + t2 = $String => t2 + NIL + STRINGP(t2) => + t1 = $String => t1 + NIL + null acceptableTypesToResolve(t1,t2) => NIL + if compareTT(t1,t2) then + t := t1 + t1 := t2 + t2 := t + (t := resolveTTSpecial(t1,t2)) and isValidType t => t + (t := resolveTTSpecial(t2,t1)) and isValidType t => t + isSubTowerOf(t1,t2) and canCoerceFrom(t1,t2) => t2 + isSubTowerOf(t2,t1) and canCoerceFrom(t2,t1) => t1 + t := resolveTTRed(t1,t2) => t + t := resolveTTCC(t1,t2) => t + (t := resolveTTEq(t1,t2)) and isValidType t => t + [c1,:arg1] := deconstructT t1 + arg1 and + [c2,:arg2] := deconstructT t2 + arg2 and + t := resolveTT1(last arg1,last arg2) + t and ( resolveTT2(c1,c2,arg1,arg2,t) or + resolveTT2(c2,c1,arg2,arg1,t) ) + +acceptableTypesToResolve(t1,t2) == + -- this is temporary. It ensures that two types that have coerces + -- that really should be converts don't automatically resolve. + -- when the coerces go away, so will this. + acceptableTypesToResolve1(t1,t2) and + acceptableTypesToResolve1(t2,t1) + +acceptableTypesToResolve1(t1,t2) == + t1 = $Integer => + t2 = $String => NIL + true + t1 = $DoubleFloat or t1 = $Float => + t2 = $String => NIL + t2 = '(RationalNumber) => NIL + t2 = [$QuotientField, $Integer] => NIL + true + true + +resolveTT2(c1,c2,arg1,arg2,t) == + -- builds a tower and tests for all the necessary coercions + t0 := constructM(c2,replaceLast(arg2,t)) + canCoerceFrom(t,t0) and + t1 := constructM(c1,replaceLast(arg1,t0)) + canCoerceFrom(t0,t1) and t1 + +resolveTTUnion(t1 is ['Union,:doms],t2) == + unionDoms1 := + doms and first doms is [":",:.] => + tagged := true + [t for [.,.,t] in doms] + tagged := false + doms + member(t2,unionDoms1) => t1 + tagged => NIL + t2 isnt ['Union,:doms2] => + ud := nil + bad := nil + for d in doms while ^bad repeat + d = '"failed" => ud := [d,:ud] + null (d' := resolveTT(d,t2)) => bad := true + ud := [d',:ud] + bad => NIL + ['Union,:REMDUP reverse ud] + ud := nil + bad := nil + for d in doms2 while ^bad repeat + d = '"failed" => ud := append(ud,[d]) + null (d' := resolveTTUnion(t1,d)) => bad := true + ud := append(ud,CDR d') + bad => NIL + ['Union,:REMDUP ud] + +resolveTTSpecial(t1,t2) == + -- tries to resolve things that would otherwise get mangled in the + -- rest of the resolve world. I'll leave it for Albi to fix those + -- things. (RSS 1/-86) + + -- following is just an efficiency hack + (t1 = '(Symbol) or t1 is ['OrderedVariableList,.]) and PAIRP(t2) and + CAR(t2) in '(Polynomial RationalFunction) => t2 + + (t1 = '(Symbol)) and ofCategory(t2, '(IntegerNumberSystem)) => + resolveTT1(['Polynomial, t2], t2) + + t1 = '(AlgebraicNumber) and (t2 = $Float or t2 = $DoubleFloat) => + ['Expression, t2] + t1 = '(AlgebraicNumber) and (t2 = ['Complex, $Float] or t2 = ['Complex, $DoubleFloat]) => + ['Expression, CADR t2] + + t1 = '(AlgebraicNumber) and t2 is ['Complex,.] => + resolveTT1('(Expression (Integer)), t2) + + t1 is ['SimpleAlgebraicExtension,F,Rep,poly] => + t2 = Rep => t1 + t2 is ['UnivariatePolynomial,x,R] and (t3 := resolveTT(t1, R)) => + ['UnivariatePolynomial,x,t3] + t2 is ['Variable,x] and (t3 := resolveTT(t1, F)) => + ['UnivariatePolynomial,x,t3] + t2 is ['Polynomial,R] and (R' := resolveTT(Rep, t2)) => + R' = Rep => t1 + ['Polynomial,t1] + canCoerceFrom(t2,F) => t1 + nil + t1 = $PositiveInteger and ofCategory(t2,'(Ring)) => + resolveTT1($Integer,t2) + t1 = $NonNegativeInteger and ofCategory(t2,'(Ring)) => + resolveTT1($Integer,t2) + t1 is ['OrderedVariableList,[x]] => resolveTTSpecial(['Variable, x], t2) + t1 is ['OrderedVariableList,vl] => + ofCategory(t2,'(Ring)) => resolveTT(['Polynomial,'(Integer)],t2) + resolveTT($Symbol,t2) + t1 is ['Variable,x] => + EQCAR(t2,'SimpleAlgebraicExtension) => resolveTTSpecial(t2,t1) + t2 is ['UnivariatePolynomial,y,S] => + x = y => t2 + resolveTT1(['UnivariatePolynomial,x,'(Integer)],t2) + t2 is ['Variable,y] => + x = y => t1 +-- ['OrderedVariableList, MSORT [x,y]] + $Symbol + t2 = '(Symbol) => t2 + t2 is ['Polynomial,.] => t2 + t2 is ['OrderedVariableList, vl] and member(x,vl) => t2 + isPolynomialMode t2 => nil + ofCategory(t2, '(IntegerNumberSystem)) => resolveTT(['Polynomial, t2], t2) + resolveTT(['Polynomial,'(Integer)],t2) + t1 is ['FunctionCalled,f] and t2 is ['FunctionCalled,g] => + null (mf := get(f,'mode,$e)) => NIL + null (mg := get(g,'mode,$e)) => NIL + mf ^= mg => NIL + mf + t1 is ['UnivariatePolynomial,x,S] => + EQCAR(t2,'Variable) => + resolveTTSpecial(t2,t1) + EQCAR(t2,'SimpleAlgebraicExtension) => + resolveTTSpecial(t2,t1) + t2 is ['UnivariatePolynomial,y,T] => + (x = y) and (U := resolveTT1(S,T)) and ['UnivariatePolynomial,x,U] + nil + t1 = '(Pi) => + t2 is ['Complex,d] => defaultTargetFE t2 + t2 is ['AlgebraicNumber] => defaultTargetFE t2 + EQCAR(t2, 'Variable) or t2 = $Symbol => + defaultTargetFE($Symbol) + t2 is ['Polynomial, .] or t2 is ['Fraction, ['Polynomial, .]] => + defaultTargetFE(t2) + nil + t1 is ['Polynomial,['Complex,u1]] and t2 is ['Complex,u2] => + resolveTT1(t1,u2) + t1 is ['Polynomial,R] and t2 is ['Complex,S] => + containsPolynomial(S) => resolveTT1(['Polynomial,['Complex,R]],t2) + ['Polynomial,['Complex,resolveTT1(R,S)]] + t1 is ['Expression, R] and t2 is ['Complex,S] => + dom' := resolveTT(R, t2) + null dom' => nil + ['Expression, dom'] + t1 is ['Segment, dom] and t2 isnt ['Segment,.] => + dom' := resolveTT(dom, t2) + null dom' => nil + ['Segment, dom'] + nil + +resolveTTCC(t1,t2) == + -- tries to use canCoerceFrom information to see if types can be + -- coerced to one another + gt21 := GGREATERP(t2,t1) + (c12 := canCoerceFrom(t1,t2)) and gt21 => t2 + c21 := canCoerceFrom(t2,t1) + null (c12 or c21) => NIL + c12 and not c21 => t2 + c21 and not c12 => t1 + -- both are coerceable to each other + if gt21 then t1 else t2 + +resolveTTEq(t1,t2) == + -- tries to find the constructor of t1 somewhere in t2 (or vice versa) + -- and move the other guy to the top + [c1,:arg1] := deconstructT t1 + [c2,:arg2] := deconstructT t2 + t := resolveTTEq1(c1,arg1,[c2,arg2]) => t + t := ( arg1 and resolveTTEq2(c2,arg2,[c1,arg1]) ) => t + arg2 and resolveTTEq2(c1,arg1,[c2,arg2]) + +resolveTTEq1(c1,arg1,TL is [c2,arg2,:.]) == + -- takes care of basic types and of types with the same constructor + -- calls resolveTT1 on the arguments in the second case + null arg1 and null arg2 => + canCoerceFrom(c1,c2) => constructTowerT(c2,CDDR TL) + canCoerceFrom(c2,c1) and constructTowerT(c1,CDDR TL) + c1=c2 and + [c2,arg2,:TL] := bubbleType TL + until null arg1 or null arg2 or not t repeat + t := resolveTT1(CAR arg1,CAR arg2) => + arg := CONS(t,arg) + arg1 := CDR arg1 + arg2 := CDR arg2 + t and null arg1 and null arg2 and + t0 := constructM(c1,nreverse arg) + constructTowerT(t0,TL) + +resolveTTEq2(c1,arg1,TL is [c,arg,:.]) == + -- tries to resolveTTEq the type [c1,arg1] with the last argument + -- of the type represented by TL + [c2,:arg2] := deconstructT last arg + TL := [c2,arg2,:TL] + t := resolveTTEq1(c1,arg1,TL) => t + arg2 and resolveTTEq2(c1,arg1,TL) + +resolveTTRed(t1,t2) == + -- the same function as resolveTTEq, but instead of testing for + -- constructor equality, it looks whether a rewrite rule can be applied + t := resolveTTRed1(t1,t2,NIL) => t + [c1,:arg1] := deconstructT t1 + t := arg1 and resolveTTRed2(t2,last arg1,[c1,arg1]) => t + [c2,:arg2] := deconstructT t2 + arg2 and resolveTTRed2(t1,last arg2,[c2,arg2]) + +resolveTTRed1(t1,t2,TL) == + -- tries to apply a reduction rule on (Resolve t1 t2) + -- then it creates a type using the result and TL + EQ(t,term1RW(t := ['Resolve,t1,t2],$Res)) and + EQ(t,term1RW(t := ['Resolve,t2,t1],$Res)) => NIL + [c2,:arg2] := deconstructT t2 + [c2,arg2,:TL] := bubbleType [c2,arg2,:TL] + t2 := constructM(c2,arg2) + l := term1RWall(['Resolve,t1,t2],$Res) + for t0 in l until t repeat t := resolveTTRed3 t0 + l and t => constructTowerT(t,TL) + l := term1RWall(['Resolve,t2,t1],$Res) + for t0 in l until t repeat t := resolveTTRed3 t0 + l and t and constructTowerT(t,TL) + +resolveTTRed2(t1,t2,TL) == + -- tries to resolveTTRed t1 and t2 and build a type using TL + t := resolveTTRed1(t1,t2,TL) => t + [c2,:arg2] := deconstructT t2 + arg2 and resolveTTRed2(t1,last arg2,[c2,arg2,:TL]) + +resolveTTRed3(t) == + -- recursive resolveTTRed which handles all subterms of the form + -- (Resolve t1 t2) or subterms which have to be interpreted + atom t => t + t is ['Resolve,a,b] => + ( t1 := resolveTTRed3 a ) and ( t2 := resolveTTRed3 b ) and + resolveTT1(t1,t2) + t is ['Incl,a,b] => member(a,b) and b + t is ['SetDiff,a,b] => intersection(a,b) and SETDIFFERENCE(a,b) + t is ['SetComp,a,b] => + and/[member(x,a) for x in b] and SETDIFFERENCE(a,b) + t is ['SetInter,a,b] => intersection(a,b) + t is ['SetUnion,a,b] => union(a,b) + t is ['VarEqual,a,b] => (a = b) and a + t is ['SetEqual,a,b] => + (and/[member(x,a) for x in b] and "and"/[member(x,b) for x in a]) and a + [( atom x and x ) or ((not cs and x and not interpOp? x and x) + or resolveTTRed3 x) or return NIL + for x in t for cs in GETDATABASE(CAR t, 'COSIG) ] + +interpOp?(op) == + PAIRP(op) and + CAR(op) in '(Incl SetDiff SetComp SetInter SetUnion VarEqual SetEqual) + +--% Resolve Type with Category + +resolveTCat(t,c) == + -- this function attempts to find a type tc of category c such that + -- t can be coerced to tc. NIL returned for failure. + -- Example: t = Integer, c = Field ==> tc = RationalNumber + + -- first check whether t already belongs to c + ofCategory(t,c) => t + + -- if t is built by a parametrized constructor and there is a + -- condition on the parameter that matches the category, try to + -- recurse. An example of this is (G I, Field) -> G RN + + rest(t) and (tc := resolveTCat1(t,c)) => tc + + -- now check some specific niladic categories + c in '((Field) (EuclideanDomain)) and ofCategory(t,'(IntegralDomain))=> + eqType [$QuotientField, t] + + c = '(Field) and t = $Symbol => ['RationalFunction,$Integer] + + c = '(Ring) and t is ['FactoredForm,t0] => ['FactoredRing,t0] + + (t is [t0]) and (sd := getImmediateSuperDomain(t0)) and sd ^= t0 => + resolveTCat(sd,c) + + SIZE(td := deconstructT t) ^= 2=> NIL + SIZE(tc := deconstructT c) ^= 2 => NIL + ut := underDomainOf t + null isValidType(uc := last tc) => NIL + null canCoerceFrom(ut,uc) => NIL + nt := constructT(first td,[uc]) + ofCategory(nt,c) => nt + NIL + +resolveTCat1(t,c) == + -- does the hard work of looking at conditions on under domains + -- if null (ut := getUnderModeOf(t)) then ut := last dt + null (conds := getConditionsForCategoryOnType(t,c)) => NIL +--rest(conds) => NIL -- will handle later + cond := first conds + cond isnt [.,["has", pat, c1],:.] => NIL + rest(c1) => NIL -- make it simple + + argN := 0 + t1 := nil + + for ut in rest t for i in 1.. while (argN = 0) repeat + sharp := INTERNL('"#",STRINGIMAGE i) + sharp = pat => + argN := i + t1 := ut + + null t1 => NIL + null (t1' := resolveTCat(t1,c1)) => NIL + t' := copy t + t'.argN := t1' + t' + +getConditionsForCategoryOnType(t,cat) == + getConditionalCategoryOfType(t,[NIL],['ATTRIBUTE,cat]) + +getConditionalCategoryOfType(t,conditions,match) == + if PAIRP t then t := first t + t in '(Union Mapping Record) => NIL + conCat := GETDATABASE(t,'CONSTRUCTORCATEGORY) + REMDUP CDR getConditionalCategoryOfType1(conCat,conditions,match,[NIL]) + +getConditionalCategoryOfType1(cat,conditions,match,seen) == + cat is ['Join,:cs] or cat is ['CATEGORY,:cs] => + null cs => conditions + getConditionalCategoryOfType1([first cat,:rest cs], + getConditionalCategoryOfType1(first cs,conditions,match,seen), + match,seen) + cat is ['IF,., cond,.] => + matchUpToPatternVars(cond,match,NIL) => + RPLACD(conditions,CONS(cat,CDR conditions)) + conditions + conditions + cat is [catName,:.] and (GETDATABASE(catName,'CONSTRUCTORKIND) = 'category) => + cat in CDR seen => conditions + RPLACD(seen,[cat,:CDR seen]) + subCat := GETDATABASE(catName,'CONSTRUCTORCATEGORY) + -- substitute vars of cat into category + for v in rest cat for vv in $TriangleVariableList repeat + subCat := SUBST(v,vv,subCat) + getConditionalCategoryOfType1(subCat,conditions,match,seen) + conditions + +matchUpToPatternVars(pat,form,patAlist) == + -- tries to match pattern variables (of the # form) in pat + -- against expressions in form. If one is found, it is checked + -- against the patAlist to make sure we are using the same expression + -- each time. + EQUAL(pat,form) => true + isSharpVarWithNum(pat) => + -- see is pattern variable is in alist + (p := assoc(pat,patAlist)) => EQUAL(form,CDR p) + patAlist := [[pat,:form],:patAlist] + true + PAIRP(pat) => + not (PAIRP form) => NIL + matchUpToPatternVars(CAR pat, CAR form,patAlist) and + matchUpToPatternVars(CDR pat, CDR form,patAlist) + NIL + +--% Resolve Type with Mode + +-- only implemented for nullary control-L's (which stand for types) + +resolveTMOrCroak(t,m) == + resolveTM(t,m) or throwKeyedMsg("S2IR0004",[t,m]) + +resolveTM(t,m) == + -- resolves a type with a mode which may be partially specified + startTimingProcess 'resolve + $Subst : local := NIL + $Coerce : local := 'T + t := eqType t + m := eqType SUBSTQ("**",$EmptyMode,m) + tt := resolveTM1(t,m) + result := tt and isValidType tt and eqType tt + stopTimingProcess 'resolve + result + +resolveTM1(t,m) == + -- general resolveTM, which looks for a term variable + -- otherwise it looks whether the type has the same top level + -- constructor as the mode, looks for a rewrite rule, or builds up + -- a tower + t=m => t + m is ['Union,:.] => resolveTMUnion(t,m) + m = '(Void) => m + m = '(Any) => m + m = '(Exit) => t + containsVars m => + isPatternVar m => + p := ASSQ(m,$Subst) => + $Coerce => + tt := resolveTT1(t,CDR p) => RPLACD(p,tt) and tt + NIL + t=CDR p and t + $Subst := CONS(CONS(m,t),$Subst) + t + atom(t) or atom(m) => NIL + (t is ['Record,:tr]) and (m is ['Record,:mr]) and + (tt := resolveTMRecord(tr,mr)) => tt + t is ['Record,:.] or m is ['Record,:.] => NIL + t is ['Variable, .] and m is ['Mapping, :.] => m + t is ['FunctionCalled, .] and m is ['Mapping, :.] => m + if isEqualOrSubDomain(t, $Integer) then + t := $Integer + tt := resolveTMEq(t,m) => tt + $Coerce and + tt := resolveTMRed(t,m) => tt + resolveTM2(t,m) + $Coerce and canCoerceFrom(t,m) and m + +resolveTMRecord(tr,mr) == + #tr ^= #mr => NIL + ok := true + tt := NIL + for ta in tr for ma in mr while ok repeat + -- element is [':,tag,mode] + CADR(ta) ^= CADR(ma) => ok := NIL -- match tags + ra := resolveTM1(CADDR ta, CADDR ma) -- resolve modes + null ra => ok := NIL + tt := CONS([CAR ta,CADR ta,ra],tt) + null ok => NIL + ['Record,nreverse tt] + +resolveTMUnion(t, m is ['Union,:ums]) == + isTaggedUnion m => resolveTMTaggedUnion(t,m) + -- resolves t with a Union type + t isnt ['Union,:uts] => + ums := REMDUP spliceTypeListForEmptyMode([t],ums) + ums' := nil + success := nil + for um in ums repeat + (um' := resolveTM1(t,um)) => + success := true + um' in '(T TRUE) => ums' := [um,:ums'] + ums' := [um',:ums'] + ums' := [um,:ums'] + -- remove any duplicate domains that might have been created + m' := ['Union,:REMDUP reverse ums'] + success => + null CONTAINED('_*_*,m') => m' + t = $Integer => NIL + resolveTM1($Integer,m') + NIL + -- t is actually a Union if we got here + ums := REMDUP spliceTypeListForEmptyMode(uts,ums) + bad := nil + doms := nil + for ut in uts while ^bad repeat + (m' := resolveTMUnion(ut,['Union,:ums])) => + doms := append(CDR m',doms) + bad := true + bad => NIL + ['Union,:REMDUP doms] + +resolveTMTaggedUnion(t, m is ['Union,:ums]) == + NIL + +spliceTypeListForEmptyMode(tl,ml) == + -- splice in tl for occurrence of ** in ml + null ml => nil + ml is [m,:ml'] => + m = "**" => append(tl,spliceTypeListForEmptyMode(tl,ml')) + [m,:spliceTypeListForEmptyMode(tl,ml')] + +resolveTM2(t,m) == + -- resolves t with the last argument of m and builds up a tower + [cm,:argm] := deconstructT m + argm and + tt := resolveTM1(t,last argm) + tt and + ttt := constructM(cm,replaceLast(argm,tt)) + ttt and canCoerceFrom(tt,ttt) and ttt + +resolveTMEq(t,m) == + -- tests whether t and m have the same top level constructor, which, + -- in the case of t, could be bubbled up + (res := resolveTMSpecial(t,m)) => res + [cm,:argm] := deconstructT m + c := containsVars cm + TL := NIL + until b or not t repeat + [ct,:argt] := deconstructT t + b := + c => + SL := resolveTMEq1(ct,cm) + not EQ(SL,'failed) + ct=cm + not b => + TL := [ct,argt,:TL] + t := argt and last argt + b and + t := resolveTMEq2(cm,argm,[ct,argt,:TL]) + if t then for p in SL repeat $Subst := augmentSub(CAR p,CDR p,$Subst) + t + +resolveTMSpecial(t,m) == + -- a few special cases + t = $AnonymousFunction and m is ['Mapping,:.] => m + t is ['Variable,x] and m is ['OrderedVariableList,le] => + isPatternVar le => ['OrderedVariableList,[x]] + PAIRP(le) and member(x,le) => le + NIL + t is ['Fraction, ['Complex, t1]] and m is ['Complex, m1] => + resolveTM1(['Complex, ['Fraction, t1]], m) + t is ['Fraction, ['Polynomial, ['Complex, t1]]] and m is ['Complex, m1] => + resolveTM1(['Complex, ['Fraction, ['Polynomial, t1]]], m) + t is ['Mapping,:lt] and m is ['Mapping,:lm] => + #lt ^= #lm => NIL + l := NIL + ok := true + for at in lt for am in lm while ok repeat + (ok := resolveTM1(at,am)) => l := [ok,:l] + ok and ['Mapping,:reverse l] + t is ['Segment,u] and m is ['UniversalSegment,.] => + resolveTM1(['UniversalSegment, u], m) + NIL + +resolveTMEq1(ct,cm) == + -- ct and cm are type constructors + -- tests for a match from cm to ct + -- the result is a substitution or 'failed + not (CAR ct=CAR cm) => 'failed + SL := NIL + ct := CDR ct + cm := CDR cm + b := 'T + while ct and cm and b repeat + xt := CAR ct + ct := CDR ct + xm := CAR cm + cm := CDR cm + if not (atom xm) and CAR xm = ":" -- i.e. Record + and CAR xt = ":" and CADR xm = CADR xt then + xm := CADDR xm + xt := CADDR xt + b := + xt=xm => 'T + isPatternVar(xm) and + p := ASSQ(xm,$Subst) => xt=CDR p + p := ASSQ(xm,SL) => xt=CDR p + SL := augmentSub(xm,xt,SL) + b => SL + 'failed + +resolveTMEq2(cm,argm,TL) == + -- [cm,argm] is a deconstructed mode, + -- TL is a deconstructed type t + [ct,argt,:TL] := + $Coerce => bubbleType TL + TL + null TL and + null argm => constructM(ct,argt) +-- null argm => NIL + arg := NIL + while argt and argm until not tt repeat + x1 := CAR argt + argt := CDR argt + x2 := CAR argm + argm := CDR argm + tt := resolveTM1(x1,x2) => + arg := CONS(tt,arg) + null argt and null argm and tt and constructM(ct,nreverse arg) + +resolveTMRed(t,m) == + -- looks for an applicable rewrite rule at any level of t and tries + -- to bubble this constructor up to the top to t + TL := NIL + until b or not t repeat + [ct,:argt] := deconstructT t + b := not EQ(t,term1RW(['Resolve,t,m],$ResMode)) and + [c0,arg0,:TL0] := bubbleType [ct,argt,:TL] + null TL0 and + l := term1RWall(['Resolve,constructM(c0,arg0),m],$ResMode) + for t0 in l until t repeat t := resolveTMRed1 t0 + l and t + b or + TL := [ct,argt,:TL] + t := argt and last argt + b and t + +resolveTMRed1(t) == + -- recursive resolveTMRed which handles all subterms of the form + -- (Resolve a b) + atom t => t + t is ['Resolve,a,b] => + ( a := resolveTMRed1 a ) and ( b := resolveTMRed1 b ) and + resolveTM1(a,b) + t is ['Incl,a,b] => PAIRP b and member(a,b) and b + t is ['Diff,a,b] => PAIRP a and member(b,a) and SETDIFFERENCE(a,[b]) + t is ['SetIncl,a,b] => PAIRP b and "and"/[member(x,b) for x in a] and b + t is ['SetDiff,a,b] => PAIRP b and PAIRP b and + intersection(a,b) and SETDIFFERENCE(a,b) + t is ['VarEqual,a,b] => (a = b) and b + t is ['SetComp,a,b] => PAIRP a and PAIRP b and + "and"/[member(x,a) for x in b] and SETDIFFERENCE(a,b) + t is ['SimpleAlgebraicExtension,a,b,p] => -- this is a hack. RSS + ['SimpleAlgebraicExtension, resolveTMRed1 a, resolveTMRed1 b,p] + [( atom x and x ) or resolveTMRed1 x or return NIL for x in t] + +--% Type and Mode Representation + +eqType(t) == + -- looks for an equivalent but more simple type + -- eg, eqType QF I = RN + -- the new algebra orginization no longer uses these sorts of types +-- termRW(t,$TypeEQ) + t + +equiType(t) == + -- looks for an equivalent but expanded type + -- eg, equiType RN == QF I + -- the new algebra orginization no longer uses these sorts of types +-- termRW(t,$TypeEqui) + t + +getUnderModeOf d == + not PAIRP d => NIL +-- n := LASSOC(first d,$underDomainAlist) => d.n ----> $underDomainAlist NOW always NIL + for a in rest d for m in rest destructT d repeat + if m then return a + +--deconstructM(t) == +-- -- M is a type, which may contain type variables +-- -- results in a pair (type constructor . mode arguments) +-- CDR t and constructor? CAR t => +-- dt := destructT CAR t +-- args := [ x for d in dt for y in t | ( x := d and y ) ] +-- c := [ x for d in dt for y in t | ( x := not d and y ) ] +-- CONS(c,args) +-- CONS(t,NIL) + +deconstructT(t) == + -- M is a type, which may contain type variables + -- results in a pair (type constructor . mode arguments) + KDR t and constructor? CAR t => + dt := destructT CAR t + args := [ x for d in dt for y in t | ( x := d and y ) ] + c := [ x for d in dt for y in t | ( x := not d and y ) ] + CONS(c,args) + CONS(t,NIL) + +constructT(c,A) == + -- c is a type constructor, A a list of argument types + A => [if d then POP A else POP c for d in destructT CAR c] + c + +constructM(c,A) == + -- replaces top level RE's or QF's by equivalent types, if possible + containsVars(c) or containsVars(A) => NIL + -- collapses illegal FE's + CAR(c) = $FunctionalExpression => eqType defaultTargetFE CAR A + eqType constructT(c,A) + +replaceLast(A,t) == + -- replaces the last element of the nonempty list A by t (constructively + nreverse RPLACA(reverse A,t) + +destructT(functor)== + -- provides a list of booleans, which indicate whether the arguments + -- to the functor are category forms or not + GETDATABASE(opOf functor,'COSIG) + +constructTowerT(t,TL) == + -- t is a type, TL a list of constructors and argument lists + -- t is embedded into TL + while TL and t repeat + [c,arg,:TL] := TL + t0 := constructM(c,replaceLast(arg,t)) + t := canCoerceFrom(t,t0) and t0 + t + +bubbleType(TL) == + -- tries to move the last constructor in TL upwards + -- uses canCoerceFrom to test whether two constructors can be bubbled + [c1,arg1,:T1] := TL + null T1 or null arg1 => TL + [c2,arg2,:T2] := T1 + t := last arg1 + t2 := constructM(c2,replaceLast(arg2,t)) + arg1 := replaceLast(arg1,t2) + newCanCoerceCommute(c2,c1) or canCoerceCommute(c2, c1) => + bubbleType [c1,arg1,:T2] + TL + +bubbleConstructor(TL) == + -- TL is a nonempty list of type constructors and nonempty argument + -- lists representing a deconstructed type + -- then the lowest constructor is bubbled to the top + [c,arg,:T1] := TL + t := last arg + until null T1 repeat + [c1,arg1,:T1] := T1 + arg1 := replaceLast(arg1,t) + t := constructT(c1,arg1) + constructT(c,replaceLast(arg,t)) + +compareTT(t1,t2) == + -- 'T if type t1 is more nested than t2 + -- otherwise 'T if t1 is lexicographically greater than t2 + EQCAR(t1,$QuotientField) or + MEMQ(opOf t2,[$QuotientField, 'SimpleAlgebraicExtension]) => NIL + CGREATERP(PRIN2CVEC opOf t1,PRIN2CVEC opOf t2) + diff --git a/src/interp/i-resolv.boot.pamphlet b/src/interp/i-resolv.boot.pamphlet deleted file mode 100644 index a9c2e362..00000000 --- a/src/interp/i-resolv.boot.pamphlet +++ /dev/null @@ -1,863 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-resolv.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -new resolution: types and modes - -a type is any term (structure) which can be regarded as a - functor call -a basic type is the call of a nullary functor (e.g. (Integer)), - otherwise it is a structured type (e.g. (Polynomial (Integer))) -a functor together with its non-type arguments is called a - type constructor - -a mode is a type which can be partially specified, i.e. a term - containing term variables -a term variable (denoted by control-L) stands for any nullary or unary function - which was build from type constructors -this means, a term variable can be: - a function LAMBDA ().T, where T is a type - a function LAMBDA (X).T(X), where X is a variable for a type and - T a type containing this variable - a function LAMBDA X.X ("control-L can be disregarded") -examples: - P(control-L) can stand for (Polynomial (RationalFunction (Integer))) - G(control-L(I)) can stand for (Gaussian (Polynomial (Integer))), but also - for (Gaussian (Integer)) - - -Resolution of Two Types - -this symmetric resolution is done the following way: -1. if the same type constructor occurs in both terms, then the - type tower is built around this constructor (resolveTTEq) -2. the next step is to look for two constructors which have an - "algebraic relationship", this means, a rewrite rule is - applicable (e.g. UP(x,I) and MP([x,y],I)) - this is done by resolveTTRed -3. if none of this is true, then a tower of types is built - e.g. resolve P I and G I to P G I - -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"i-object" -)package "BOOT" - -resolveTypeList u == - u is [a,:tail] => - - -- if the list consists entirely of variables then keep it explicit - allVars := - a is ['Variable,v] => [v] - nil - while allVars for b in tail repeat - allVars := - b is ['Variable,v] => insert(v, allVars) - nil - allVars => - null rest allVars => ['Variable, first allVars] - ['OrderedVariableList,nreverse allVars] - - for md in tail repeat - a := resolveTT(md,a) - null a => return nil - a - throwKeyedMsg("S2IR0002",NIL) - --- resolveTT is in CLAMMED BOOT - -resolveTypeListAny tl == - rt := resolveTypeList tl - null rt => $Any - rt - -resolveTTAny(t1,t2) == - (t3 := resolveTT(t1, t2)) => t3 - $Any - -resolveTT1(t1,t2) == - -- this is the main symmetric resolve - -- first it looks for equal constructors on both sides - -- then it tries to use a rewrite rule - -- and finally it builds up a tower - t1=t2 => t1 - (t1 = '$NoValueMode) or (t2 = '$NoValueMode) => NIL - (t1 = $Void) or (t2 = $Void) => $Void - (t1 = $Any) or (t2 = $Any) => $Any - t1 = '(Exit) => t2 - t2 = '(Exit) => t1 - t1 is ['Union,:.] => resolveTTUnion(t1,t2) - t2 is ['Union,:.] => resolveTTUnion(t2,t1) - STRINGP(t1) => - t2 = $String => t2 - NIL - STRINGP(t2) => - t1 = $String => t1 - NIL - null acceptableTypesToResolve(t1,t2) => NIL - if compareTT(t1,t2) then - t := t1 - t1 := t2 - t2 := t - (t := resolveTTSpecial(t1,t2)) and isValidType t => t - (t := resolveTTSpecial(t2,t1)) and isValidType t => t - isSubTowerOf(t1,t2) and canCoerceFrom(t1,t2) => t2 - isSubTowerOf(t2,t1) and canCoerceFrom(t2,t1) => t1 - t := resolveTTRed(t1,t2) => t - t := resolveTTCC(t1,t2) => t - (t := resolveTTEq(t1,t2)) and isValidType t => t - [c1,:arg1] := deconstructT t1 - arg1 and - [c2,:arg2] := deconstructT t2 - arg2 and - t := resolveTT1(last arg1,last arg2) - t and ( resolveTT2(c1,c2,arg1,arg2,t) or - resolveTT2(c2,c1,arg2,arg1,t) ) - -acceptableTypesToResolve(t1,t2) == - -- this is temporary. It ensures that two types that have coerces - -- that really should be converts don't automatically resolve. - -- when the coerces go away, so will this. - acceptableTypesToResolve1(t1,t2) and - acceptableTypesToResolve1(t2,t1) - -acceptableTypesToResolve1(t1,t2) == - t1 = $Integer => - t2 = $String => NIL - true - t1 = $DoubleFloat or t1 = $Float => - t2 = $String => NIL - t2 = '(RationalNumber) => NIL - t2 = [$QuotientField, $Integer] => NIL - true - true - -resolveTT2(c1,c2,arg1,arg2,t) == - -- builds a tower and tests for all the necessary coercions - t0 := constructM(c2,replaceLast(arg2,t)) - canCoerceFrom(t,t0) and - t1 := constructM(c1,replaceLast(arg1,t0)) - canCoerceFrom(t0,t1) and t1 - -resolveTTUnion(t1 is ['Union,:doms],t2) == - unionDoms1 := - doms and first doms is [":",:.] => - tagged := true - [t for [.,.,t] in doms] - tagged := false - doms - member(t2,unionDoms1) => t1 - tagged => NIL - t2 isnt ['Union,:doms2] => - ud := nil - bad := nil - for d in doms while ^bad repeat - d = '"failed" => ud := [d,:ud] - null (d' := resolveTT(d,t2)) => bad := true - ud := [d',:ud] - bad => NIL - ['Union,:REMDUP reverse ud] - ud := nil - bad := nil - for d in doms2 while ^bad repeat - d = '"failed" => ud := append(ud,[d]) - null (d' := resolveTTUnion(t1,d)) => bad := true - ud := append(ud,CDR d') - bad => NIL - ['Union,:REMDUP ud] - -resolveTTSpecial(t1,t2) == - -- tries to resolve things that would otherwise get mangled in the - -- rest of the resolve world. I'll leave it for Albi to fix those - -- things. (RSS 1/-86) - - -- following is just an efficiency hack - (t1 = '(Symbol) or t1 is ['OrderedVariableList,.]) and PAIRP(t2) and - CAR(t2) in '(Polynomial RationalFunction) => t2 - - (t1 = '(Symbol)) and ofCategory(t2, '(IntegerNumberSystem)) => - resolveTT1(['Polynomial, t2], t2) - - t1 = '(AlgebraicNumber) and (t2 = $Float or t2 = $DoubleFloat) => - ['Expression, t2] - t1 = '(AlgebraicNumber) and (t2 = ['Complex, $Float] or t2 = ['Complex, $DoubleFloat]) => - ['Expression, CADR t2] - - t1 = '(AlgebraicNumber) and t2 is ['Complex,.] => - resolveTT1('(Expression (Integer)), t2) - - t1 is ['SimpleAlgebraicExtension,F,Rep,poly] => - t2 = Rep => t1 - t2 is ['UnivariatePolynomial,x,R] and (t3 := resolveTT(t1, R)) => - ['UnivariatePolynomial,x,t3] - t2 is ['Variable,x] and (t3 := resolveTT(t1, F)) => - ['UnivariatePolynomial,x,t3] - t2 is ['Polynomial,R] and (R' := resolveTT(Rep, t2)) => - R' = Rep => t1 - ['Polynomial,t1] - canCoerceFrom(t2,F) => t1 - nil - t1 = $PositiveInteger and ofCategory(t2,'(Ring)) => - resolveTT1($Integer,t2) - t1 = $NonNegativeInteger and ofCategory(t2,'(Ring)) => - resolveTT1($Integer,t2) - t1 is ['OrderedVariableList,[x]] => resolveTTSpecial(['Variable, x], t2) - t1 is ['OrderedVariableList,vl] => - ofCategory(t2,'(Ring)) => resolveTT(['Polynomial,'(Integer)],t2) - resolveTT($Symbol,t2) - t1 is ['Variable,x] => - EQCAR(t2,'SimpleAlgebraicExtension) => resolveTTSpecial(t2,t1) - t2 is ['UnivariatePolynomial,y,S] => - x = y => t2 - resolveTT1(['UnivariatePolynomial,x,'(Integer)],t2) - t2 is ['Variable,y] => - x = y => t1 --- ['OrderedVariableList, MSORT [x,y]] - $Symbol - t2 = '(Symbol) => t2 - t2 is ['Polynomial,.] => t2 - t2 is ['OrderedVariableList, vl] and member(x,vl) => t2 - isPolynomialMode t2 => nil - ofCategory(t2, '(IntegerNumberSystem)) => resolveTT(['Polynomial, t2], t2) - resolveTT(['Polynomial,'(Integer)],t2) - t1 is ['FunctionCalled,f] and t2 is ['FunctionCalled,g] => - null (mf := get(f,'mode,$e)) => NIL - null (mg := get(g,'mode,$e)) => NIL - mf ^= mg => NIL - mf - t1 is ['UnivariatePolynomial,x,S] => - EQCAR(t2,'Variable) => - resolveTTSpecial(t2,t1) - EQCAR(t2,'SimpleAlgebraicExtension) => - resolveTTSpecial(t2,t1) - t2 is ['UnivariatePolynomial,y,T] => - (x = y) and (U := resolveTT1(S,T)) and ['UnivariatePolynomial,x,U] - nil - t1 = '(Pi) => - t2 is ['Complex,d] => defaultTargetFE t2 - t2 is ['AlgebraicNumber] => defaultTargetFE t2 - EQCAR(t2, 'Variable) or t2 = $Symbol => - defaultTargetFE($Symbol) - t2 is ['Polynomial, .] or t2 is ['Fraction, ['Polynomial, .]] => - defaultTargetFE(t2) - nil - t1 is ['Polynomial,['Complex,u1]] and t2 is ['Complex,u2] => - resolveTT1(t1,u2) - t1 is ['Polynomial,R] and t2 is ['Complex,S] => - containsPolynomial(S) => resolveTT1(['Polynomial,['Complex,R]],t2) - ['Polynomial,['Complex,resolveTT1(R,S)]] - t1 is ['Expression, R] and t2 is ['Complex,S] => - dom' := resolveTT(R, t2) - null dom' => nil - ['Expression, dom'] - t1 is ['Segment, dom] and t2 isnt ['Segment,.] => - dom' := resolveTT(dom, t2) - null dom' => nil - ['Segment, dom'] - nil - -resolveTTCC(t1,t2) == - -- tries to use canCoerceFrom information to see if types can be - -- coerced to one another - gt21 := GGREATERP(t2,t1) - (c12 := canCoerceFrom(t1,t2)) and gt21 => t2 - c21 := canCoerceFrom(t2,t1) - null (c12 or c21) => NIL - c12 and not c21 => t2 - c21 and not c12 => t1 - -- both are coerceable to each other - if gt21 then t1 else t2 - -resolveTTEq(t1,t2) == - -- tries to find the constructor of t1 somewhere in t2 (or vice versa) - -- and move the other guy to the top - [c1,:arg1] := deconstructT t1 - [c2,:arg2] := deconstructT t2 - t := resolveTTEq1(c1,arg1,[c2,arg2]) => t - t := ( arg1 and resolveTTEq2(c2,arg2,[c1,arg1]) ) => t - arg2 and resolveTTEq2(c1,arg1,[c2,arg2]) - -resolveTTEq1(c1,arg1,TL is [c2,arg2,:.]) == - -- takes care of basic types and of types with the same constructor - -- calls resolveTT1 on the arguments in the second case - null arg1 and null arg2 => - canCoerceFrom(c1,c2) => constructTowerT(c2,CDDR TL) - canCoerceFrom(c2,c1) and constructTowerT(c1,CDDR TL) - c1=c2 and - [c2,arg2,:TL] := bubbleType TL - until null arg1 or null arg2 or not t repeat - t := resolveTT1(CAR arg1,CAR arg2) => - arg := CONS(t,arg) - arg1 := CDR arg1 - arg2 := CDR arg2 - t and null arg1 and null arg2 and - t0 := constructM(c1,nreverse arg) - constructTowerT(t0,TL) - -resolveTTEq2(c1,arg1,TL is [c,arg,:.]) == - -- tries to resolveTTEq the type [c1,arg1] with the last argument - -- of the type represented by TL - [c2,:arg2] := deconstructT last arg - TL := [c2,arg2,:TL] - t := resolveTTEq1(c1,arg1,TL) => t - arg2 and resolveTTEq2(c1,arg1,TL) - -resolveTTRed(t1,t2) == - -- the same function as resolveTTEq, but instead of testing for - -- constructor equality, it looks whether a rewrite rule can be applied - t := resolveTTRed1(t1,t2,NIL) => t - [c1,:arg1] := deconstructT t1 - t := arg1 and resolveTTRed2(t2,last arg1,[c1,arg1]) => t - [c2,:arg2] := deconstructT t2 - arg2 and resolveTTRed2(t1,last arg2,[c2,arg2]) - -resolveTTRed1(t1,t2,TL) == - -- tries to apply a reduction rule on (Resolve t1 t2) - -- then it creates a type using the result and TL - EQ(t,term1RW(t := ['Resolve,t1,t2],$Res)) and - EQ(t,term1RW(t := ['Resolve,t2,t1],$Res)) => NIL - [c2,:arg2] := deconstructT t2 - [c2,arg2,:TL] := bubbleType [c2,arg2,:TL] - t2 := constructM(c2,arg2) - l := term1RWall(['Resolve,t1,t2],$Res) - for t0 in l until t repeat t := resolveTTRed3 t0 - l and t => constructTowerT(t,TL) - l := term1RWall(['Resolve,t2,t1],$Res) - for t0 in l until t repeat t := resolveTTRed3 t0 - l and t and constructTowerT(t,TL) - -resolveTTRed2(t1,t2,TL) == - -- tries to resolveTTRed t1 and t2 and build a type using TL - t := resolveTTRed1(t1,t2,TL) => t - [c2,:arg2] := deconstructT t2 - arg2 and resolveTTRed2(t1,last arg2,[c2,arg2,:TL]) - -resolveTTRed3(t) == - -- recursive resolveTTRed which handles all subterms of the form - -- (Resolve t1 t2) or subterms which have to be interpreted - atom t => t - t is ['Resolve,a,b] => - ( t1 := resolveTTRed3 a ) and ( t2 := resolveTTRed3 b ) and - resolveTT1(t1,t2) - t is ['Incl,a,b] => member(a,b) and b - t is ['SetDiff,a,b] => intersection(a,b) and SETDIFFERENCE(a,b) - t is ['SetComp,a,b] => - and/[member(x,a) for x in b] and SETDIFFERENCE(a,b) - t is ['SetInter,a,b] => intersection(a,b) - t is ['SetUnion,a,b] => union(a,b) - t is ['VarEqual,a,b] => (a = b) and a - t is ['SetEqual,a,b] => - (and/[member(x,a) for x in b] and "and"/[member(x,b) for x in a]) and a - [( atom x and x ) or ((not cs and x and not interpOp? x and x) - or resolveTTRed3 x) or return NIL - for x in t for cs in GETDATABASE(CAR t, 'COSIG) ] - -interpOp?(op) == - PAIRP(op) and - CAR(op) in '(Incl SetDiff SetComp SetInter SetUnion VarEqual SetEqual) - ---% Resolve Type with Category - -resolveTCat(t,c) == - -- this function attempts to find a type tc of category c such that - -- t can be coerced to tc. NIL returned for failure. - -- Example: t = Integer, c = Field ==> tc = RationalNumber - - -- first check whether t already belongs to c - ofCategory(t,c) => t - - -- if t is built by a parametrized constructor and there is a - -- condition on the parameter that matches the category, try to - -- recurse. An example of this is (G I, Field) -> G RN - - rest(t) and (tc := resolveTCat1(t,c)) => tc - - -- now check some specific niladic categories - c in '((Field) (EuclideanDomain)) and ofCategory(t,'(IntegralDomain))=> - eqType [$QuotientField, t] - - c = '(Field) and t = $Symbol => ['RationalFunction,$Integer] - - c = '(Ring) and t is ['FactoredForm,t0] => ['FactoredRing,t0] - - (t is [t0]) and (sd := getImmediateSuperDomain(t0)) and sd ^= t0 => - resolveTCat(sd,c) - - SIZE(td := deconstructT t) ^= 2=> NIL - SIZE(tc := deconstructT c) ^= 2 => NIL - ut := underDomainOf t - null isValidType(uc := last tc) => NIL - null canCoerceFrom(ut,uc) => NIL - nt := constructT(first td,[uc]) - ofCategory(nt,c) => nt - NIL - -resolveTCat1(t,c) == - -- does the hard work of looking at conditions on under domains - -- if null (ut := getUnderModeOf(t)) then ut := last dt - null (conds := getConditionsForCategoryOnType(t,c)) => NIL ---rest(conds) => NIL -- will handle later - cond := first conds - cond isnt [.,["has", pat, c1],:.] => NIL - rest(c1) => NIL -- make it simple - - argN := 0 - t1 := nil - - for ut in rest t for i in 1.. while (argN = 0) repeat - sharp := INTERNL('"#",STRINGIMAGE i) - sharp = pat => - argN := i - t1 := ut - - null t1 => NIL - null (t1' := resolveTCat(t1,c1)) => NIL - t' := copy t - t'.argN := t1' - t' - -getConditionsForCategoryOnType(t,cat) == - getConditionalCategoryOfType(t,[NIL],['ATTRIBUTE,cat]) - -getConditionalCategoryOfType(t,conditions,match) == - if PAIRP t then t := first t - t in '(Union Mapping Record) => NIL - conCat := GETDATABASE(t,'CONSTRUCTORCATEGORY) - REMDUP CDR getConditionalCategoryOfType1(conCat,conditions,match,[NIL]) - -getConditionalCategoryOfType1(cat,conditions,match,seen) == - cat is ['Join,:cs] or cat is ['CATEGORY,:cs] => - null cs => conditions - getConditionalCategoryOfType1([first cat,:rest cs], - getConditionalCategoryOfType1(first cs,conditions,match,seen), - match,seen) - cat is ['IF,., cond,.] => - matchUpToPatternVars(cond,match,NIL) => - RPLACD(conditions,CONS(cat,CDR conditions)) - conditions - conditions - cat is [catName,:.] and (GETDATABASE(catName,'CONSTRUCTORKIND) = 'category) => - cat in CDR seen => conditions - RPLACD(seen,[cat,:CDR seen]) - subCat := GETDATABASE(catName,'CONSTRUCTORCATEGORY) - -- substitute vars of cat into category - for v in rest cat for vv in $TriangleVariableList repeat - subCat := SUBST(v,vv,subCat) - getConditionalCategoryOfType1(subCat,conditions,match,seen) - conditions - -matchUpToPatternVars(pat,form,patAlist) == - -- tries to match pattern variables (of the # form) in pat - -- against expressions in form. If one is found, it is checked - -- against the patAlist to make sure we are using the same expression - -- each time. - EQUAL(pat,form) => true - isSharpVarWithNum(pat) => - -- see is pattern variable is in alist - (p := assoc(pat,patAlist)) => EQUAL(form,CDR p) - patAlist := [[pat,:form],:patAlist] - true - PAIRP(pat) => - not (PAIRP form) => NIL - matchUpToPatternVars(CAR pat, CAR form,patAlist) and - matchUpToPatternVars(CDR pat, CDR form,patAlist) - NIL - ---% Resolve Type with Mode - --- only implemented for nullary control-L's (which stand for types) - -resolveTMOrCroak(t,m) == - resolveTM(t,m) or throwKeyedMsg("S2IR0004",[t,m]) - -resolveTM(t,m) == - -- resolves a type with a mode which may be partially specified - startTimingProcess 'resolve - $Subst : local := NIL - $Coerce : local := 'T - t := eqType t - m := eqType SUBSTQ("**",$EmptyMode,m) - tt := resolveTM1(t,m) - result := tt and isValidType tt and eqType tt - stopTimingProcess 'resolve - result - -resolveTM1(t,m) == - -- general resolveTM, which looks for a term variable - -- otherwise it looks whether the type has the same top level - -- constructor as the mode, looks for a rewrite rule, or builds up - -- a tower - t=m => t - m is ['Union,:.] => resolveTMUnion(t,m) - m = '(Void) => m - m = '(Any) => m - m = '(Exit) => t - containsVars m => - isPatternVar m => - p := ASSQ(m,$Subst) => - $Coerce => - tt := resolveTT1(t,CDR p) => RPLACD(p,tt) and tt - NIL - t=CDR p and t - $Subst := CONS(CONS(m,t),$Subst) - t - atom(t) or atom(m) => NIL - (t is ['Record,:tr]) and (m is ['Record,:mr]) and - (tt := resolveTMRecord(tr,mr)) => tt - t is ['Record,:.] or m is ['Record,:.] => NIL - t is ['Variable, .] and m is ['Mapping, :.] => m - t is ['FunctionCalled, .] and m is ['Mapping, :.] => m - if isEqualOrSubDomain(t, $Integer) then - t := $Integer - tt := resolveTMEq(t,m) => tt - $Coerce and - tt := resolveTMRed(t,m) => tt - resolveTM2(t,m) - $Coerce and canCoerceFrom(t,m) and m - -resolveTMRecord(tr,mr) == - #tr ^= #mr => NIL - ok := true - tt := NIL - for ta in tr for ma in mr while ok repeat - -- element is [':,tag,mode] - CADR(ta) ^= CADR(ma) => ok := NIL -- match tags - ra := resolveTM1(CADDR ta, CADDR ma) -- resolve modes - null ra => ok := NIL - tt := CONS([CAR ta,CADR ta,ra],tt) - null ok => NIL - ['Record,nreverse tt] - -resolveTMUnion(t, m is ['Union,:ums]) == - isTaggedUnion m => resolveTMTaggedUnion(t,m) - -- resolves t with a Union type - t isnt ['Union,:uts] => - ums := REMDUP spliceTypeListForEmptyMode([t],ums) - ums' := nil - success := nil - for um in ums repeat - (um' := resolveTM1(t,um)) => - success := true - um' in '(T TRUE) => ums' := [um,:ums'] - ums' := [um',:ums'] - ums' := [um,:ums'] - -- remove any duplicate domains that might have been created - m' := ['Union,:REMDUP reverse ums'] - success => - null CONTAINED('_*_*,m') => m' - t = $Integer => NIL - resolveTM1($Integer,m') - NIL - -- t is actually a Union if we got here - ums := REMDUP spliceTypeListForEmptyMode(uts,ums) - bad := nil - doms := nil - for ut in uts while ^bad repeat - (m' := resolveTMUnion(ut,['Union,:ums])) => - doms := append(CDR m',doms) - bad := true - bad => NIL - ['Union,:REMDUP doms] - -resolveTMTaggedUnion(t, m is ['Union,:ums]) == - NIL - -spliceTypeListForEmptyMode(tl,ml) == - -- splice in tl for occurrence of ** in ml - null ml => nil - ml is [m,:ml'] => - m = "**" => append(tl,spliceTypeListForEmptyMode(tl,ml')) - [m,:spliceTypeListForEmptyMode(tl,ml')] - -resolveTM2(t,m) == - -- resolves t with the last argument of m and builds up a tower - [cm,:argm] := deconstructT m - argm and - tt := resolveTM1(t,last argm) - tt and - ttt := constructM(cm,replaceLast(argm,tt)) - ttt and canCoerceFrom(tt,ttt) and ttt - -resolveTMEq(t,m) == - -- tests whether t and m have the same top level constructor, which, - -- in the case of t, could be bubbled up - (res := resolveTMSpecial(t,m)) => res - [cm,:argm] := deconstructT m - c := containsVars cm - TL := NIL - until b or not t repeat - [ct,:argt] := deconstructT t - b := - c => - SL := resolveTMEq1(ct,cm) - not EQ(SL,'failed) - ct=cm - not b => - TL := [ct,argt,:TL] - t := argt and last argt - b and - t := resolveTMEq2(cm,argm,[ct,argt,:TL]) - if t then for p in SL repeat $Subst := augmentSub(CAR p,CDR p,$Subst) - t - -resolveTMSpecial(t,m) == - -- a few special cases - t = $AnonymousFunction and m is ['Mapping,:.] => m - t is ['Variable,x] and m is ['OrderedVariableList,le] => - isPatternVar le => ['OrderedVariableList,[x]] - PAIRP(le) and member(x,le) => le - NIL - t is ['Fraction, ['Complex, t1]] and m is ['Complex, m1] => - resolveTM1(['Complex, ['Fraction, t1]], m) - t is ['Fraction, ['Polynomial, ['Complex, t1]]] and m is ['Complex, m1] => - resolveTM1(['Complex, ['Fraction, ['Polynomial, t1]]], m) - t is ['Mapping,:lt] and m is ['Mapping,:lm] => - #lt ^= #lm => NIL - l := NIL - ok := true - for at in lt for am in lm while ok repeat - (ok := resolveTM1(at,am)) => l := [ok,:l] - ok and ['Mapping,:reverse l] - t is ['Segment,u] and m is ['UniversalSegment,.] => - resolveTM1(['UniversalSegment, u], m) - NIL - -resolveTMEq1(ct,cm) == - -- ct and cm are type constructors - -- tests for a match from cm to ct - -- the result is a substitution or 'failed - not (CAR ct=CAR cm) => 'failed - SL := NIL - ct := CDR ct - cm := CDR cm - b := 'T - while ct and cm and b repeat - xt := CAR ct - ct := CDR ct - xm := CAR cm - cm := CDR cm - if not (atom xm) and CAR xm = ":" -- i.e. Record - and CAR xt = ":" and CADR xm = CADR xt then - xm := CADDR xm - xt := CADDR xt - b := - xt=xm => 'T - isPatternVar(xm) and - p := ASSQ(xm,$Subst) => xt=CDR p - p := ASSQ(xm,SL) => xt=CDR p - SL := augmentSub(xm,xt,SL) - b => SL - 'failed - -resolveTMEq2(cm,argm,TL) == - -- [cm,argm] is a deconstructed mode, - -- TL is a deconstructed type t - [ct,argt,:TL] := - $Coerce => bubbleType TL - TL - null TL and - null argm => constructM(ct,argt) --- null argm => NIL - arg := NIL - while argt and argm until not tt repeat - x1 := CAR argt - argt := CDR argt - x2 := CAR argm - argm := CDR argm - tt := resolveTM1(x1,x2) => - arg := CONS(tt,arg) - null argt and null argm and tt and constructM(ct,nreverse arg) - -resolveTMRed(t,m) == - -- looks for an applicable rewrite rule at any level of t and tries - -- to bubble this constructor up to the top to t - TL := NIL - until b or not t repeat - [ct,:argt] := deconstructT t - b := not EQ(t,term1RW(['Resolve,t,m],$ResMode)) and - [c0,arg0,:TL0] := bubbleType [ct,argt,:TL] - null TL0 and - l := term1RWall(['Resolve,constructM(c0,arg0),m],$ResMode) - for t0 in l until t repeat t := resolveTMRed1 t0 - l and t - b or - TL := [ct,argt,:TL] - t := argt and last argt - b and t - -resolveTMRed1(t) == - -- recursive resolveTMRed which handles all subterms of the form - -- (Resolve a b) - atom t => t - t is ['Resolve,a,b] => - ( a := resolveTMRed1 a ) and ( b := resolveTMRed1 b ) and - resolveTM1(a,b) - t is ['Incl,a,b] => PAIRP b and member(a,b) and b - t is ['Diff,a,b] => PAIRP a and member(b,a) and SETDIFFERENCE(a,[b]) - t is ['SetIncl,a,b] => PAIRP b and "and"/[member(x,b) for x in a] and b - t is ['SetDiff,a,b] => PAIRP b and PAIRP b and - intersection(a,b) and SETDIFFERENCE(a,b) - t is ['VarEqual,a,b] => (a = b) and b - t is ['SetComp,a,b] => PAIRP a and PAIRP b and - "and"/[member(x,a) for x in b] and SETDIFFERENCE(a,b) - t is ['SimpleAlgebraicExtension,a,b,p] => -- this is a hack. RSS - ['SimpleAlgebraicExtension, resolveTMRed1 a, resolveTMRed1 b,p] - [( atom x and x ) or resolveTMRed1 x or return NIL for x in t] - ---% Type and Mode Representation - -eqType(t) == - -- looks for an equivalent but more simple type - -- eg, eqType QF I = RN - -- the new algebra orginization no longer uses these sorts of types --- termRW(t,$TypeEQ) - t - -equiType(t) == - -- looks for an equivalent but expanded type - -- eg, equiType RN == QF I - -- the new algebra orginization no longer uses these sorts of types --- termRW(t,$TypeEqui) - t - -getUnderModeOf d == - not PAIRP d => NIL --- n := LASSOC(first d,$underDomainAlist) => d.n ----> $underDomainAlist NOW always NIL - for a in rest d for m in rest destructT d repeat - if m then return a - ---deconstructM(t) == --- -- M is a type, which may contain type variables --- -- results in a pair (type constructor . mode arguments) --- CDR t and constructor? CAR t => --- dt := destructT CAR t --- args := [ x for d in dt for y in t | ( x := d and y ) ] --- c := [ x for d in dt for y in t | ( x := not d and y ) ] --- CONS(c,args) --- CONS(t,NIL) - -deconstructT(t) == - -- M is a type, which may contain type variables - -- results in a pair (type constructor . mode arguments) - KDR t and constructor? CAR t => - dt := destructT CAR t - args := [ x for d in dt for y in t | ( x := d and y ) ] - c := [ x for d in dt for y in t | ( x := not d and y ) ] - CONS(c,args) - CONS(t,NIL) - -constructT(c,A) == - -- c is a type constructor, A a list of argument types - A => [if d then POP A else POP c for d in destructT CAR c] - c - -constructM(c,A) == - -- replaces top level RE's or QF's by equivalent types, if possible - containsVars(c) or containsVars(A) => NIL - -- collapses illegal FE's - CAR(c) = $FunctionalExpression => eqType defaultTargetFE CAR A - eqType constructT(c,A) - -replaceLast(A,t) == - -- replaces the last element of the nonempty list A by t (constructively - nreverse RPLACA(reverse A,t) - -destructT(functor)== - -- provides a list of booleans, which indicate whether the arguments - -- to the functor are category forms or not - GETDATABASE(opOf functor,'COSIG) - -constructTowerT(t,TL) == - -- t is a type, TL a list of constructors and argument lists - -- t is embedded into TL - while TL and t repeat - [c,arg,:TL] := TL - t0 := constructM(c,replaceLast(arg,t)) - t := canCoerceFrom(t,t0) and t0 - t - -bubbleType(TL) == - -- tries to move the last constructor in TL upwards - -- uses canCoerceFrom to test whether two constructors can be bubbled - [c1,arg1,:T1] := TL - null T1 or null arg1 => TL - [c2,arg2,:T2] := T1 - t := last arg1 - t2 := constructM(c2,replaceLast(arg2,t)) - arg1 := replaceLast(arg1,t2) - newCanCoerceCommute(c2,c1) or canCoerceCommute(c2, c1) => - bubbleType [c1,arg1,:T2] - TL - -bubbleConstructor(TL) == - -- TL is a nonempty list of type constructors and nonempty argument - -- lists representing a deconstructed type - -- then the lowest constructor is bubbled to the top - [c,arg,:T1] := TL - t := last arg - until null T1 repeat - [c1,arg1,:T1] := T1 - arg1 := replaceLast(arg1,t) - t := constructT(c1,arg1) - constructT(c,replaceLast(arg,t)) - -compareTT(t1,t2) == - -- 'T if type t1 is more nested than t2 - -- otherwise 'T if t1 is lexicographically greater than t2 - EQCAR(t1,$QuotientField) or - MEMQ(opOf t2,[$QuotientField, 'SimpleAlgebraicExtension]) => NIL - CGREATERP(PRIN2CVEC opOf t1,PRIN2CVEC opOf t2) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot new file mode 100644 index 00000000..1ab11dc0 --- /dev/null +++ b/src/interp/i-spec1.boot @@ -0,0 +1,1238 @@ +-- 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. + + +import '"i-analy" +)package "BOOT" + + +-- Functions which require special handlers (also see end of file) + +$repeatLabel := NIL +$breakCount := 0 +$anonymousMapCounter := 0 + +$specialOps := '( + ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar + equation error free has IF _is _isnt iterate _break LET _local MDEF _or + pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where ) + +--% Void stuff + +voidValue() == '"()" + +--% Handlers for Anonymous Function Definitions + +upADEF t == + t isnt [.,[vars,types,.,body],pred,.] => NIL + -- do some checking on what we got + for var in vars repeat + if not IDENTP(var) then throwKeyedMsg("S2IS0057",[var]) + -- unabbreviate types + types := [(if t then evaluateType unabbrev t else NIL) for t in types] + -- we do not allow partial types + if isPartialMode(m := first types) then throwKeyedMsg("S2IS0058",[m]) + + -- we want everything to be declared or nothing. The exception is that + -- we do not require a target type since we will compute one anyway. + if null(m) and rest types then + m := first rest types + types' := rest rest types + else + types' := rest types + for type in types' repeat + if (type and null m) or (m and null type) then + throwKeyedMsg("S2IS0059",NIL) + if isPartialMode type then throwKeyedMsg("S2IS0058",[type]) + +-- $localVars: local := nil +-- $freeVars: local := nil +-- $env: local := [[NIL]] + $compilingMap : local := true + + -- if there is a predicate, merge it in with the body + if pred ^= true then body := ['IF,pred,body,'noMapVal] + + tar := getTarget t + null m and tar is ['Mapping,.,:argTypes] and (#vars = #argTypes) => + if isPartialMode tar then throwKeyedMsg("S2IS0058",[tar]) + evalTargetedADEF(t,vars,rest tar,body) + null m => evalUntargetedADEF(t,vars,types,body) + evalTargetedADEF(t,vars,types,body) + +evalUntargetedADEF(t,vars,types,body) == + -- recreate a parse form + if vars is [var] + then vars := var + else vars := ['Tuple,:vars] + val := objNewWrap(["+->",vars,body],$AnonymousFunction) + putValue(t,val) + putModeSet(t,[objMode val]) + +evalTargetedADEF(t,vars,types,body) == + $mapName : local := makeInternalMapName('"anonymousFunction", + #vars,$anonymousMapCounter,'"internal") + $anonymousMapCounter := 1 + $anonymousMapCounter + $compilingMap : local := true -- state that we are trying to compile + $mapThrowCount : local := 0 -- number of "return"s encountered + $mapReturnTypes : local := nil -- list of types from returns + $repeatLabel : local := nil -- for loops; see upREPEAT + $breakCount : local := 0 -- breaks from loops; ditto + + -- now substitute formal names for the parm variables + -- this is used in the interpret-code case, but isn't so bad any way + -- since it makes the bodies look more like regular map bodies + + sublist := [[var,:GENSYM()] for var in vars] + body := sublisNQ(sublist,body) + vars := [CDR v for v in sublist] + + for m in CDR types for var in vars repeat + $env:= put(var,'mode,m,$env) + mkLocalVar($mapName,var) + for lvar in getLocalVars($mapName,body) repeat + mkLocalVar($mapName,lvar) + -- set up catch point for interpret-code mode + x := CATCH('mapCompiler,compileTargetedADEF(t,vars,types,body)) + x = 'tryInterpOnly => mkInterpTargetedADEF(t,vars,types,body) + x + +mkInterpTargetedADEF(t,vars,types,oldBody) == + null first types => + throwKeyedMsg("S2IS0056",NIL) + throwMessage '" map result type needed but not present." + arglCode := ["LIST",:[argCode for type in rest types for var in vars]] + where argCode() == ['putValueValue,['mkAtreeNode,MKQ var], + objNewCode(["wrap",var],type)] + put($mapName,'mapBody,oldBody,$e) + body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types] + compileADEFBody(t,vars,types,body,first types) + +compileTargetedADEF(t,vars,types,body) == + val := compileBody(body,CAR types) + computedResultType := objMode val + body := wrapMapBodyWithCatch flattenCOND objVal val + compileADEFBody(t,vars,types,body,computedResultType) + +compileADEFBody(t,vars,types,body,computedResultType) == +--+ + $compiledOpNameList := [$mapName] + minivectorName := makeInternalMapMinivectorName(PNAME $mapName) + $minivectorNames := [[$mapName,:minivectorName],:$minivectorNames] + body := SUBST(minivectorName,"$$$",body) + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,minivectorName] + SET(minivectorName,LIST2REFVEC $minivector) + + -- The use of the three variables $definingMap, $genValue and $compilingMap + -- is to cover the following cases: + -- + -- $definingMap: This is set in analyzeMap and covers examples like: + -- addx x == ((y: Integer): Integer +-> x + y) + -- g := addx 10 + -- g 3 + -- i.e. we are storing the mapping as an object. + -- + -- $compilingMap: This covers mappings which are created and applied "on the + -- "fly", for example: + -- [map(h +-> D(h, t), v) for v in [t]] + -- + -- $genValue: This seems to be needed when we create a map as an argument + -- for a constructor, e.g.: + -- Dx: LODO(EXPR INT, f +-> D(f, x)) := D() + -- + -- MCD 13/3/96 + if not $definingMap and ($genValue or $compilingMap) then + fun := ["function",["LAMBDA",[:vars,'envArg],body]] + code := wrap timedEVALFUN ['LIST,fun] + else + $freeVariables := [] + $boundVariables := [minivectorName,:vars] + -- CCL does not support upwards funargs, so we check for any free variables + -- and pass them into the lambda as part of envArg. + body := checkForFreeVariables(body,"ALL") + fun := ["function",["LAMBDA",[:vars,'envArg],body]] + code := ["CONS", fun, ["VECTOR", :reverse $freeVariables]] + + val := objNew(code,rt := ['Mapping,computedResultType,:rest types]) + putValue(t,val) + putModeSet(t,[rt]) + +--% Handler for Algebraic Extensions + +upAlgExtension t == + -- handler for algebraic extension declaration. These are of + -- the form "a | a**2+1", and have the effect that "a" is declared + -- to be a simple algebraic extension, with respect to the given + -- polynomial, and given the value "a" in this type. + t isnt [op,var,eq] => nil + null $genValue => throwKeyedMsg("S2IS0001",NIL) + a := getUnname var + clearCmdParts ['propert,a] --clear properties of a + algExtension:= eq2AlgExtension eq + upmode := ['UnivariatePolynomial,a,$EmptyMode] + $declaredMode : local := upmode + putTarget(algExtension,upmode) + ms:= bottomUp algExtension + triple:= getValue algExtension + upmode:= resolveTMOrCroak(objMode(triple),upmode) + null (T:= coerceInteractive(triple,upmode)) => + throwKeyedMsgCannotCoerceWithValue(objVal(triple), + objMode(triple),upmode) + newmode := objMode T + (field := resolveTCat(CADDR newmode,'(Field))) or + throwKeyedMsg("S2IS0002",[eq]) + pd:= ['UnivariatePolynomial,a,field] + null (canonicalAE:= coerceInteractive(T,pd)) => + throwKeyedMsgCannotCoerceWithValue(objVal T,objMode T,pd) + sae:= ['SimpleAlgebraicExtension,field,pd,objValUnwrap canonicalAE] + saeTypeSynonym := INTERN STRCONC('"SAE",STRINGIMAGE a) + saeTypeSynonymValue := objNew(sae,'(Domain)) + fun := getFunctionFromDomain('generator,sae,NIL) + expr:= wrap SPADCALL(fun) + putHist(saeTypeSynonym,'value,saeTypeSynonymValue,$e) + putHist(a,'mode,sae,$e) + putHist(a,'value,T2:= objNew(expr,sae),$e) + clearDependencies(a,true) + if $printTypeIfTrue then + sayKeyedMsg("S2IS0003",NIL) + sayMSG concat ['%l,'" ",saeTypeSynonym,'" := ", + :prefix2String objVal saeTypeSynonymValue] + sayMSG concat ['" ",a,'" : ",saeTypeSynonym,'" := ",a] + putValue(op,T2) + putModeSet(op,[sae]) + +eq2AlgExtension eq == + -- transforms "a=b" to a-b for processing + eq is [op,:l] and VECP op and (getUnname op='equation) => + [mkAtreeNode "-",:l] + eq + +--% Handlers for booleans + +upand x == + -- generates code for and forms. The second argument is only + -- evaluated if the first argument is true. + x isnt [op,term1,term2] => NIL + putTarget(term1,$Boolean) + putTarget(term2,$Boolean) + ms := bottomUp term1 + ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"and_""],term1) + $genValue => + BooleanEquality(objValUnwrap(getValue term1), + getConstantFromDomain('(false),$Boolean)) => + putValue(x,getValue term1) + putModeSet(x,ms) + -- first term is true, so look at the second one + ms := bottomUp term2 + ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) + putValue(x,getValue term2) + putModeSet(x,ms) + + ms := bottomUp term2 + ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) + -- generate an IF expression and let the rest of the code handle it + cond := [mkAtreeNode "=",mkAtree "false",term1] + putTarget(cond,$Boolean) + code := [mkAtreeNode "IF",cond,mkAtree "false",term2] + putTarget(code,$Boolean) + bottomUp code + putValue(x,getValue code) + putModeSet(x,ms) + +upor x == + -- generates code for or forms. The second argument is only + -- evaluated if the first argument is false. + x isnt [op,term1,term2] => NIL + putTarget(term1,$Boolean) + putTarget(term2,$Boolean) + ms := bottomUp term1 + ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"or_""],term1) + $genValue => + BooleanEquality(objValUnwrap(getValue term1), + getConstantFromDomain('(true),$Boolean)) => + putValue(x,getValue term1) + putModeSet(x,ms) + -- first term is false, so look at the second one + ms := bottomUp term2 + ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) + putValue(x,getValue term2) + putModeSet(x,ms) + + ms := bottomUp term2 + ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) + -- generate an IF expression and let the rest of the code handle it + cond := [mkAtreeNode "=",mkAtree "true",term1] + putTarget(cond,$Boolean) + code := [mkAtreeNode "IF",cond,mkAtree "true",term2] + putTarget(code,$Boolean) + bottomUp code + putValue(x,getValue code) + putModeSet(x,ms) + +--% Handlers for case + +upcase t == + t isnt [op,lhs,rhs] => nil + bottomUp lhs + triple := getValue lhs + objMode(triple) isnt ['Union,:unionDoms] => + throwKeyedMsg("S2IS0004",NIL) + if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs' + if first unionDoms is [":",.,.] then + for i in 0.. for d in unionDoms repeat + if d is [":",=rhs,.] then rhstag := i + if NULL rhstag then error '"upcase: bad Union form" + $genValue => + rhstag = first unwrap objVal triple => code := wrap 'TRUE + code := wrap NIL + code := + ["COND", + [["EQL",rhstag,["CAR",["unwrap",objVal triple]]], + ''TRUE], + [''T,NIL]] + else + $genValue => + t' := coerceUnion2Branch triple + rhs = objMode t' => code := wrap 'TRUE + code := wrap NIL + triple' := objNewCode(["wrap",objVal triple],objMode triple) + code := + ["COND", + [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]], + ''TRUE], + [''T,NIL]] + putValue(op,objNew(code,$Boolean)) + putModeSet(op,[$Boolean]) + +--% Handlers for TARGET + +upTARGET t == + -- Evaluates the rhs to a mode,which is used as the target type for + -- the lhs. + t isnt [op,lhs,rhs] => nil + -- do not (yet) support local variables on the rhs + (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => + keyedMsgCompFailure("S2IC0010",[rhs]) + $declaredMode: local := NIL + m:= evaluateType unabbrev rhs + not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) + categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) + $declaredMode:= m + not atom(lhs) and putTarget(lhs,m) + ms := bottomUp lhs + first ms ^= m => + throwKeyedMsg("S2IC0011",[first ms,m]) + putValue(op,getValue lhs) + putModeSet(op,ms) + +--% Handlers for COERCE + +upCOERCE t == + -- evaluate the lhs and then tries to coerce the result to the + -- mode which is the rhs. + -- previous to 5/16/89, this had the same semantics as + -- (lhs@rhs) :: rhs + -- this must be made explicit now. + t isnt [op,lhs,rhs] => nil + $useConvertForCoercions : local := true + -- do not (yet) support local variables on the rhs + (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => + keyedMsgCompFailure("S2IC0006",[rhs]) + $declaredMode: local := NIL + m := evaluateType unabbrev rhs + not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) + categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) + $declaredMode:= m + -- 05/16/89 (RSS) following line commented out to give correct + -- semantic difference between :: and @ + bottomUp lhs + type:=evalCOERCE(op,lhs,m) + putModeSet(op,[type]) + +evalCOERCE(op,tree,m) == + -- the value of tree is coerced to mode m + -- this is not necessary, if the target property of tree was used + v := getValue tree + t1 := objMode(v) + if $genValue and t1 is ['Union,:.] then + v := coerceUnion2Branch v + t1 := objMode(v) + e := objVal(v) + value:= + t1=m => v + t2 := + if isPartialMode m + then + $genValue and (t1 = '(Symbol)) and containsPolynomial m => + resolveTM(['UnivariatePolynomial,objValUnwrap(v),'(Integer)],m) + resolveTM(t1,m) + else m + null t2 => throwKeyedMsgCannotCoerceWithValue(e,t1,m) + $genValue => coerceOrRetract(v,t2) + objNew(getArgValue(tree,t2),t2) + val:= value or throwKeyedMsgCannotCoerceWithValue(e,t1,m) + putValue(op,val) + objMode(val) + +--% Handlers for COLLECT + +transformCollect [:itrl,body] == + -- syntactic transformation for COLLECT form, called from mkAtree1 + iterList:=[:iterTran1 for it in itrl] where iterTran1() == + it is ["STEP",index,lower,step,:upperList] => + [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper + for upper in upperList]]] + it is ["IN",index,s] => + [["IN",index,mkAtree1 s]] + it is ["ON",index,s] => + [['IN,index,mkAtree1 ['tails,s]]] + it is ["WHILE",b] => + [["WHILE",mkAtree1 b]] + it is ["|",pred] => + [["SUCHTHAT",mkAtree1 pred]] + it is [op,:.] and (op in '(VALUE UNTIL)) => nil + bodyTree:=mkAtree1 body + iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where + iterTran2() == + it is ["STEP",:.] => nil + it is ["IN",:.] => nil + it is ["ON",:.] => nil + it is ["WHILE",:.] => nil + it is [op,b] and (op in '(UNTIL)) => + [[op,mkAtree1 b]] + it is ["|",pred] => nil + keyedSystemError("S2GE0016", + ['"transformCollect",'"Unknown type of iterator"]) + [:iterList,bodyTree] + +upCOLLECT t == + -- $compilingLoop variable insures that throw to interp-only mode + -- goes to the outermost loop. + $compilingLoop => upCOLLECT1 t + upCOLLECT0 t + +upCOLLECT0 t == + -- sets up catch point for interpret-code mode + $compilingLoop: local := true + ms:=CATCH('loopCompiler,upCOLLECT1 t) + ms = 'tryInterpOnly => interpOnlyCOLLECT t + ms + +upCOLLECT1 t == + t isnt [op,:itrl,body] => nil + -- upCOLLECT with compiled body + if (target := getTarget t) and not getTarget(body) then + if target is [agg,S] and agg in '(List Vector Stream InfiniteTuple) then + putTarget(body,S) + $interpOnly => interpCOLLECT(op,itrl,body) + isStreamCollect itrl => collectStream(t,op,itrl,body) + upLoopIters itrl + ms:= bottomUpCompile body + [m]:= ms + for itr in itrl repeat + itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") + mode:= ['Tuple,m] + evalCOLLECT(op,rest t,mode) + putModeSet(op,[mode]) + +upLoopIters itrl == + -- type analyze iterator loop iterators + for iter in itrl repeat + iter is ["WHILE",pred] => + bottomUpCompilePredicate(pred,'"while") + iter is ["SUCHTHAT",pred] => + bottomUpCompilePredicate(pred,'"|") + iter is ["UNTIL",:.] => + NIL -- handle after body is analyzed + iter is ["IN",index,s] => + upLoopIterIN(iter,index,s) + iter is ["STEP",index,lower,step,:upperList] => + upLoopIterSTEP(index,lower,step,upperList) + -- following is an optimization + typeIsASmallInteger(get(index,'mode,$env)) => + RPLACA(iter,'ISTEP) + NIL -- should have error msg here? + +upLoopIterIN(iter,index,s) == + iterMs := bottomUp s + + null IDENTP index => throwKeyedMsg("S2IS0005",[index]) + + if $genValue and first iterMs is ['Union,:.] then + v := coerceUnion2Branch getValue s + m := objMode v + putValue(s,v) + putMode(s,m) + iterMs := [m] + putModeSet(s,iterMs) + + -- transform segment variable into STEP + iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => + lower := [mkAtreeNode 'lo,s] + step := [mkAtreeNode 'incr, s] + upperList := + CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] + NIL + upLoopIterSTEP(index,lower,step,upperList) + newIter := ['STEP,index,lower,step,:upperList] + RPLACA(iter,CAR newIter) + RPLACD(iter,CDR newIter) + + iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index]) + put(index,'mode,ud,$env) + mkLocalVar('"the iterator expression",index) + +upLoopIterSTEP(index,lower,step,upperList) == + null IDENTP index => throwKeyedMsg("S2IS0005",[index]) + ltype := IFCAR bottomUpUseSubdomain(lower) + not (typeIsASmallInteger(ltype) or isEqualOrSubDomain(ltype,$Integer))=> + throwKeyedMsg("S2IS0007",['"lower"]) + stype := IFCAR bottomUpUseSubdomain(step) + not (typeIsASmallInteger(stype) or isEqualOrSubDomain(stype,$Integer))=> + throwKeyedMsg("S2IS0008",NIL) + types := [ltype] + utype := nil + for upper in upperList repeat + utype := IFCAR bottomUpUseSubdomain(upper) + not (typeIsASmallInteger(utype) or isEqualOrSubDomain(utype,$Integer))=> + throwKeyedMsg("S2IS0007",['"upper"]) + if utype then types := [utype, :types] + else types := [stype, :types] + type := resolveTypeListAny REMDUP types + put(index,'mode,type,$env) + mkLocalVar('"the iterator expression",index) + +evalCOLLECT(op,[:itrl,body],m) == + iters := [evalLoopIter itr for itr in itrl] + bod := getArgValue(body,computedMode body) + if bod isnt ['SPADCALL,:.] then bode := ['unwrap,bod] + code := timedOptimization asTupleNewCode0 ['COLLECT,:iters,bod] + if $genValue then code := wrap timedEVALFUN code + putValue(op,objNew(code,m)) + +falseFun(x) == nil + +evalLoopIter itr == + -- generate code for loop iterator + itr is ['STEP,index,lower,step,:upperList] => + ['STEP,getUnname index,getArgValue(lower,$Integer), + getArgValue(step,$Integer), + :[getArgValue(upper,$Integer) for upper in upperList]] + itr is ['ISTEP,index,lower,step,:upperList] => + ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), + getArgValue(step,$SmallInteger), + :[getArgValue(upper,$SmallInteger) for upper in upperList]] + itr is ['IN,index,s] => + ['IN,getUnname index,getArgValue(s,['List,get(index,'mode,$env)])] + (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => + [x,getArgValue(pred,$Boolean)] + +interpCOLLECT(op,itrl,body) == + -- interpret-code mode COLLECT handler + $collectTypeList: local := NIL + $indexVars: local := NIL + $indexTypes: local := NIL + emptyAtree op + emptyAtree itrl + emptyAtree body + code := ['COLLECT,:[interpIter itr for itr in itrl], + interpCOLLECTbody(body,$indexVars,$indexTypes)] + value := timedEVALFUN code + t := + null value => '(None) + last $collectTypeList + rm := ['Tuple,t] + value := [objValUnwrap coerceInteractive(objNewWrap(v,m),t) + for v in value for m in $collectTypeList] + putValue(op,objNewWrap(asTupleNew(#value, value),rm)) + putModeSet(op,[rm]) + +interpIter itr == + -- interpret loop iterator + itr is ['STEP,index,lower,step,:upperList] => + $indexVars:= [getUnname index,:$indexVars] + [m]:= bottomUp lower + $indexTypes:= [m,:$indexTypes] + for up in upperList repeat bottomUp up + ['STEP,getUnname index,getArgValue(lower,$Integer), + getArgValue(step,$Integer), + :[getArgValue(upper,$Integer) for upper in upperList]] + itr is ['ISTEP,index,lower,step,:upperList] => + $indexVars:= [getUnname index,:$indexVars] + [m]:= bottomUp lower + $indexTypes:= [m,:$indexTypes] + for up in upperList repeat bottomUp up + ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), + getArgValue(step,$SmallInteger), + :[getArgValue(upper,$SmallInteger) for upper in upperList]] + itr is ['IN,index,s] => + $indexVars:=[getUnname index,:$indexVars] + [m]:= bottomUp s + m isnt ['List,um] => throwKeyedMsg("S2IS0009",[m]) + $indexTypes:=[um,:$indexTypes] + ['IN,getUnname index,getArgValue(s,m)] + (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => + [x,interpLoop(pred,$indexVars,$indexTypes,$Boolean)] + +interpOnlyCOLLECT t == + -- called when compilation failed in COLLECT body, not in compiling map + $genValue: local := true + $interpOnly: local := true + upCOLLECT t + +interpCOLLECTbody(expr,indexList,indexTypes) == + -- generate code for interpret-code collect + ['interpCOLLECTbodyIter,MKQ expr,MKQ indexList,['LIST,:indexList], + MKQ indexTypes] + +interpCOLLECTbodyIter(exp,indexList,indexVals,indexTypes) == + -- execute interpret-code collect body. keeps list of type of + -- elements in list in $collectTypeList. + emptyAtree exp + for i in indexList for val in indexVals for type in indexTypes repeat + put(i,'value,objNewWrap(val,type),$env) + [m]:=bottomUp exp + $collectTypeList:= + null $collectTypeList => [rm:=m] + [:$collectTypeList,rm:=resolveTT(m,last $collectTypeList)] + null rm => throwKeyedMsg("S2IS0010",NIL) + value:= + rm ^= m => coerceInteractive(getValue exp,rm) + getValue exp + objValUnwrap(value) + +--% Stream Collect functions + +isStreamCollect itrl == + -- calls bottomUp on iterators and if any of them are streams + -- then whole shebang is a stream + isStream := false + for itr in itrl until isStream repeat + itr is ['IN,.,s] => + iterMs := bottomUp s + iterMs is [['Stream,:.]] => isStream := true + iterMs is [['InfiniteTuple,:.]] => isStream := true + iterMs is [['UniversalSegment,:.]] => isStream := true + itr is ['STEP,.,.,.] => isStream := true + isStream + +collectStream(t,op,itrl,body) == + v := CATCH('loopCompiler,collectStream1(t,op,itrl,body)) + v = 'tryInterpOnly => throwKeyedMsg("S2IS0011",NIL) + v + +collectStream1(t,op,itrl,body) == + $indexVars:local := NIL + upStreamIters itrl + if #$indexVars = 1 then mode:=collectOneStream(t,op,itrl,body) + else mode:=collectSeveralStreams(t,op,itrl,body) + putModeSet(op,[mode]) + +upStreamIters itrl == + -- type analyze stream collect loop iterators + for iter in itrl repeat + iter is ['IN,index,s] => + upStreamIterIN(iter,index,s) + iter is ['STEP,index,lower,step,:upperList] => + upStreamIterSTEP(index,lower,step,upperList) + +upStreamIterIN(iter,index,s) == + iterMs := bottomUp s + + -- transform segment variable into STEP + iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => + lower := [mkAtreeNode 'lo, s] + step := [mkAtreeNode 'incr, s] + upperList := + CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] + NIL + upStreamIterSTEP(index,lower,step,upperList) + newIter := ['STEP,index,lower,step,:upperList] + RPLACA(iter,CAR newIter) + RPLACD(iter,CDR newIter) + + (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]]) + and (iterMs isnt [['InfinitTuple, ud]]) => + throwKeyedMsg("S2IS0006",[index]) + put(index,'mode,ud,$env) + mkLocalVar('"the iterator expression",index) + s := + iterMs is [['List,ud],:.] => + form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,s,['Stream,ud]], + ['InfiniteTuple, ud]] + bottomUp form + form + s + $indexVars:= [[index,:s],:$indexVars] + +upStreamIterSTEP(index,lower,step,upperList) == + null isEqualOrSubDomain(ltype := IFCAR bottomUpUseSubdomain(lower), + $Integer) => throwKeyedMsg("S2IS0007",['"lower"]) + null isEqualOrSubDomain(stype := IFCAR bottomUpUseSubdomain(step), + $Integer) => throwKeyedMsg("S2IS0008",NIL) + for upper in upperList repeat + null isEqualOrSubDomain(IFCAR bottomUpUseSubdomain(upper), + $Integer) => throwKeyedMsg("S2IS0007",['"upper"]) + + put(index,'mode,type := resolveTT(ltype,stype),$env) + null type => throwKeyedMsg("S2IS0010", nil) + mkLocalVar('"the iterator expression",index) + + s := + null upperList => + -- create the function that does the appropriate incrementing + genFun := 'generate + form := [mkAtreeNode genFun, + [[mkAtreeNode 'Dollar, ['IncrementingMaps,type], + mkAtreeNode 'incrementBy],step],lower] + bottomUp form + form + form := [mkAtreeNode 'SEGMENT,lower,first upperList] + putTarget(form,['Segment,type]) + form := [mkAtreeNode 'construct,form] + putTarget(form,['List,['Segment,type]]) + form := [mkAtreeNode 'expand,form] + putTarget(form,'(List (Integer))) + form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,form,['Stream,$Integer]], + ['InfiniteTuple, $Integer]] + bottomUp form + form + $indexVars:= [[index,:s],:$indexVars] + +collectOneStream(t,op,itrl,body) == + -- build stream collect for case of iterating over a single stream + -- In this case we don't need to build records + form := mkAndApplyPredicates itrl + bodyVec := mkIterFun(CAR $indexVars,body,$localVars) + form := [mkAtreeNode 'map,bodyVec,form] + bottomUp form + val := getValue form + m := objMode val + m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => + systemError '"Not a Stream" + newVal := objNew(objVal val, ['InfiniteTuple, ud]) + putValue(op,newVal) + objMode newVal + +mkAndApplyPredicates itrl == + -- for one index variable case for now. may generalize later + [indSet] := $indexVars + [.,:s] := indSet + for iter in itrl repeat + iter is ['WHILE,pred] => + fun := 'filterWhile + predVec := mkIterFun(indSet,pred,$localVars) + s := [mkAtreeNode fun,predVec,s] + iter is ['UNTIL,pred] => + fun := 'filterUntil + predVec := mkIterFun(indSet,pred,$localVars) + s := [mkAtreeNode fun,predVec,s] + iter is ['SUCHTHAT,pred] => + fun := 'select + putTarget(pred,$Boolean) + predVec := mkIterFun(indSet,pred,$localVars) + s := [mkAtreeNode fun,predVec,s] + s + +mkIterFun([index,:s],funBody,$localVars) == + -- transform funBody into a lambda with index as the parameter + mode := objMode getValue s + mode isnt ['Stream, indMode] and mode isnt ['InfiniteTuple, indMode] => + keyedSystemError('"S2GE0016", '("mkIterFun" "bad stream index type")) + put(index,'mode,indMode,$env) + mkLocalVar($mapName,index) + [m]:=bottomUpCompile funBody + mapMode := ['Mapping,m,indMode] + $freeVariables := [] + $boundVariables := [index] + -- CCL does not support upwards funargs, so we check for any free variables + -- and pass them into the lambda as part of envArg. + body := checkForFreeVariables(getValue funBody,$localVars) + val:=['function,['LAMBDA,[index,'envArg],objVal body]] + vec := mkAtreeNode GENSYM() + putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) + vec + +checkForFreeVariables(v,locals) == + -- v is the body of a lambda expression. The list $boundVariables is all the + -- bound variables, the parameter locals contains local variables which might + -- be free, or the token ALL, which means that any parameter is a candidate + -- to be free. + NULL v => v + SYMBOLP v => + v="$$$" => v -- Placeholder for mini-vector + MEMQ(v,$boundVariables) => v + p := POSITION(v,$freeVariables) => + ["ELT","envArg",positionInVec(p,#($freeVariables))] + (locals = "ALL") or MEMQ(v,locals) => + $freeVariables := [v,:$freeVariables] + ["ELT","envArg",positionInVec(0,#($freeVariables))] + v + LISTP v => + CDR(LASTTAIL v) => -- Must be a better way to check for a genuine list? + v + [op,:args] := v + LISTP op => + -- Might have a mode at the front of a list, or be calling a function + -- which returns a function. + [checkForFreeVariables(op,locals),:[checkForFreeVariables(a,locals) for a in args]] + op = "LETT" => -- Expands to a SETQ. + ["SETF",:[checkForFreeVariables(a,locals) for a in args]] + op = "COLLECT" => -- Introduces a new bound variable? + first(args) is ["STEP",var,:.] => + $boundVariables := [var,:$boundVariables] + r := ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] + $boundVariables := delete(var,$boundVariables) + r + ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] + op = "REPEAT" => -- Introduces a new bound variable? + first(args) is ["STEP",var,:.] => + $boundVariables := [var,:$boundVariables] + r := ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] + $boundVariables := delete(var,$boundVariables) + r + ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] + op = "LET" => + args is [var,form,name] => + -- This is some bizarre LET, not what one would expect in Common Lisp! + -- Treat var as a free variable, since it may be bound out of scope + -- if we are in a lambda within another lambda. + newvar := + p := POSITION(var,$freeVariables) => + ["ELT","envArg",positionInVec(p,#($freeVariables))] + $freeVariables := [var,:$freeVariables] + ["ELT","envArg",positionInVec(0,#($freeVariables))] + ["SETF",newvar,checkForFreeVariables(form,locals)] + error "Non-simple variable bindings are not currently supported" + op = "PROG" => + error "Non-simple variable bindings are not currently supported" + op = "LAMBDA" => v + op = "QUOTE" => v + op = "getValueFromEnvironment" => v + [op,:[checkForFreeVariables(a,locals) for a in args]] + v + +positionInVec(p,l) == + -- We cons up the free list, but need to keep positions consistent so + -- count from the end of the list. + l-p-1 + +collectSeveralStreams(t,op,itrl,body) == + -- performs collects over several streams in parallel + $index: local := nil + [form,:zipType] := mkZipCode $indexVars + form := mkAndApplyZippedPredicates(form,zipType,itrl) + vec := mkIterZippedFun($indexVars,body,zipType,$localVars) + form := [mkAtreeNode 'map, vec, form] + bottomUp form + val := getValue form + m := objMode val + m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => + systemError '"Not a Stream" + newVal := objNew(objVal val, ['InfiniteTuple, ud]) + putValue(op,newVal) + objMode newVal + +mkZipCode indexList == + -- create interpreter form for turning a list of parallel streams + -- into a stream of nested record types. returns [form,:recordType] + #indexList = 2 => + [[.,:s2],[.,:s1]] := indexList + t1 := CADR objMode getValue s1 + t2 := CADR objMode getValue s2 + zipType := ['Record,['_:,'part1,t1], ['_:,'part2,t2] ] + zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t1, + mkEvalable t2], + mkAtreeNode 'makeRecord] + form := [mkAtreeNode 'map,zipFun,s1,s2] + [form,:zipType] + [form,:zipType] := mkZipCode CDR indexList + [[.,:s],:.] := indexList + t := CADR objMode getValue s + zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t, + mkEvalable zipType], + mkAtreeNode 'makeRecord] + form := [mkAtreeNode 'map,zipFun,s,form] + zipType := ['Record,['_:,'part1,t],['_:,'part2,zipType]] + [form,:zipType] + +mkAndApplyZippedPredicates (s,zipType,itrl) == + -- for one index variable case for now. may generalize later + for iter in itrl repeat + iter is ['WHILE,pred] => + predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) + s := [mkAtreeNode 'swhile,predVec,s] + iter is ['UNTIL,pred] => + predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) + s := [mkAtreeNode 'suntil,predVec,s] + iter is ['SUCHTHAT,pred] => + putTarget(pred,$Boolean) + predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) + s := [mkAtreeNode 'select,predVec,s] + s + +mkIterZippedFun(indexList,funBody,zipType,$localVars) == + -- transform funBody into a lamda with $index as the parameter + numVars:= #indexList + for [var,:.] in indexList repeat + funBody := subVecNodes(mkIterVarSub(var,numVars),var,funBody) + put($index,'mode,zipType,$env) + mkLocalVar($mapName,$index) + [m]:=bottomUpCompile funBody + mapMode := ['Mapping,m,zipType] + $freeVariables := [] + $boundVariables := [$index] + -- CCL does not support upwards funargs, so we check for any free variables + -- and pass them into the lambda as part of envArg. + body := + [checkForFreeVariables(form,$localVars) for form in getValue funBody] + val:=['function,['LAMBDA,[$index,'envArg],objVal body]] + vec := mkAtreeNode GENSYM() + putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) + vec + +subVecNodes(new,old,form) == + ATOM form => + (VECP form) and (form.0 = old) => new + form + [subVecNodes(new,old,CAR form), :subVecNodes(new,old,CDR form)] + +mkIterVarSub(var,numVars) == + n := iterVarPos var + n=2 => + [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part2] + n=1 => + [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part1] + [mkAtreeNode "elt",mkNestedElts(numVars-n),mkAtreeNode 'part1] + +iterVarPos var == + for [index,:.] in reverse $indexVars for i in 1.. repeat + index=var => return(i) + +mkNestedElts n == + n=0 => mkAtreeNode($index or ($index:= GENSYM())) + [mkAtreeNode "elt", mkNestedElts(n-1), mkAtreeNode 'part2] + +--% Handlers for construct + +upconstruct t == + --Computes the common mode set of the construct by resolving across + --the argument list, and evaluating + t isnt [op,:l] => nil + dol := getAtree(op,'dollar) + tar := getTarget(op) or dol + null l => upNullList(op,l,tar) + tar is ['Record,:types] => upRecordConstruct(op,l,tar) + isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) + aggs := '(List) + if tar and PAIRP(tar) and ^isPartialMode(tar) then + CAR(tar) in aggs => + ud := + (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar + CADR tar + for x in l repeat if not getTarget(x) then putTarget(x,ud) + CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => + vec := ['List,underDomainOf tar] + for x in l repeat if not getTarget(x) then putTarget(x,vec) + argModeSetList:= [bottomUp x for x in l] + dol and dol is [topType,:.] and not (topType in aggs) => + (mmS:= selectMms(op,l,tar)) and (mS:= evalForm(op,getUnname op,l,mmS)) => + putModeSet(op,mS) + NIL + (tar and tar is [topType,:.] and not (topType in aggs)) and + (mmS:= modemapsHavingTarget(selectMms(op,l,tar),tar)) and + (mS:= evalForm(op,getUnname op,l,mmS)) => + putModeSet(op,mS) + eltTypes := replaceSymbols([first x for x in argModeSetList],l) + eltTypes is [['Tuple, td]] => + mode := ['List, td] + evalTupleConstruct(op, l, mode, tar) + eltTypes is [['InfiniteTuple, td]] => + mode := ['Stream, td] + evalInfiniteTupleConstruct(op, l, mode, tar) + if not isPartialMode(tar) and tar is ['List,ud] then + mode := ['List, resolveTypeListAny cons(ud,eltTypes)] + else mode := ['List, resolveTypeListAny eltTypes] + if isPartialMode tar then tar:=resolveTM(mode,tar) + evalconstruct(op,l,mode,tar) + +modemapsHavingTarget(mmS,target) == + -- returns those modemaps have the signature result matching the + -- given target + [mm for mm in mmS | ([[.,res,:.],:.] := mm) and res = target] + +evalTupleConstruct(op,l,m,tar) == + ['List, ud] := m + code := ['APPEND, + :([["asTupleAsList", getArgValueOrThrow(x,['Tuple, ud])] for x in l])] + val := + $genValue => objNewWrap(timedEVALFUN code,m) + objNew(code,m) + + (val1 := coerceInteractive(val,tar or m)) => + putValue(op,val1) + putModeSet(op,[tar or m]) + putValue(op,val) + putModeSet(op,[m]) + +evalInfiniteTupleConstruct(op,l,m,tar) == + ['Stream, ud] := m + code := first [(getArgValue(x,['InfiniteTuple, ud]) or + throwKeyedMsg("S2IC0007",[['InifinteTuple, ud]])) for x in l] + val := + $genValue => objNewWrap(timedEVALFUN code,m) + objNew(code,m) + if tar then val1 := coerceInteractive(val,tar) else val1 := val + + val1 => + putValue(op,val1) + putModeSet(op,[tar or m]) + putValue(op,val) + putModeSet(op,[m]) + +evalconstruct(op,l,m,tar) == + [agg,:.,underMode]:= m + code := ['LIST, :(argCode:=[(getArgValue(x,underMode) or + throwKeyedMsg("S2IC0007",[underMode])) for x in l])] + val := + $genValue => objNewWrap(timedEVALFUN code,m) + objNew(code,m) + if tar then val1 := coerceInteractive(val,tar) else val1 := val + + val1 => + putValue(op,val1) + putModeSet(op,[tar or m]) + putValue(op,val) + putModeSet(op,[m]) + +replaceSymbols(modeList,l) == + -- replaces symbol types with their corresponding polynomial types + -- if not all type are symbols + not ($Symbol in modeList) => modeList + modeList is [a,:b] and and/[a=x for x in b] => modeList + [if m=$Symbol then getMinimalVarMode(objValUnwrap(getValue arg), + $declaredMode) else m for m in modeList for arg in l] + +upNullList(op,l,tar) == + -- handler for [] (empty list) + defMode := + tar and tar is [a,b] and (a in '(Stream Vector List)) and + not isPartialMode(b) => ['List,b] + '(List (None)) + val := objNewWrap(NIL,defMode) + tar and not isPartialMode(tar) => + null (val' := coerceInteractive(val,tar)) => + throwKeyedMsg("S2IS0013",[tar]) + putValue(op,val') + putModeSet(op,[tar]) + putValue(op,val) + putModeSet(op,[defMode]) + +upTaggedUnionConstruct(op,l,tar) == + -- special handler for tagged union constructors + tar isnt [.,:types] => nil + #l ^= 1 => throwKeyedMsg("S2IS0051",[#l,tar]) + bottomUp first l + obj := getValue first l + (code := coerceInteractive(getValue first l,tar)) or + throwKeyedMsgCannotCoerceWithValue(objVal obj, objMode obj,tar) + putValue(op,code) + putModeSet(op,[tar]) + +upRecordConstruct(op,l,tar) == + -- special handler for record constructors + tar isnt [.,:types] => nil + argModes := nil + for arg in l repeat bottomUp arg + argCode := + [(getArgValue(arg,type) or throwKeyedMsgCannotCoerceWithValue( + objVal getValue arg,objMode getValue arg,type)) + for arg in l for ['_:,.,type] in types] + len := #l + code := + (len = 1) => ["CONS", :argCode, '()] + (len = 2) => ["CONS",:argCode] + ['VECTOR,:argCode] + if $genValue then code := wrap timedEVALFUN code + putValue(op,objNew(code,tar)) + putModeSet(op,[tar]) + +--% Handlers for declarations + +upDeclare t == + t isnt [op,lhs,rhs] => nil + (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => + keyedMsgCompFailure("S2IS0014",[lhs]) + mode := evaluateType unabbrev rhs + mode = $Void => throwKeyedMsgSP("S2IS0015",NIL,op) + not isLegitimateMode(mode,nil,nil) => throwKeyedMsgSP("S2IE0004",[mode],op) + categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op) + packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op) + junk := + lhs is ["free",['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or + lhs is ["free",:vars] => + for var in vars repeat declare(['free,var],mode) + lhs is ["local",['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or + lhs is ["local",:vars] => + for var in vars repeat declare(["local",var],mode) + lhs is ["Tuple",:vars] or lhs is ["LISTOF",:vars] => + for var in vars repeat declare(var,mode) + declare(lhs,mode) + putValue(op,objNewWrap(voidValue(), $Void)) + putModeSet(op,[$Void]) + +declare(var,mode) == + -- performs declaration. + -- 10/31/89: no longer coerces value to new declared type + if var is ['local,v] then + uplocalWithType(v,mode) + var := v + if var is ['free,v] then + upfreeWithType(v,mode) + var := v + not IDENTP(var) => + throwKeyedMsg("S2IS0016",[STRINGIMAGE var]) + var in '(% %%) => throwKeyedMsg("S2IS0050",[var]) + if get(var,'isInterpreterFunction,$e) then + mode isnt ['Mapping,.,:args] => + throwKeyedMsg("S2IS0017",[var,mode]) + -- validate that the new declaration has the defined # of args + mapval := objVal get(var,'value,$e) + -- mapval looks like '(MAP (args . defn)) + margs := CAADR mapval + -- if one args, margs is not a pair, just #1 or NIL + -- otherwise it looks like (Tuple #1 #2 ...) + nargs := + null margs => 0 + PAIRP margs => -1 + #margs + 1 + nargs ^= #args => throwKeyedMsg("S2IM0008",[var]) + if $compilingMap then mkLocalVar($mapName,var) + else clearDependencies(var,true) + isLocalVar(var) => put(var,'mode,mode,$env) + mode is ['Mapping,:.] => declareMap(var,mode) + v := get(var,'value,$e) => + -- only allow this if either + -- - value already has given type + -- - new mode is same as old declared mode + objMode(v) = mode => putHist(var,'mode,mode,$e) + mode = get(var,'mode,$e) => NIL -- nothing to do + throwKeyedMsg("S2IS0052",[var,mode]) + putHist(var,'mode,mode,$e) + +declareMap(var,mode) == + -- declare a Mapping property + (v:=get(var,'value,$e)) and objVal(v) isnt ['MAP,:.] => + throwKeyedMsg("S2IS0019",[var]) + isPartialMode mode => throwKeyedMsg("S2IM0004",NIL) + putHist(var,'mode,mode,$e) + +getAndEvalConstructorArgument tree == + triple := getValue tree + objMode triple = '(Domain) => triple + isWrapped objVal(triple) => triple + isLocalVar objVal triple => compFailure('" Local variable or parameter used in type") + objNewWrap(timedEVALFUN objVal(triple), objMode(triple)) + +replaceSharps(x,d) == + -- replaces all sharps in x by the arguments of domain d + -- all replaces the triangle variables + SL:= NIL + for e in CDR d for var in $FormalMapVariableList repeat + SL:= CONS(CONS(var,e),SL) + x := subCopy(x,SL) + SL:= NIL + for e in CDR d for var in $TriangleVariableList repeat + SL:= CONS(CONS(var,e),SL) + subCopy(x,SL) + +isDomainValuedVariable form == + -- returns the value of form if form is a variable with a type value + IDENTP form and (val := ( + get(form,'value,$InteractiveFrame) or _ + (PAIRP($env) and get(form,'value,$env)) or _ + (PAIRP($e) and get(form,'value,$e)))) and + objMode(val) in '((Domain) (SubDomain (Domain))) => + objValUnwrap(val) + nil + +evalCategory(d,c) == + -- tests whether domain d has category c + isPartialMode d or ofCategory(d,c) + +isOkInterpMode m == + isPartialMode(m) => isLegitimateMode(m,nil,nil) + isValidType(m) and isLegitimateMode(m,nil,nil) + +isLegitimateRecordOrTaggedUnion u == + and/[x is [":",.,d] and isLegitimateMode(d,nil,nil) for x in u] + +isPolynomialMode m == + -- If m is a polynomial type this function returns a list of its + -- variables, and nil otherwise + m is [op,a,:rargs] => + a := removeQuote a + MEMQ(op,'(Polynomial RationalFunction AlgebraicFunction Expression + ElementaryFunction LiouvillianFunction FunctionalExpression + CombinatorialFunction ))=> 'all + op = 'UnivariatePolynomial => LIST a + op = 'Variable => LIST a + MEMQ(op,'(MultivariatePolynomial DistributedMultivariatePolynomial + HomogeneousDistributedMultivariatePolynomial)) => a + NIL + NIL + +containsPolynomial m == + not PAIRP(m) => NIL + [d,:.] := m + d in $univariateDomains or d in $multivariateDomains or + d in '(Polynomial RationalFunction) => true + (m' := underDomainOf m) and containsPolynomial m' + +containsVariables m == + not PAIRP(m) => NIL + [d,:.] := m + d in $univariateDomains or d in $multivariateDomains => true + (m' := underDomainOf m) and containsVariables m' + +listOfDuplicates l == + l is [x,:l'] => + x in l' => [x,:listOfDuplicates deleteAll(x,l')] + listOfDuplicates l' + +-- The following function removes all occurrences of x from the list l + +deleteAll(x,l) == + null l => nil + x = CAR(l) => deleteAll(x,CDR l) + [first l,:deleteAll(x,rest l)] + diff --git a/src/interp/i-spec1.boot.pamphlet b/src/interp/i-spec1.boot.pamphlet deleted file mode 100644 index 2e178fe0..00000000 --- a/src/interp/i-spec1.boot.pamphlet +++ /dev/null @@ -1,1303 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-spec1.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Handlers for Special Forms (1 of 2) - -This file contains the functions which do type analysis and -evaluation of special functions in the interpreter. -Special functions are ones which are not defined in the algebra -code, such as assignment, construct, COLLECT and declaration. - -Operators which require special handlers all have a LISP "up" -property which is the name of the special handler, which is -always the word "up" followed by the operator name. -If an operator has this "up" property the handler is called -automatically from bottomUp instead of general modemap selection. - -The up handlers are usually split into two pieces, the first is -the up function itself, which performs the type analysis, and an -"eval" function, which generates (and executes, if required) the -code for the function. -The up functions always take a single argument, which is the -entire attributed tree for the operation, and return the modeSet -of the node, which is a singleton list containing the type -computed for the node. -The eval functions can take any arguments deemed necessary. -Actual evaluation is done if $genValue is true, otherwise code is -generated. -(See the function analyzeMap for other things that may affect -what is generated in these functions.) - -These functions are required to do two things: - 1) do a putValue on the operator vector with the computed value - of the node, which is a triple. This is usually done in the - eval functions. - 2) do a putModeSet on the operator vector with a list of the - computed type of the node. This is usually done in the - up functions. - -There are several special modes used in these functions: - 1) Void is the mode that should be used for all statements - that do not otherwise return values, such as declarations, - loops, IF-THEN's without ELSE's, etc.. - 2) $NoValueMode and $ThrowAwayMode used to be used in situations - where Void is now used, and are being phased out completely. -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"i-analy" -)package "BOOT" - - --- Functions which require special handlers (also see end of file) - -$repeatLabel := NIL -$breakCount := 0 -$anonymousMapCounter := 0 - -$specialOps := '( - ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar - equation error free has IF _is _isnt iterate _break LET _local MDEF _or - pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where ) - ---% Void stuff - -voidValue() == '"()" - ---% Handlers for Anonymous Function Definitions - -upADEF t == - t isnt [.,[vars,types,.,body],pred,.] => NIL - -- do some checking on what we got - for var in vars repeat - if not IDENTP(var) then throwKeyedMsg("S2IS0057",[var]) - -- unabbreviate types - types := [(if t then evaluateType unabbrev t else NIL) for t in types] - -- we do not allow partial types - if isPartialMode(m := first types) then throwKeyedMsg("S2IS0058",[m]) - - -- we want everything to be declared or nothing. The exception is that - -- we do not require a target type since we will compute one anyway. - if null(m) and rest types then - m := first rest types - types' := rest rest types - else - types' := rest types - for type in types' repeat - if (type and null m) or (m and null type) then - throwKeyedMsg("S2IS0059",NIL) - if isPartialMode type then throwKeyedMsg("S2IS0058",[type]) - --- $localVars: local := nil --- $freeVars: local := nil --- $env: local := [[NIL]] - $compilingMap : local := true - - -- if there is a predicate, merge it in with the body - if pred ^= true then body := ['IF,pred,body,'noMapVal] - - tar := getTarget t - null m and tar is ['Mapping,.,:argTypes] and (#vars = #argTypes) => - if isPartialMode tar then throwKeyedMsg("S2IS0058",[tar]) - evalTargetedADEF(t,vars,rest tar,body) - null m => evalUntargetedADEF(t,vars,types,body) - evalTargetedADEF(t,vars,types,body) - -evalUntargetedADEF(t,vars,types,body) == - -- recreate a parse form - if vars is [var] - then vars := var - else vars := ['Tuple,:vars] - val := objNewWrap(["+->",vars,body],$AnonymousFunction) - putValue(t,val) - putModeSet(t,[objMode val]) - -evalTargetedADEF(t,vars,types,body) == - $mapName : local := makeInternalMapName('"anonymousFunction", - #vars,$anonymousMapCounter,'"internal") - $anonymousMapCounter := 1 + $anonymousMapCounter - $compilingMap : local := true -- state that we are trying to compile - $mapThrowCount : local := 0 -- number of "return"s encountered - $mapReturnTypes : local := nil -- list of types from returns - $repeatLabel : local := nil -- for loops; see upREPEAT - $breakCount : local := 0 -- breaks from loops; ditto - - -- now substitute formal names for the parm variables - -- this is used in the interpret-code case, but isn't so bad any way - -- since it makes the bodies look more like regular map bodies - - sublist := [[var,:GENSYM()] for var in vars] - body := sublisNQ(sublist,body) - vars := [CDR v for v in sublist] - - for m in CDR types for var in vars repeat - $env:= put(var,'mode,m,$env) - mkLocalVar($mapName,var) - for lvar in getLocalVars($mapName,body) repeat - mkLocalVar($mapName,lvar) - -- set up catch point for interpret-code mode - x := CATCH('mapCompiler,compileTargetedADEF(t,vars,types,body)) - x = 'tryInterpOnly => mkInterpTargetedADEF(t,vars,types,body) - x - -mkInterpTargetedADEF(t,vars,types,oldBody) == - null first types => - throwKeyedMsg("S2IS0056",NIL) - throwMessage '" map result type needed but not present." - arglCode := ["LIST",:[argCode for type in rest types for var in vars]] - where argCode() == ['putValueValue,['mkAtreeNode,MKQ var], - objNewCode(["wrap",var],type)] - put($mapName,'mapBody,oldBody,$e) - body := ['rewriteMap1,MKQ $mapName,arglCode,MKQ types] - compileADEFBody(t,vars,types,body,first types) - -compileTargetedADEF(t,vars,types,body) == - val := compileBody(body,CAR types) - computedResultType := objMode val - body := wrapMapBodyWithCatch flattenCOND objVal val - compileADEFBody(t,vars,types,body,computedResultType) - -compileADEFBody(t,vars,types,body,computedResultType) == ---+ - $compiledOpNameList := [$mapName] - minivectorName := makeInternalMapMinivectorName(PNAME $mapName) - $minivectorNames := [[$mapName,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - - -- The use of the three variables $definingMap, $genValue and $compilingMap - -- is to cover the following cases: - -- - -- $definingMap: This is set in analyzeMap and covers examples like: - -- addx x == ((y: Integer): Integer +-> x + y) - -- g := addx 10 - -- g 3 - -- i.e. we are storing the mapping as an object. - -- - -- $compilingMap: This covers mappings which are created and applied "on the - -- "fly", for example: - -- [map(h +-> D(h, t), v) for v in [t]] - -- - -- $genValue: This seems to be needed when we create a map as an argument - -- for a constructor, e.g.: - -- Dx: LODO(EXPR INT, f +-> D(f, x)) := D() - -- - -- MCD 13/3/96 - if not $definingMap and ($genValue or $compilingMap) then - fun := ["function",["LAMBDA",[:vars,'envArg],body]] - code := wrap timedEVALFUN ['LIST,fun] - else - $freeVariables := [] - $boundVariables := [minivectorName,:vars] - -- CCL does not support upwards funargs, so we check for any free variables - -- and pass them into the lambda as part of envArg. - body := checkForFreeVariables(body,"ALL") - fun := ["function",["LAMBDA",[:vars,'envArg],body]] - code := ["CONS", fun, ["VECTOR", :reverse $freeVariables]] - - val := objNew(code,rt := ['Mapping,computedResultType,:rest types]) - putValue(t,val) - putModeSet(t,[rt]) - ---% Handler for Algebraic Extensions - -upAlgExtension t == - -- handler for algebraic extension declaration. These are of - -- the form "a | a**2+1", and have the effect that "a" is declared - -- to be a simple algebraic extension, with respect to the given - -- polynomial, and given the value "a" in this type. - t isnt [op,var,eq] => nil - null $genValue => throwKeyedMsg("S2IS0001",NIL) - a := getUnname var - clearCmdParts ['propert,a] --clear properties of a - algExtension:= eq2AlgExtension eq - upmode := ['UnivariatePolynomial,a,$EmptyMode] - $declaredMode : local := upmode - putTarget(algExtension,upmode) - ms:= bottomUp algExtension - triple:= getValue algExtension - upmode:= resolveTMOrCroak(objMode(triple),upmode) - null (T:= coerceInteractive(triple,upmode)) => - throwKeyedMsgCannotCoerceWithValue(objVal(triple), - objMode(triple),upmode) - newmode := objMode T - (field := resolveTCat(CADDR newmode,'(Field))) or - throwKeyedMsg("S2IS0002",[eq]) - pd:= ['UnivariatePolynomial,a,field] - null (canonicalAE:= coerceInteractive(T,pd)) => - throwKeyedMsgCannotCoerceWithValue(objVal T,objMode T,pd) - sae:= ['SimpleAlgebraicExtension,field,pd,objValUnwrap canonicalAE] - saeTypeSynonym := INTERN STRCONC('"SAE",STRINGIMAGE a) - saeTypeSynonymValue := objNew(sae,'(Domain)) - fun := getFunctionFromDomain('generator,sae,NIL) - expr:= wrap SPADCALL(fun) - putHist(saeTypeSynonym,'value,saeTypeSynonymValue,$e) - putHist(a,'mode,sae,$e) - putHist(a,'value,T2:= objNew(expr,sae),$e) - clearDependencies(a,true) - if $printTypeIfTrue then - sayKeyedMsg("S2IS0003",NIL) - sayMSG concat ['%l,'" ",saeTypeSynonym,'" := ", - :prefix2String objVal saeTypeSynonymValue] - sayMSG concat ['" ",a,'" : ",saeTypeSynonym,'" := ",a] - putValue(op,T2) - putModeSet(op,[sae]) - -eq2AlgExtension eq == - -- transforms "a=b" to a-b for processing - eq is [op,:l] and VECP op and (getUnname op='equation) => - [mkAtreeNode "-",:l] - eq - ---% Handlers for booleans - -upand x == - -- generates code for and forms. The second argument is only - -- evaluated if the first argument is true. - x isnt [op,term1,term2] => NIL - putTarget(term1,$Boolean) - putTarget(term2,$Boolean) - ms := bottomUp term1 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"and_""],term1) - $genValue => - BooleanEquality(objValUnwrap(getValue term1), - getConstantFromDomain('(false),$Boolean)) => - putValue(x,getValue term1) - putModeSet(x,ms) - -- first term is true, so look at the second one - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) - putValue(x,getValue term2) - putModeSet(x,ms) - - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"and_""],term2) - -- generate an IF expression and let the rest of the code handle it - cond := [mkAtreeNode "=",mkAtree "false",term1] - putTarget(cond,$Boolean) - code := [mkAtreeNode "IF",cond,mkAtree "false",term2] - putTarget(code,$Boolean) - bottomUp code - putValue(x,getValue code) - putModeSet(x,ms) - -upor x == - -- generates code for or forms. The second argument is only - -- evaluated if the first argument is false. - x isnt [op,term1,term2] => NIL - putTarget(term1,$Boolean) - putTarget(term2,$Boolean) - ms := bottomUp term1 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[1,'"_"or_""],term1) - $genValue => - BooleanEquality(objValUnwrap(getValue term1), - getConstantFromDomain('(true),$Boolean)) => - putValue(x,getValue term1) - putModeSet(x,ms) - -- first term is false, so look at the second one - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) - putValue(x,getValue term2) - putModeSet(x,ms) - - ms := bottomUp term2 - ms isnt [=$Boolean] => throwKeyedMsgSP("S2IS0054",[2,'"_"or_""],term2) - -- generate an IF expression and let the rest of the code handle it - cond := [mkAtreeNode "=",mkAtree "true",term1] - putTarget(cond,$Boolean) - code := [mkAtreeNode "IF",cond,mkAtree "true",term2] - putTarget(code,$Boolean) - bottomUp code - putValue(x,getValue code) - putModeSet(x,ms) - ---% Handlers for case - -upcase t == - t isnt [op,lhs,rhs] => nil - bottomUp lhs - triple := getValue lhs - objMode(triple) isnt ['Union,:unionDoms] => - throwKeyedMsg("S2IS0004",NIL) - if (rhs' := isDomainValuedVariable(rhs)) then rhs := rhs' - if first unionDoms is [":",.,.] then - for i in 0.. for d in unionDoms repeat - if d is [":",=rhs,.] then rhstag := i - if NULL rhstag then error '"upcase: bad Union form" - $genValue => - rhstag = first unwrap objVal triple => code := wrap 'TRUE - code := wrap NIL - code := - ["COND", - [["EQL",rhstag,["CAR",["unwrap",objVal triple]]], - ''TRUE], - [''T,NIL]] - else - $genValue => - t' := coerceUnion2Branch triple - rhs = objMode t' => code := wrap 'TRUE - code := wrap NIL - triple' := objNewCode(["wrap",objVal triple],objMode triple) - code := - ["COND", - [["EQUAL",MKQ rhs,["objMode",['coerceUnion2Branch,triple']]], - ''TRUE], - [''T,NIL]] - putValue(op,objNew(code,$Boolean)) - putModeSet(op,[$Boolean]) - ---% Handlers for TARGET - -upTARGET t == - -- Evaluates the rhs to a mode,which is used as the target type for - -- the lhs. - t isnt [op,lhs,rhs] => nil - -- do not (yet) support local variables on the rhs - (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => - keyedMsgCompFailure("S2IC0010",[rhs]) - $declaredMode: local := NIL - m:= evaluateType unabbrev rhs - not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) - categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) - $declaredMode:= m - not atom(lhs) and putTarget(lhs,m) - ms := bottomUp lhs - first ms ^= m => - throwKeyedMsg("S2IC0011",[first ms,m]) - putValue(op,getValue lhs) - putModeSet(op,ms) - ---% Handlers for COERCE - -upCOERCE t == - -- evaluate the lhs and then tries to coerce the result to the - -- mode which is the rhs. - -- previous to 5/16/89, this had the same semantics as - -- (lhs@rhs) :: rhs - -- this must be made explicit now. - t isnt [op,lhs,rhs] => nil - $useConvertForCoercions : local := true - -- do not (yet) support local variables on the rhs - (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => - keyedMsgCompFailure("S2IC0006",[rhs]) - $declaredMode: local := NIL - m := evaluateType unabbrev rhs - not isLegitimateMode(m,NIL,NIL) => throwKeyedMsg("S2IE0004",[m]) - categoryForm?(m) => throwKeyedMsg("S2IE0014",[m]) - $declaredMode:= m - -- 05/16/89 (RSS) following line commented out to give correct - -- semantic difference between :: and @ - bottomUp lhs - type:=evalCOERCE(op,lhs,m) - putModeSet(op,[type]) - -evalCOERCE(op,tree,m) == - -- the value of tree is coerced to mode m - -- this is not necessary, if the target property of tree was used - v := getValue tree - t1 := objMode(v) - if $genValue and t1 is ['Union,:.] then - v := coerceUnion2Branch v - t1 := objMode(v) - e := objVal(v) - value:= - t1=m => v - t2 := - if isPartialMode m - then - $genValue and (t1 = '(Symbol)) and containsPolynomial m => - resolveTM(['UnivariatePolynomial,objValUnwrap(v),'(Integer)],m) - resolveTM(t1,m) - else m - null t2 => throwKeyedMsgCannotCoerceWithValue(e,t1,m) - $genValue => coerceOrRetract(v,t2) - objNew(getArgValue(tree,t2),t2) - val:= value or throwKeyedMsgCannotCoerceWithValue(e,t1,m) - putValue(op,val) - objMode(val) - ---% Handlers for COLLECT - -transformCollect [:itrl,body] == - -- syntactic transformation for COLLECT form, called from mkAtree1 - iterList:=[:iterTran1 for it in itrl] where iterTran1() == - it is ["STEP",index,lower,step,:upperList] => - [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper - for upper in upperList]]] - it is ["IN",index,s] => - [["IN",index,mkAtree1 s]] - it is ["ON",index,s] => - [['IN,index,mkAtree1 ['tails,s]]] - it is ["WHILE",b] => - [["WHILE",mkAtree1 b]] - it is ["|",pred] => - [["SUCHTHAT",mkAtree1 pred]] - it is [op,:.] and (op in '(VALUE UNTIL)) => nil - bodyTree:=mkAtree1 body - iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where - iterTran2() == - it is ["STEP",:.] => nil - it is ["IN",:.] => nil - it is ["ON",:.] => nil - it is ["WHILE",:.] => nil - it is [op,b] and (op in '(UNTIL)) => - [[op,mkAtree1 b]] - it is ["|",pred] => nil - keyedSystemError("S2GE0016", - ['"transformCollect",'"Unknown type of iterator"]) - [:iterList,bodyTree] - -upCOLLECT t == - -- $compilingLoop variable insures that throw to interp-only mode - -- goes to the outermost loop. - $compilingLoop => upCOLLECT1 t - upCOLLECT0 t - -upCOLLECT0 t == - -- sets up catch point for interpret-code mode - $compilingLoop: local := true - ms:=CATCH('loopCompiler,upCOLLECT1 t) - ms = 'tryInterpOnly => interpOnlyCOLLECT t - ms - -upCOLLECT1 t == - t isnt [op,:itrl,body] => nil - -- upCOLLECT with compiled body - if (target := getTarget t) and not getTarget(body) then - if target is [agg,S] and agg in '(List Vector Stream InfiniteTuple) then - putTarget(body,S) - $interpOnly => interpCOLLECT(op,itrl,body) - isStreamCollect itrl => collectStream(t,op,itrl,body) - upLoopIters itrl - ms:= bottomUpCompile body - [m]:= ms - for itr in itrl repeat - itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") - mode:= ['Tuple,m] - evalCOLLECT(op,rest t,mode) - putModeSet(op,[mode]) - -upLoopIters itrl == - -- type analyze iterator loop iterators - for iter in itrl repeat - iter is ["WHILE",pred] => - bottomUpCompilePredicate(pred,'"while") - iter is ["SUCHTHAT",pred] => - bottomUpCompilePredicate(pred,'"|") - iter is ["UNTIL",:.] => - NIL -- handle after body is analyzed - iter is ["IN",index,s] => - upLoopIterIN(iter,index,s) - iter is ["STEP",index,lower,step,:upperList] => - upLoopIterSTEP(index,lower,step,upperList) - -- following is an optimization - typeIsASmallInteger(get(index,'mode,$env)) => - RPLACA(iter,'ISTEP) - NIL -- should have error msg here? - -upLoopIterIN(iter,index,s) == - iterMs := bottomUp s - - null IDENTP index => throwKeyedMsg("S2IS0005",[index]) - - if $genValue and first iterMs is ['Union,:.] then - v := coerceUnion2Branch getValue s - m := objMode v - putValue(s,v) - putMode(s,m) - iterMs := [m] - putModeSet(s,iterMs) - - -- transform segment variable into STEP - iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => - lower := [mkAtreeNode 'lo,s] - step := [mkAtreeNode 'incr, s] - upperList := - CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] - NIL - upLoopIterSTEP(index,lower,step,upperList) - newIter := ['STEP,index,lower,step,:upperList] - RPLACA(iter,CAR newIter) - RPLACD(iter,CDR newIter) - - iterMs isnt [['List,ud]] => throwKeyedMsg("S2IS0006",[index]) - put(index,'mode,ud,$env) - mkLocalVar('"the iterator expression",index) - -upLoopIterSTEP(index,lower,step,upperList) == - null IDENTP index => throwKeyedMsg("S2IS0005",[index]) - ltype := IFCAR bottomUpUseSubdomain(lower) - not (typeIsASmallInteger(ltype) or isEqualOrSubDomain(ltype,$Integer))=> - throwKeyedMsg("S2IS0007",['"lower"]) - stype := IFCAR bottomUpUseSubdomain(step) - not (typeIsASmallInteger(stype) or isEqualOrSubDomain(stype,$Integer))=> - throwKeyedMsg("S2IS0008",NIL) - types := [ltype] - utype := nil - for upper in upperList repeat - utype := IFCAR bottomUpUseSubdomain(upper) - not (typeIsASmallInteger(utype) or isEqualOrSubDomain(utype,$Integer))=> - throwKeyedMsg("S2IS0007",['"upper"]) - if utype then types := [utype, :types] - else types := [stype, :types] - type := resolveTypeListAny REMDUP types - put(index,'mode,type,$env) - mkLocalVar('"the iterator expression",index) - -evalCOLLECT(op,[:itrl,body],m) == - iters := [evalLoopIter itr for itr in itrl] - bod := getArgValue(body,computedMode body) - if bod isnt ['SPADCALL,:.] then bode := ['unwrap,bod] - code := timedOptimization asTupleNewCode0 ['COLLECT,:iters,bod] - if $genValue then code := wrap timedEVALFUN code - putValue(op,objNew(code,m)) - -falseFun(x) == nil - -evalLoopIter itr == - -- generate code for loop iterator - itr is ['STEP,index,lower,step,:upperList] => - ['STEP,getUnname index,getArgValue(lower,$Integer), - getArgValue(step,$Integer), - :[getArgValue(upper,$Integer) for upper in upperList]] - itr is ['ISTEP,index,lower,step,:upperList] => - ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), - getArgValue(step,$SmallInteger), - :[getArgValue(upper,$SmallInteger) for upper in upperList]] - itr is ['IN,index,s] => - ['IN,getUnname index,getArgValue(s,['List,get(index,'mode,$env)])] - (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => - [x,getArgValue(pred,$Boolean)] - -interpCOLLECT(op,itrl,body) == - -- interpret-code mode COLLECT handler - $collectTypeList: local := NIL - $indexVars: local := NIL - $indexTypes: local := NIL - emptyAtree op - emptyAtree itrl - emptyAtree body - code := ['COLLECT,:[interpIter itr for itr in itrl], - interpCOLLECTbody(body,$indexVars,$indexTypes)] - value := timedEVALFUN code - t := - null value => '(None) - last $collectTypeList - rm := ['Tuple,t] - value := [objValUnwrap coerceInteractive(objNewWrap(v,m),t) - for v in value for m in $collectTypeList] - putValue(op,objNewWrap(asTupleNew(#value, value),rm)) - putModeSet(op,[rm]) - -interpIter itr == - -- interpret loop iterator - itr is ['STEP,index,lower,step,:upperList] => - $indexVars:= [getUnname index,:$indexVars] - [m]:= bottomUp lower - $indexTypes:= [m,:$indexTypes] - for up in upperList repeat bottomUp up - ['STEP,getUnname index,getArgValue(lower,$Integer), - getArgValue(step,$Integer), - :[getArgValue(upper,$Integer) for upper in upperList]] - itr is ['ISTEP,index,lower,step,:upperList] => - $indexVars:= [getUnname index,:$indexVars] - [m]:= bottomUp lower - $indexTypes:= [m,:$indexTypes] - for up in upperList repeat bottomUp up - ['ISTEP,getUnname index,getArgValue(lower,$SmallInteger), - getArgValue(step,$SmallInteger), - :[getArgValue(upper,$SmallInteger) for upper in upperList]] - itr is ['IN,index,s] => - $indexVars:=[getUnname index,:$indexVars] - [m]:= bottomUp s - m isnt ['List,um] => throwKeyedMsg("S2IS0009",[m]) - $indexTypes:=[um,:$indexTypes] - ['IN,getUnname index,getArgValue(s,m)] - (itr is [x,pred]) and (x in '(WHILE UNTIL SUCHTHAT)) => - [x,interpLoop(pred,$indexVars,$indexTypes,$Boolean)] - -interpOnlyCOLLECT t == - -- called when compilation failed in COLLECT body, not in compiling map - $genValue: local := true - $interpOnly: local := true - upCOLLECT t - -interpCOLLECTbody(expr,indexList,indexTypes) == - -- generate code for interpret-code collect - ['interpCOLLECTbodyIter,MKQ expr,MKQ indexList,['LIST,:indexList], - MKQ indexTypes] - -interpCOLLECTbodyIter(exp,indexList,indexVals,indexTypes) == - -- execute interpret-code collect body. keeps list of type of - -- elements in list in $collectTypeList. - emptyAtree exp - for i in indexList for val in indexVals for type in indexTypes repeat - put(i,'value,objNewWrap(val,type),$env) - [m]:=bottomUp exp - $collectTypeList:= - null $collectTypeList => [rm:=m] - [:$collectTypeList,rm:=resolveTT(m,last $collectTypeList)] - null rm => throwKeyedMsg("S2IS0010",NIL) - value:= - rm ^= m => coerceInteractive(getValue exp,rm) - getValue exp - objValUnwrap(value) - ---% Stream Collect functions - -isStreamCollect itrl == - -- calls bottomUp on iterators and if any of them are streams - -- then whole shebang is a stream - isStream := false - for itr in itrl until isStream repeat - itr is ['IN,.,s] => - iterMs := bottomUp s - iterMs is [['Stream,:.]] => isStream := true - iterMs is [['InfiniteTuple,:.]] => isStream := true - iterMs is [['UniversalSegment,:.]] => isStream := true - itr is ['STEP,.,.,.] => isStream := true - isStream - -collectStream(t,op,itrl,body) == - v := CATCH('loopCompiler,collectStream1(t,op,itrl,body)) - v = 'tryInterpOnly => throwKeyedMsg("S2IS0011",NIL) - v - -collectStream1(t,op,itrl,body) == - $indexVars:local := NIL - upStreamIters itrl - if #$indexVars = 1 then mode:=collectOneStream(t,op,itrl,body) - else mode:=collectSeveralStreams(t,op,itrl,body) - putModeSet(op,[mode]) - -upStreamIters itrl == - -- type analyze stream collect loop iterators - for iter in itrl repeat - iter is ['IN,index,s] => - upStreamIterIN(iter,index,s) - iter is ['STEP,index,lower,step,:upperList] => - upStreamIterSTEP(index,lower,step,upperList) - -upStreamIterIN(iter,index,s) == - iterMs := bottomUp s - - -- transform segment variable into STEP - iterMs is [['Segment,.]] or iterMs is [['UniversalSegment,.]] => - lower := [mkAtreeNode 'lo, s] - step := [mkAtreeNode 'incr, s] - upperList := - CAAR(iterMs) = 'Segment => [[mkAtreeNode 'hi,s]] - NIL - upStreamIterSTEP(index,lower,step,upperList) - newIter := ['STEP,index,lower,step,:upperList] - RPLACA(iter,CAR newIter) - RPLACD(iter,CDR newIter) - - (iterMs isnt [['List,ud]]) and (iterMs isnt [['Stream,ud]]) - and (iterMs isnt [['InfinitTuple, ud]]) => - throwKeyedMsg("S2IS0006",[index]) - put(index,'mode,ud,$env) - mkLocalVar('"the iterator expression",index) - s := - iterMs is [['List,ud],:.] => - form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,s,['Stream,ud]], - ['InfiniteTuple, ud]] - bottomUp form - form - s - $indexVars:= [[index,:s],:$indexVars] - -upStreamIterSTEP(index,lower,step,upperList) == - null isEqualOrSubDomain(ltype := IFCAR bottomUpUseSubdomain(lower), - $Integer) => throwKeyedMsg("S2IS0007",['"lower"]) - null isEqualOrSubDomain(stype := IFCAR bottomUpUseSubdomain(step), - $Integer) => throwKeyedMsg("S2IS0008",NIL) - for upper in upperList repeat - null isEqualOrSubDomain(IFCAR bottomUpUseSubdomain(upper), - $Integer) => throwKeyedMsg("S2IS0007",['"upper"]) - - put(index,'mode,type := resolveTT(ltype,stype),$env) - null type => throwKeyedMsg("S2IS0010", nil) - mkLocalVar('"the iterator expression",index) - - s := - null upperList => - -- create the function that does the appropriate incrementing - genFun := 'generate - form := [mkAtreeNode genFun, - [[mkAtreeNode 'Dollar, ['IncrementingMaps,type], - mkAtreeNode 'incrementBy],step],lower] - bottomUp form - form - form := [mkAtreeNode 'SEGMENT,lower,first upperList] - putTarget(form,['Segment,type]) - form := [mkAtreeNode 'construct,form] - putTarget(form,['List,['Segment,type]]) - form := [mkAtreeNode 'expand,form] - putTarget(form,'(List (Integer))) - form:=[mkAtreeNode 'pretend, [mkAtreeNode 'COERCE,form,['Stream,$Integer]], - ['InfiniteTuple, $Integer]] - bottomUp form - form - $indexVars:= [[index,:s],:$indexVars] - -collectOneStream(t,op,itrl,body) == - -- build stream collect for case of iterating over a single stream - -- In this case we don't need to build records - form := mkAndApplyPredicates itrl - bodyVec := mkIterFun(CAR $indexVars,body,$localVars) - form := [mkAtreeNode 'map,bodyVec,form] - bottomUp form - val := getValue form - m := objMode val - m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => - systemError '"Not a Stream" - newVal := objNew(objVal val, ['InfiniteTuple, ud]) - putValue(op,newVal) - objMode newVal - -mkAndApplyPredicates itrl == - -- for one index variable case for now. may generalize later - [indSet] := $indexVars - [.,:s] := indSet - for iter in itrl repeat - iter is ['WHILE,pred] => - fun := 'filterWhile - predVec := mkIterFun(indSet,pred,$localVars) - s := [mkAtreeNode fun,predVec,s] - iter is ['UNTIL,pred] => - fun := 'filterUntil - predVec := mkIterFun(indSet,pred,$localVars) - s := [mkAtreeNode fun,predVec,s] - iter is ['SUCHTHAT,pred] => - fun := 'select - putTarget(pred,$Boolean) - predVec := mkIterFun(indSet,pred,$localVars) - s := [mkAtreeNode fun,predVec,s] - s - -mkIterFun([index,:s],funBody,$localVars) == - -- transform funBody into a lambda with index as the parameter - mode := objMode getValue s - mode isnt ['Stream, indMode] and mode isnt ['InfiniteTuple, indMode] => - keyedSystemError('"S2GE0016", '("mkIterFun" "bad stream index type")) - put(index,'mode,indMode,$env) - mkLocalVar($mapName,index) - [m]:=bottomUpCompile funBody - mapMode := ['Mapping,m,indMode] - $freeVariables := [] - $boundVariables := [index] - -- CCL does not support upwards funargs, so we check for any free variables - -- and pass them into the lambda as part of envArg. - body := checkForFreeVariables(getValue funBody,$localVars) - val:=['function,['LAMBDA,[index,'envArg],objVal body]] - vec := mkAtreeNode GENSYM() - putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) - vec - -checkForFreeVariables(v,locals) == - -- v is the body of a lambda expression. The list $boundVariables is all the - -- bound variables, the parameter locals contains local variables which might - -- be free, or the token ALL, which means that any parameter is a candidate - -- to be free. - NULL v => v - SYMBOLP v => - v="$$$" => v -- Placeholder for mini-vector - MEMQ(v,$boundVariables) => v - p := POSITION(v,$freeVariables) => - ["ELT","envArg",positionInVec(p,#($freeVariables))] - (locals = "ALL") or MEMQ(v,locals) => - $freeVariables := [v,:$freeVariables] - ["ELT","envArg",positionInVec(0,#($freeVariables))] - v - LISTP v => - CDR(LASTTAIL v) => -- Must be a better way to check for a genuine list? - v - [op,:args] := v - LISTP op => - -- Might have a mode at the front of a list, or be calling a function - -- which returns a function. - [checkForFreeVariables(op,locals),:[checkForFreeVariables(a,locals) for a in args]] - op = "LETT" => -- Expands to a SETQ. - ["SETF",:[checkForFreeVariables(a,locals) for a in args]] - op = "COLLECT" => -- Introduces a new bound variable? - first(args) is ["STEP",var,:.] => - $boundVariables := [var,:$boundVariables] - r := ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] - $boundVariables := delete(var,$boundVariables) - r - ["COLLECT",:[checkForFreeVariables(a,locals) for a in args]] - op = "REPEAT" => -- Introduces a new bound variable? - first(args) is ["STEP",var,:.] => - $boundVariables := [var,:$boundVariables] - r := ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] - $boundVariables := delete(var,$boundVariables) - r - ["REPEAT",:[checkForFreeVariables(a,locals) for a in args]] - op = "LET" => - args is [var,form,name] => - -- This is some bizarre LET, not what one would expect in Common Lisp! - -- Treat var as a free variable, since it may be bound out of scope - -- if we are in a lambda within another lambda. - newvar := - p := POSITION(var,$freeVariables) => - ["ELT","envArg",positionInVec(p,#($freeVariables))] - $freeVariables := [var,:$freeVariables] - ["ELT","envArg",positionInVec(0,#($freeVariables))] - ["SETF",newvar,checkForFreeVariables(form,locals)] - error "Non-simple variable bindings are not currently supported" - op = "PROG" => - error "Non-simple variable bindings are not currently supported" - op = "LAMBDA" => v - op = "QUOTE" => v - op = "getValueFromEnvironment" => v - [op,:[checkForFreeVariables(a,locals) for a in args]] - v - -positionInVec(p,l) == - -- We cons up the free list, but need to keep positions consistent so - -- count from the end of the list. - l-p-1 - -collectSeveralStreams(t,op,itrl,body) == - -- performs collects over several streams in parallel - $index: local := nil - [form,:zipType] := mkZipCode $indexVars - form := mkAndApplyZippedPredicates(form,zipType,itrl) - vec := mkIterZippedFun($indexVars,body,zipType,$localVars) - form := [mkAtreeNode 'map, vec, form] - bottomUp form - val := getValue form - m := objMode val - m isnt ['Stream, ud] and m isnt ['InfiniteTuple, ud] => - systemError '"Not a Stream" - newVal := objNew(objVal val, ['InfiniteTuple, ud]) - putValue(op,newVal) - objMode newVal - -mkZipCode indexList == - -- create interpreter form for turning a list of parallel streams - -- into a stream of nested record types. returns [form,:recordType] - #indexList = 2 => - [[.,:s2],[.,:s1]] := indexList - t1 := CADR objMode getValue s1 - t2 := CADR objMode getValue s2 - zipType := ['Record,['_:,'part1,t1], ['_:,'part2,t2] ] - zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t1, - mkEvalable t2], - mkAtreeNode 'makeRecord] - form := [mkAtreeNode 'map,zipFun,s1,s2] - [form,:zipType] - [form,:zipType] := mkZipCode CDR indexList - [[.,:s],:.] := indexList - t := CADR objMode getValue s - zipFun := [mkAtreeNode 'Dollar, ['MakeRecord,mkEvalable t, - mkEvalable zipType], - mkAtreeNode 'makeRecord] - form := [mkAtreeNode 'map,zipFun,s,form] - zipType := ['Record,['_:,'part1,t],['_:,'part2,zipType]] - [form,:zipType] - -mkAndApplyZippedPredicates (s,zipType,itrl) == - -- for one index variable case for now. may generalize later - for iter in itrl repeat - iter is ['WHILE,pred] => - predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) - s := [mkAtreeNode 'swhile,predVec,s] - iter is ['UNTIL,pred] => - predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) - s := [mkAtreeNode 'suntil,predVec,s] - iter is ['SUCHTHAT,pred] => - putTarget(pred,$Boolean) - predVec := mkIterZippedFun($indexVars,pred,zipType,$localVars) - s := [mkAtreeNode 'select,predVec,s] - s - -mkIterZippedFun(indexList,funBody,zipType,$localVars) == - -- transform funBody into a lamda with $index as the parameter - numVars:= #indexList - for [var,:.] in indexList repeat - funBody := subVecNodes(mkIterVarSub(var,numVars),var,funBody) - put($index,'mode,zipType,$env) - mkLocalVar($mapName,$index) - [m]:=bottomUpCompile funBody - mapMode := ['Mapping,m,zipType] - $freeVariables := [] - $boundVariables := [$index] - -- CCL does not support upwards funargs, so we check for any free variables - -- and pass them into the lambda as part of envArg. - body := - [checkForFreeVariables(form,$localVars) for form in getValue funBody] - val:=['function,['LAMBDA,[$index,'envArg],objVal body]] - vec := mkAtreeNode GENSYM() - putValue(vec,objNew(['CONS,val,["VECTOR",:reverse $freeVariables]],mapMode)) - vec - -subVecNodes(new,old,form) == - ATOM form => - (VECP form) and (form.0 = old) => new - form - [subVecNodes(new,old,CAR form), :subVecNodes(new,old,CDR form)] - -mkIterVarSub(var,numVars) == - n := iterVarPos var - n=2 => - [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part2] - n=1 => - [mkAtreeNode "elt",mkNestedElts(numVars-2),mkAtreeNode 'part1] - [mkAtreeNode "elt",mkNestedElts(numVars-n),mkAtreeNode 'part1] - -iterVarPos var == - for [index,:.] in reverse $indexVars for i in 1.. repeat - index=var => return(i) - -mkNestedElts n == - n=0 => mkAtreeNode($index or ($index:= GENSYM())) - [mkAtreeNode "elt", mkNestedElts(n-1), mkAtreeNode 'part2] - ---% Handlers for construct - -upconstruct t == - --Computes the common mode set of the construct by resolving across - --the argument list, and evaluating - t isnt [op,:l] => nil - dol := getAtree(op,'dollar) - tar := getTarget(op) or dol - null l => upNullList(op,l,tar) - tar is ['Record,:types] => upRecordConstruct(op,l,tar) - isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) - aggs := '(List) - if tar and PAIRP(tar) and ^isPartialMode(tar) then - CAR(tar) in aggs => - ud := - (l is [[realOp, :.]]) and (getUnname(realOp) = 'COLLECT) => tar - CADR tar - for x in l repeat if not getTarget(x) then putTarget(x,ud) - CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => - vec := ['List,underDomainOf tar] - for x in l repeat if not getTarget(x) then putTarget(x,vec) - argModeSetList:= [bottomUp x for x in l] - dol and dol is [topType,:.] and not (topType in aggs) => - (mmS:= selectMms(op,l,tar)) and (mS:= evalForm(op,getUnname op,l,mmS)) => - putModeSet(op,mS) - NIL - (tar and tar is [topType,:.] and not (topType in aggs)) and - (mmS:= modemapsHavingTarget(selectMms(op,l,tar),tar)) and - (mS:= evalForm(op,getUnname op,l,mmS)) => - putModeSet(op,mS) - eltTypes := replaceSymbols([first x for x in argModeSetList],l) - eltTypes is [['Tuple, td]] => - mode := ['List, td] - evalTupleConstruct(op, l, mode, tar) - eltTypes is [['InfiniteTuple, td]] => - mode := ['Stream, td] - evalInfiniteTupleConstruct(op, l, mode, tar) - if not isPartialMode(tar) and tar is ['List,ud] then - mode := ['List, resolveTypeListAny cons(ud,eltTypes)] - else mode := ['List, resolveTypeListAny eltTypes] - if isPartialMode tar then tar:=resolveTM(mode,tar) - evalconstruct(op,l,mode,tar) - -modemapsHavingTarget(mmS,target) == - -- returns those modemaps have the signature result matching the - -- given target - [mm for mm in mmS | ([[.,res,:.],:.] := mm) and res = target] - -evalTupleConstruct(op,l,m,tar) == - ['List, ud] := m - code := ['APPEND, - :([["asTupleAsList", getArgValueOrThrow(x,['Tuple, ud])] for x in l])] - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - - (val1 := coerceInteractive(val,tar or m)) => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -evalInfiniteTupleConstruct(op,l,m,tar) == - ['Stream, ud] := m - code := first [(getArgValue(x,['InfiniteTuple, ud]) or - throwKeyedMsg("S2IC0007",[['InifinteTuple, ud]])) for x in l] - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - if tar then val1 := coerceInteractive(val,tar) else val1 := val - - val1 => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -evalconstruct(op,l,m,tar) == - [agg,:.,underMode]:= m - code := ['LIST, :(argCode:=[(getArgValue(x,underMode) or - throwKeyedMsg("S2IC0007",[underMode])) for x in l])] - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - if tar then val1 := coerceInteractive(val,tar) else val1 := val - - val1 => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -replaceSymbols(modeList,l) == - -- replaces symbol types with their corresponding polynomial types - -- if not all type are symbols - not ($Symbol in modeList) => modeList - modeList is [a,:b] and and/[a=x for x in b] => modeList - [if m=$Symbol then getMinimalVarMode(objValUnwrap(getValue arg), - $declaredMode) else m for m in modeList for arg in l] - -upNullList(op,l,tar) == - -- handler for [] (empty list) - defMode := - tar and tar is [a,b] and (a in '(Stream Vector List)) and - not isPartialMode(b) => ['List,b] - '(List (None)) - val := objNewWrap(NIL,defMode) - tar and not isPartialMode(tar) => - null (val' := coerceInteractive(val,tar)) => - throwKeyedMsg("S2IS0013",[tar]) - putValue(op,val') - putModeSet(op,[tar]) - putValue(op,val) - putModeSet(op,[defMode]) - -upTaggedUnionConstruct(op,l,tar) == - -- special handler for tagged union constructors - tar isnt [.,:types] => nil - #l ^= 1 => throwKeyedMsg("S2IS0051",[#l,tar]) - bottomUp first l - obj := getValue first l - (code := coerceInteractive(getValue first l,tar)) or - throwKeyedMsgCannotCoerceWithValue(objVal obj, objMode obj,tar) - putValue(op,code) - putModeSet(op,[tar]) - -upRecordConstruct(op,l,tar) == - -- special handler for record constructors - tar isnt [.,:types] => nil - argModes := nil - for arg in l repeat bottomUp arg - argCode := - [(getArgValue(arg,type) or throwKeyedMsgCannotCoerceWithValue( - objVal getValue arg,objMode getValue arg,type)) - for arg in l for ['_:,.,type] in types] - len := #l - code := - (len = 1) => ["CONS", :argCode, '()] - (len = 2) => ["CONS",:argCode] - ['VECTOR,:argCode] - if $genValue then code := wrap timedEVALFUN code - putValue(op,objNew(code,tar)) - putModeSet(op,[tar]) - ---% Handlers for declarations - -upDeclare t == - t isnt [op,lhs,rhs] => nil - (not $genValue) and or/[CONTAINED(var,rhs) for var in $localVars] => - keyedMsgCompFailure("S2IS0014",[lhs]) - mode := evaluateType unabbrev rhs - mode = $Void => throwKeyedMsgSP("S2IS0015",NIL,op) - not isLegitimateMode(mode,nil,nil) => throwKeyedMsgSP("S2IE0004",[mode],op) - categoryForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'category],op) - packageForm?(mode) => throwKeyedMsgSP("S2IE0011",[mode, 'package],op) - junk := - lhs is ["free",['Tuple,:vars]] or lhs is ['free,['LISTOF,:vars]] or - lhs is ["free",:vars] => - for var in vars repeat declare(['free,var],mode) - lhs is ["local",['Tuple,:vars]] or lhs is ['local,['LISTOF,:vars]] or - lhs is ["local",:vars] => - for var in vars repeat declare(["local",var],mode) - lhs is ["Tuple",:vars] or lhs is ["LISTOF",:vars] => - for var in vars repeat declare(var,mode) - declare(lhs,mode) - putValue(op,objNewWrap(voidValue(), $Void)) - putModeSet(op,[$Void]) - -declare(var,mode) == - -- performs declaration. - -- 10/31/89: no longer coerces value to new declared type - if var is ['local,v] then - uplocalWithType(v,mode) - var := v - if var is ['free,v] then - upfreeWithType(v,mode) - var := v - not IDENTP(var) => - throwKeyedMsg("S2IS0016",[STRINGIMAGE var]) - var in '(% %%) => throwKeyedMsg("S2IS0050",[var]) - if get(var,'isInterpreterFunction,$e) then - mode isnt ['Mapping,.,:args] => - throwKeyedMsg("S2IS0017",[var,mode]) - -- validate that the new declaration has the defined # of args - mapval := objVal get(var,'value,$e) - -- mapval looks like '(MAP (args . defn)) - margs := CAADR mapval - -- if one args, margs is not a pair, just #1 or NIL - -- otherwise it looks like (Tuple #1 #2 ...) - nargs := - null margs => 0 - PAIRP margs => -1 + #margs - 1 - nargs ^= #args => throwKeyedMsg("S2IM0008",[var]) - if $compilingMap then mkLocalVar($mapName,var) - else clearDependencies(var,true) - isLocalVar(var) => put(var,'mode,mode,$env) - mode is ['Mapping,:.] => declareMap(var,mode) - v := get(var,'value,$e) => - -- only allow this if either - -- - value already has given type - -- - new mode is same as old declared mode - objMode(v) = mode => putHist(var,'mode,mode,$e) - mode = get(var,'mode,$e) => NIL -- nothing to do - throwKeyedMsg("S2IS0052",[var,mode]) - putHist(var,'mode,mode,$e) - -declareMap(var,mode) == - -- declare a Mapping property - (v:=get(var,'value,$e)) and objVal(v) isnt ['MAP,:.] => - throwKeyedMsg("S2IS0019",[var]) - isPartialMode mode => throwKeyedMsg("S2IM0004",NIL) - putHist(var,'mode,mode,$e) - -getAndEvalConstructorArgument tree == - triple := getValue tree - objMode triple = '(Domain) => triple - isWrapped objVal(triple) => triple - isLocalVar objVal triple => compFailure('" Local variable or parameter used in type") - objNewWrap(timedEVALFUN objVal(triple), objMode(triple)) - -replaceSharps(x,d) == - -- replaces all sharps in x by the arguments of domain d - -- all replaces the triangle variables - SL:= NIL - for e in CDR d for var in $FormalMapVariableList repeat - SL:= CONS(CONS(var,e),SL) - x := subCopy(x,SL) - SL:= NIL - for e in CDR d for var in $TriangleVariableList repeat - SL:= CONS(CONS(var,e),SL) - subCopy(x,SL) - -isDomainValuedVariable form == - -- returns the value of form if form is a variable with a type value - IDENTP form and (val := ( - get(form,'value,$InteractiveFrame) or _ - (PAIRP($env) and get(form,'value,$env)) or _ - (PAIRP($e) and get(form,'value,$e)))) and - objMode(val) in '((Domain) (SubDomain (Domain))) => - objValUnwrap(val) - nil - -evalCategory(d,c) == - -- tests whether domain d has category c - isPartialMode d or ofCategory(d,c) - -isOkInterpMode m == - isPartialMode(m) => isLegitimateMode(m,nil,nil) - isValidType(m) and isLegitimateMode(m,nil,nil) - -isLegitimateRecordOrTaggedUnion u == - and/[x is [":",.,d] and isLegitimateMode(d,nil,nil) for x in u] - -isPolynomialMode m == - -- If m is a polynomial type this function returns a list of its - -- variables, and nil otherwise - m is [op,a,:rargs] => - a := removeQuote a - MEMQ(op,'(Polynomial RationalFunction AlgebraicFunction Expression - ElementaryFunction LiouvillianFunction FunctionalExpression - CombinatorialFunction ))=> 'all - op = 'UnivariatePolynomial => LIST a - op = 'Variable => LIST a - MEMQ(op,'(MultivariatePolynomial DistributedMultivariatePolynomial - HomogeneousDistributedMultivariatePolynomial)) => a - NIL - NIL - -containsPolynomial m == - not PAIRP(m) => NIL - [d,:.] := m - d in $univariateDomains or d in $multivariateDomains or - d in '(Polynomial RationalFunction) => true - (m' := underDomainOf m) and containsPolynomial m' - -containsVariables m == - not PAIRP(m) => NIL - [d,:.] := m - d in $univariateDomains or d in $multivariateDomains => true - (m' := underDomainOf m) and containsVariables m' - -listOfDuplicates l == - l is [x,:l'] => - x in l' => [x,:listOfDuplicates deleteAll(x,l')] - listOfDuplicates l' - --- The following function removes all occurrences of x from the list l - -deleteAll(x,l) == - null l => nil - x = CAR(l) => deleteAll(x,CDR l) - [first l,:deleteAll(x,rest l)] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot new file mode 100644 index 00000000..aec3d6ce --- /dev/null +++ b/src/interp/i-spec2.boot @@ -0,0 +1,1150 @@ +-- 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. + + +import '"i-spec1" +)package "BOOT" + +-- Functions which require special handlers (also see end of file) + +--% Handlers for map definitions + +upDEF t == + -- performs map definitions. value is thrown away + t isnt [op,def,pred,.] => nil + v:=addDefMap(["DEF",:def],pred) + null(LISTP(def)) or null(def) => + keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) + mapOp := first def + if LISTP(mapOp) then + null mapOp => + keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) + mapOp := first mapOp + put(mapOp,"value",v,$e) + putValue(op,objNew(voidValue(), $Void)) + putModeSet(op,[$Void]) + +--% Handler for package calling and $ constants + +upDollar t == + -- Puts "dollar" property in atree node, and calls bottom up + t isnt [op,D,form] => nil + t2 := t + (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] => + keyedMsgCompFailure("S2IS0032",NIL) + EQ(D,"Lisp") => upLispCall(op,form) + if VECP D and (SIZE(D) > 0) then D := D.0 + t := evaluateType unabbrev D + categoryForm? t => + throwKeyedMsg("S2IE0012", [t]) + f := getUnname form + if f = $immediateDataSymbol then + f := objValUnwrap coerceInteractive(getValue form,$OutputForm) + if f = '(construct) then f := "nil" + ATOM(form) and (f ^= $immediateDataSymbol) and + (u := findUniqueOpInDomain(op,f,t)) => u + f in '(One Zero true false nil) and constantInDomain?([f],t) => + isPartialMode t => throwKeyedMsg("S2IS0020",NIL) + if $genValue then + val := wrap getConstantFromDomain([f],t) + else val := ["getConstantFromDomain",["LIST",MKQ f],MKQ t] + putValue(op,objNew(val,t)) + putModeSet(op,[t]) + + nargs := #rest form + + (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms + + f ^= "construct" and null isOpInDomain(f,t,nargs) => + throwKeyedMsg("S2IS0023",[f,t]) + if (sig := findCommonSigInDomain(f,t,nargs)) then + for x in sig for y in form repeat + if x then putTarget(y,x) + putAtree(first form,"dollar",t) + ms := bottomUp form + f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm => + throwKeyedMsg("S2IS0021",[f,t]) + putValue(op,getValue first form) + putModeSet(op,ms) + + +upDollarTuple(op, f, t, t2, args, nargs) == + -- this function tries to find a tuple function to use + nargs = 1 and getUnname first args = "Tuple" => NIL + nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL + null (singles := isOpInDomain(f,t,1)) => NIL + tuple := NIL + for [[.,arg], :.] in singles while null tuple repeat + if arg is ['Tuple,.] then tuple := arg + null tuple => NIL + [.,D,form] := t2 + newArg := [mkAtreeNode "Tuple",:args] + putTarget(newArg, tuple) + ms := bottomUp newArg + first ms ^= tuple => NIL + form := [first form, newArg] + putAtree(first form,"dollar",t) + ms := bottomUp form + putValue(op,getValue first form) + putModeSet(op,ms) + +upLispCall(op,t) == + -- process $Lisp calls + if atom t then code:=getUnname t else + [lispOp,:argl]:= t + null functionp lispOp.0 => + throwKeyedMsg("S2IS0024",[lispOp.0]) + for arg in argl repeat bottomUp arg + code:=[getUnname lispOp, + :[getArgValue(arg,computedMode arg) for arg in argl]] + code := + $genValue => wrap timedEVALFUN code + code + rt := '(SExpression) + putValue(op,objNew(code,rt)) + putModeSet(op,[rt]) + +--% Handlers for equation + +upequation tree == + -- only handle this if there is a target of Boolean + -- this should speed things up a bit + tree isnt [op,lhs,rhs] => NIL + $Boolean ^= getTarget(op) => NIL + null VECP op => NIL + -- change equation into '=' + op.0 := "=" + bottomUp tree + +--% Handler for error + +uperror t == + -- when compiling a function, this merely inserts another argument + -- which is the name of the function. + not $compilingMap => NIL + t isnt [op,msg] => NIL + msgMs := bottomUp msg + msgMs isnt [=$String] => NIL + RPLACD(t,[mkAtree object2String $mapName,msg]) + bottomUp t + +--% Handlers for free and local + +upfree t == + putValue(t,objNew('(voidValue),$Void)) + putModeSet(t,[$Void]) + +uplocal t == + putValue(t,objNew('(voidValue),$Void)) + putModeSet(t,[$Void]) + +upfreeWithType(var,type) == + sayKeyedMsg("S2IS0055",['"free",var]) + var + +uplocalWithType(var,type) == + sayKeyedMsg("S2IS0055",['"local",var]) + var + +--% Handlers for has + +uphas t == + t isnt [op,type,prop] => nil + -- handler for category and attribute queries + type := + isLocalVar(type) => ["unabbrev", type] + MKQ unabbrev type + catCode := + prop := unabbrev prop + evaluateType0 prop => ["evaluateType", MKQ prop] + MKQ prop + code:=["newHasTest",["evaluateType", type], catCode] + if $genValue then code := wrap timedEVALFUN code + putValue(op,objNew(code,$Boolean)) + putModeSet(op,[$Boolean]) + +--hasTest(a,b) == +-- newHasTest(a,b) --see NRUNFAST BOOT + +--% Handlers for IF + +upIF t == + t isnt [op,cond,a,b] => nil + bottomUpPredicate(cond,'"if/when") + $genValue => interpIF(op,cond,a,b) + compileIF(op,cond,a,b,t) + +compileIF(op,cond,a,b,t) == + -- type analyzer for compiled case where types of both branches of + -- IF are resolved. + ms1 := bottomUp a + [m1] := ms1 + b = "noBranch" => + evalIF(op,rest t,$Void) + putModeSet(op,[$Void]) + b = "noMapVal" => + -- if this was a return statement, we take the mode to be that + -- of what is being returned. + if getUnname a = 'return then + ms1 := bottomUp CADR a + [m1] := ms1 + evalIF(op,rest t,m1) + putModeSet(op,ms1) + ms2 := bottomUp b + [m2] := ms2 + m:= + m2=m1 => m1 + m2 = $Exit => m1 + m1 = $Exit => m2 + if EQCAR(m1,"Symbol") then + m1:=getMinimalVarMode(getUnname a,$declaredMode) + if EQCAR(m2,"Symbol") then + m2:=getMinimalVarMode(getUnname b,$declaredMode) + (r := resolveTTAny(m2,m1)) => r + rempropI($mapName,'localModemap) + rempropI($mapName,'localVars) + rempropI($mapName,'mapBody) + throwKeyedMsg("S2IS0026",[m2,m1]) + evalIF(op,rest t,m) + putModeSet(op,[m]) + +evalIF(op,[cond,a,b],m) == + -- generate code form compiled IF + elseCode:= + b="noMapVal" => + [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018", + ["CONS",MKQ object2Identifier $mapName,NIL]]]] + b='noBranch => + $lastLineInSEQ => [[MKQ true,["voidValue"]]] + NIL + [[MKQ true,genIFvalCode(b,m)]] + code:=["COND",[getArgValue(cond,$Boolean), + genIFvalCode(a,m)],:elseCode] + triple:= objNew(code,m) + putValue(op,triple) + +genIFvalCode(t,m) == + -- passes type information down braches of IF statement + -- So that coercions can be performed on data at branches of IF. + m1 := computedMode t + m1=m => getArgValue(t,m) + code:=objVal getValue t + IFcodeTran(code,m,m1) + +IFcodeTran(code,m,m1) == + -- coerces values at branches of IF + null code => code + code is ["spadThrowBrightly",:.] => code + m1 = $Exit => code + code isnt ["COND",[p1,a1],[''T,a2]] => + m = $Void => code + code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => + wrapped2Quote objVal code' + throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) + a1:=IFcodeTran(a1,m,m1) + a2:=IFcodeTran(a2,m,m1) + ['COND,[p1,a1],[''T,a2]] + +interpIF(op,cond,a,b) == + -- non-compiled version of IF type analyzer. Doesn't resolve accross + -- branches of the IF. + val:= getValue cond + val:= coerceInteractive(val,$Boolean) => + objValUnwrap(val) => upIFgenValue(op,a) + EQ(b,"noBranch") => + putValue(op,objNew(voidValue(), $Void)) + putModeSet(op,[$Void]) + upIFgenValue(op,b) + throwKeyedMsg("S2IS0031",NIL) + +upIFgenValue(op,tree) == + -- evaluates tree and transfers the results to op + ms:=bottomUp tree + val:= getValue tree + putValue(op,val) + putModeSet(op,ms) + +--% Handlers for is + +upis t == + t isnt [op,a,pattern] => nil + $opIsIs : local := true + upisAndIsnt t + +upisnt t == + t isnt [op,a,pattern] => nil + $opIsIs : local := nil + upisAndIsnt t + +upisAndIsnt(t:=[op,a,pattern]) == + -- handler for "is" pattern matching + mS:= bottomUp a + mS isnt [m] => + keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) + putPvarModes(removeConstruct pattern,m) + evalis(op,rest t,m) + putModeSet(op,[$Boolean]) + +putPvarModes(pattern,m) == + -- Puts the modes for the pattern variables into $env + m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL) + for pvar in pattern repeat + IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) + pvar is ['_:,var] => + null (var=$quadSymbol) and put(var,"mode",m,$env) + pvar is ['_=,var] => + null (var=$quadSymbol) and put(var,"mode",um,$env) + putPvarModes(pvar,um) + +evalis(op,[a,pattern],mode) == + -- actually handles is and isnt + if $opIsIs + then fun := 'evalIsPredicate + else fun := 'evalIsntPredicate + if isLocalPred pattern then + code:= compileIs(a,pattern) + else code:=[fun,getArgValue(a,mode), + MKQ pattern,MKQ mode] + triple:= + $genValue => objNewWrap(timedEVALFUN code,$Boolean) + objNew(code,$Boolean) + putValue(op,triple) + +isLocalPred pattern == + -- returns true if the is predicate is to be compiled + for pat in pattern repeat + IDENTP pat and isLocalVar(pat) => return true + pat is [":",var] and isLocalVar(var) => return true + pat is ["=",var] and isLocalVar(var) => return true + +compileIs(val,pattern) == + -- produce code for compiled "is" predicate. makes pattern variables + -- into local variables of the function + vars:= NIL + for pat in CDR pattern repeat + IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars] + pat is [":",var] => vars:= [var,:vars] + pat is ["=",var] => vars:= [var,:vars] + predCode:=["LET",g:=GENSYM(),["isPatternMatch", + getArgValue(val,computedMode val),MKQ removeConstruct pattern]] + for var in REMDUP vars repeat + assignCode:=[["LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode] + null $opIsIs => + ["COND",[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,MKQ 'T]]] + ["COND",[["NOT",["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,MKQ 'T]]] + +evalIsPredicate(value,pattern,mode) == + --This function pattern matches value to pattern, and returns + --true if it matches, and false otherwise. As a side effect + --if the pattern matches then the bindings given in the pattern + --are made + pattern:= removeConstruct pattern + ^((valueAlist:=isPatternMatch(value,pattern))='failed) => + for [id,:value] in valueAlist repeat + evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) + true + false + +evalIsntPredicate(value,pattern,mode) == + evalIsPredicate(value,pattern,mode) => NIL + 'TRUE + +removeConstruct pat == + -- removes the "construct" from the beginning of patterns + if pat is ["construct",:p] then pat:=p + if pat is ["cons", a, b] then pat := [a, [":", b]] + atom pat => pat + RPLACA(pat,removeConstruct CAR pat) + RPLACD(pat,removeConstruct CDR pat) + pat + +isPatternMatch(l,pats) == + -- perform the actual pattern match + $subs: local := NIL + isPatMatch(l,pats) + $subs + +isPatMatch(l,pats) == + null pats => + null l => $subs + $subs:='failed + null l => + null pats => $subs + pats is [[":",var]] => + $subs := [[var],:$subs] + $subs:='failed + pats is [pat,:restPats] => + IDENTP pat => + $subs:=[[pat,:first l],:$subs] + isPatMatch(rest l,restPats) + pat is ["=",var] => + p:=ASSQ(var,$subs) => + CAR l = CDR p => isPatMatch(rest l, restPats) + $subs:="failed" + $subs:="failed" + pat is [":",var] => + n:=#restPats + m:=#l-n + m<0 => $subs:="failed" + ZEROP n => $subs:=[[var,:l],:$subs] + $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] + isPatMatch(DROP(m,l),restPats) + isPatMatch(first l,pat) = "failed" => "failed" + isPatMatch(rest l,restPats) + keyedSystemError("S2GE0016",['"isPatMatch", + '"unknown form of is predicate"]) + +--% Handler for iterate + +upiterate t == + null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) + $iterateCount := $iterateCount + 1 + code := ["THROW",$repeatBodyLabel,'(voidValue)] + $genValue => THROW(eval $repeatBodyLabel,voidValue()) + putValue(t,objNew(code,$Void)) + putModeSet(t,[$Void]) + +--% Handler for break + +upbreak t == + t isnt [op,.] => nil + null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) + $breakCount := $breakCount + 1 + code := ["THROW",$repeatLabel,'(voidValue)] + $genValue => THROW(eval $repeatLabel,voidValue()) + putValue(op,objNew(code,$Void)) + putModeSet(op,[$Void]) + +--% Handlers for LET + +upLET t == + -- analyzes and evaluates the righthand side, and does the variable + -- binding + t isnt [op,lhs,rhs] => nil + $declaredMode: local := NIL + PAIRP lhs => + var:= getUnname first lhs + var = "construct" => upLETWithPatternOnLhs t + var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"]) + upLETWithFormOnLhs(op,lhs,rhs) + var:= getUnname lhs + var = $immediateDataSymbol => + -- following will be immediate data, so probably ok to not + -- specially format it + obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) + throwKeyedMsg("S2IS0027",[obj]) + var in '(% %%) => -- for history + throwKeyedMsg("S2IS0027",[var]) + (IDENTP var) and not (var in '(true false elt QUOTE)) => + var ^= (var' := unabbrev(var)) => -- constructor abbreviation + throwKeyedMsg("S2IS0028",[var,var']) + if get(var,'isInterpreterFunction,$e) then + putHist(var,'isInterpreterFunction,false,$e) + sayKeyedMsg("S2IS0049",['"Function",var]) + else if get(var,'isInterpreterRule,$e) then + putHist(var,'isInterpreterRule,false,$e) + sayKeyedMsg("S2IS0049",['"Rule",var]) + not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m) + transferPropsToNode(var,lhs) + if ( m:= getMode(lhs) ) then + $declaredMode := m + putTarget(rhs,m) + if (val := getValue lhs) and (objMode val = $Boolean) and + getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) + (rhsMs:= bottomUp rhs) = [$Void] => + throwKeyedMsg("S2IS0034",[var]) + val:=evalLET(lhs,rhs) + putValue(op,val) + putModeSet(op,[objMode(val)]) + throwKeyedMsg("S2IS0027",[var]) + +isTupleForm f == + -- have to do following since "Tuple" is an internal form name + getUnname f ^= "Tuple" => false + f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" => + #args ^= 1 => true + isTupleForm first args => true + isType first args => false + true + false + +evalLET(lhs,rhs) == + -- lhs is a vector for a variable, and rhs is the evaluated atree + -- for the value which is coerced to the mode of lhs + $useConvertForCoercions: local := true + v' := (v:= getValue rhs) + ((not getMode lhs) and (getModeSet rhs is [.])) or + get(getUnname lhs,'autoDeclare,$env) => + v:= + $genValue => v + objNew(wrapped2Quote objVal v,objMode v) + evalLETput(lhs,v) + t1:= objMode v + t2' := (t2 := getMode lhs) + value:= + t1 = t2 => + $genValue => v + objNew(wrapped2Quote objVal v,objMode v) + if isPartialMode t2 then + if EQCAR(t1,'Symbol) and $declaredMode then + t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) + t' := t2 + null (t2 := resolveTM(t1,t2)) => + if not t2 then t2 := t' + throwKeyedMsg("S2IS0035",[t1,t2]) + null (v := getArgValue(rhs,t2)) => + isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => + throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) + throwKeyedMsg("S2IS0037",[t2]) + t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2) + value => evalLETput(lhs,value) + throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) + +evalLETput(lhs,value) == + -- put value into the cell for lhs + name:= getUnname lhs + if not $genValue then + code:= + isLocalVar(name) => + om := objMode(value) + dm := get(name,'mode,$env) + dm and not ((om = dm) or isSubDomain(om,dm) or + isSubDomain(dm,om)) => + compFailure ['" The type of the local variable", + :bright name,'"has changed in the computation."] + if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) + ['LET,name,objVal value,$mapName] + -- $mapName is set in analyzeMap + om := objMode value + dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) + dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => + THROW('loopCompiler,'tryInterpOnly) + ['unwrap,['evalLETchangeValue,MKQ name, + objNewCode(['wrap,objVal value],objMode value)]] + value:= objNew(code,objMode value) + isLocalVar(name) => + if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) + put(name,'mode,objMode(value),$env) + put(name,'automode,objMode(value),$env) + $genValue and evalLETchangeValue(name,value) + putValue(lhs,value) + +upLETWithPatternOnLhs(t := [op,pattern,a]) == + $opIsIs : local := true + [m] := bottomUp a + putPvarModes(pattern,m) + object := evalis(op,[a,pattern],m) + -- have to change code to return value of a + failCode := + ['spadThrowBrightly,['concat, + '" Pattern",['QUOTE,bright form2String pattern], + '"is not matched in assignment to right-hand side."]] + if $genValue + then + null objValUnwrap object => eval failCode + putValue(op,getValue a) + else + code := ['COND,[objVal object,objVal getValue a],[''T,failCode]] + putValue(op,objNew(code,m)) + putModeSet(op,[m]) + +evalLETchangeValue(name,value) == + -- write the value of name into the environment, clearing dependent + -- maps if its type changes from its last value + localEnv := PAIRP $env + clearCompilationsFlag := + val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) + null val => + not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) + objMode val ^= objMode(value) + if clearCompilationsFlag then + clearDependencies(name,true) + if localEnv and isLocalVar(name) + then $env:= putHist(name,'value,value,$env) + else putIntSymTab(name,'value,value,$e) + objVal value + +upLETWithFormOnLhs(op,lhs,rhs) == + -- bottomUp for assignment to forms (setelt, table or tuple) + lhs' := getUnnameIfCan lhs + rhs' := getUnnameIfCan rhs + lhs' = 'Tuple => + rhs' ^= 'Tuple => throwKeyedMsg("S2IS0039",NIL) + #(lhs) ^= #(rhs) => throwKeyedMsg("S2IS0038",NIL) + -- generate a sequence of assignments, using local variables + -- to first hold the assignments so that things like + -- (t1,t2) := (t2,t1) will work. + seq := [] + temps := [GENSYM() for l in rest lhs] + for lvar in temps repeat mkLocalVar($mapName,lvar) + for l in reverse rest lhs for t in temps repeat + transferPropsToNode(getUnname l,l) + let := mkAtreeNode 'LET + t' := mkAtreeNode t + if m := getMode(l) then putMode(t',m) + seq := cons([let,l,t'],seq) + for t in temps for r in reverse rest rhs + for l in reverse rest lhs repeat + let := mkAtreeNode 'LET + t' := mkAtreeNode t + if m := getMode(l) then putMode(t',m) + seq := cons([let,t',r],seq) + seq := cons(mkAtreeNode 'SEQ,seq) + ms := bottomUp seq + putValue(op,getValue seq) + putModeSet(op,ms) + rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL) + tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) + throwKeyedMsg("S2IS0060", NIL) +-- upTableSetelt(op,lhs,rhs) + +seteltable(lhs is [f,:argl],rhs) == + -- produces the setelt form for trees such as "l.2:= 3" + null (g := getUnnameIfCan f) => NIL + EQ(g,"elt") => altSeteltable [:argl, rhs] + get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL + transferPropsToNode(g,f) + getValue(lhs) or getMode(lhs) => + f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs] + altSeteltable [:lhs,rhs] + NIL + +altSeteltable args == + for x in args repeat bottomUp x + newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"] + form := NIL + + -- first look for exact matches for any of the possibilities + while ^form for newOp in newOps repeat + if selectMms(newOp, args, NIL) then form := [newOp, :args] + + -- now try retracting arguments after the first + while ^form and ( "and"/[retractAtree(a) for a in rest args] ) repeat + while ^form for newOp in newOps repeat + if selectMms(newOp, args, NIL) then form := [newOp, :args] + + form + + +upSetelt(op,lhs,tree) == + -- type analyzes implicit setelt forms + var:=opOf lhs + transferPropsToNode(getUnname var,var) + if (m1:=getMode var) then $declaredMode:= m1 + if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then + putModeSet(var,[m1]) + ms := bottomUp tree + putValue(op,getValue tree) + putModeSet(op,ms) + +upTableSetelt(op,lhs is [htOp,:args],rhs) == + -- called only for undeclared, uninitialized table setelts + ("*" = (PNAME getUnname htOp).0) and (1 ^= # args) => + throwKeyedMsg("S2IS0040",NIL) + # args ^= 1 => + throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", + getUnname first args, + ['",",getUnname arg for arg in rest args],'"]"]]) + keyMode := '(Any) + putMode (htOp,['Table,keyMode,'(Any)]) + -- if we are to use a new table, we must call the "table" + -- function to give it an initial value. + bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]] + tableCode := objVal getValue htOp + r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs]) + $genValue => r + -- construct code + t := getValue op + putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) + r + +unVectorize body == + -- transforms from an atree back into a tree + VECP body => + name := getUnname body + name ^= $immediateDataSymbol => name + objValUnwrap getValue body + atom body => body + body is [op,:argl] => + newOp:=unVectorize op + if newOp = 'SUCHTHAT then newOp := "|" + if newOp = 'COERCE then newOp := "::" + if newOp = 'Dollar then newOp := "$elt" + [newOp,:unVectorize argl] + systemErrorHere '"unVectorize" + +isType t == + -- Returns the evaluated type if t is a tree representing a type, + -- and NIL otherwise + op:=opOf t + VECP op => + isMap(op:= getUnname op) => NIL + op = 'Mapping => + argTypes := [isType type for type in rest t] + "or"/[null type for type in argTypes] => nil + ['Mapping, :argTypes] + isLocalVar(op) => NIL + d := isDomainValuedVariable op => d + type:= + -- next line handles subscripted vars + (abbreviation?(op) or (op = 'typeOf) or + constructor?(op) or (op in '(Record Union Enumeration))) and + unabbrev unVectorize t + type and evaluateType type + d := isDomainValuedVariable op => d + NIL + +upLETtype(op,lhs,type) == + -- performs type assignment + opName:= getUnname lhs + (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] => + compFailure ['" Cannot compile type assignment to",:bright opName] + mode := + if isPartialMode type then '(Mode) + else if categoryForm?(type) then '(SubDomain (Domain)) + else '(Domain) + val:= objNew(type,mode) + if isLocalVar(opName) then put(opName,'value,val,$env) + else putHist(opName,'value,val,$e) + putValue(op,val) + -- have to fix the following + putModeSet(op,[mode]) + +assignSymbol(symbol, value, domain) == +-- Special function for binding an interpreter variable from within algebra +-- code. Does not do the assignment and returns nil, if the variable is +-- already assigned + val := get(symbol, 'value, $e) => nil + obj := objNew(wrap value, devaluate domain) + put(symbol, 'value, obj, $e) + true + +--% Handler for Interpreter Macros + +getInterpMacroNames() == + names := [n for [n,:.] in $InterpreterMacroAlist] + if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then + names := append(names,[n for [n,:.] in CDR m]) + MSORT names + +isInterpMacro name == + -- look in local and then global environment for a macro + null IDENTP name => NIL + name in $specialOps => NIL + (m := get("--macros--",name,$env)) => m + (m := get("--macros--",name,$e)) => m + (m := get("--macros--",name,$InteractiveFrame)) => m + -- $InterpreterMacroAlist will probably be phased out soon + (sv := assoc(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv) + NIL + +--% Handlers for prefix QUOTE + +upQUOTE t == + t isnt [op,expr] => NIL + ms:= list + m:= getBasicMode expr => m + IDENTP expr => +-- $useSymbolNotVariable => $Symbol + ['Variable,expr] + $OutputForm + evalQUOTE(op,[expr],ms) + putModeSet(op,ms) + +evalQUOTE(op,[expr],[m]) == + triple:= + $genValue => objNewWrap(expr,m) + objNew(['QUOTE,expr],m) + putValue(op,triple) + +--% Handler for pretend + +uppretend t == + t isnt [op,expr,type] => NIL + mode := evaluateType unabbrev type + not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) + bottomUp expr + putValue(op,objNew(objVal getValue expr,mode)) + putModeSet(op,[mode]) + +--% Handlers for REDUCE + +getReduceFunction(op,type,result, locale) == + -- return the function cell for operation with the signature + -- (type,type) -> type, possible from locale + if type is ['Variable,var] then + args := [arg := mkAtreeNode var,arg] + putValue(arg,objNewWrap(var,type)) + else + args := [arg := mkAtreeNode "%1",arg] + if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) + putModeSet(arg,[type]) + vecOp:=mkAtreeNode op + transferPropsToNode(op,vecOp) + if locale then putAtree(vecOp,'dollar,locale) + mmS:= selectMms(vecOp,args,result) + mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | + (isHomogeneousArgs sig) and "and"/[null c for c in cond]] + null mm => 'failed + [[dc,:sig],fun,:.]:=mm + dc='local => [MKQ [fun,:'local],:CAR sig] + dcVector := evalDomain dc + $compilingMap => + k := NRTgetMinivectorIndex( + NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) + ['ELT,"$$$",k] --$$$ denotes minivector + env:= + NRTcompiledLookup(op,sig,dcVector) + MKQ env + +isHomogeneous sig == + --return true if sig describes a homogeneous binary operation + sig.0=sig.1 and sig.1=sig.2 + +isHomogeneousArgs sig == + --return true if sig describes a homogeneous binary operation + sig.1=sig.2 + +--% Handlers for REPEAT + +transformREPEAT [:itrl,body] == + -- syntactic transformation of repeat iterators, called from mkAtree2 + iterList:=[:iterTran1 for it in itrl] where iterTran1() == + it is ["STEP",index,lower,step,:upperList] => + [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper + for upper in upperList]]] + it is ["IN",index,s] => + [['IN,index,mkAtree1 s]] + it is ["ON",index,s] => + [['IN,index,mkAtree1 ['tails,s]]] + it is ["WHILE",b] => + [["WHILE",mkAtree1 b]] + it is ["|",pred] => + [["SUCHTHAT",mkAtree1 pred]] + it is [op,:.] and (op in '(VALUE UNTIL)) => nil + bodyTree:=mkAtree1 body + iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2() == + it is ["STEP",:.] => nil + it is ["IN",:.] => nil + it is ["ON",:.] => nil + it is ["WHILE",:.] => nil + it is [op,b] and (op in '(UNTIL VALUE)) => + [[op,mkAtree1 b]] + it is ['_|,pred] => nil + keyedSystemError("S2GE0016", + ['"transformREPEAT",'"Unknown type of iterator"]) + [:iterList,bodyTree] + +upREPEAT t == + -- REPEATS always return void() of Void + -- assures throw to interpret-code mode goes to outermost loop + $repeatLabel : local := MKQ GENSYM() + $breakCount : local := 0 + $repeatBodyLabel : local := MKQ GENSYM() + $iterateCount : local := 0 + $compilingLoop => upREPEAT1 t + upREPEAT0 t + +upREPEAT0 t == + -- sets up catch point for interp-only mode + $compilingLoop: local := true + ms := CATCH('loopCompiler,upREPEAT1 t) + ms = 'tryInterpOnly => interpOnlyREPEAT t + ms + +upREPEAT1 t == + -- repeat loop handler with compiled body + -- see if it has the expected form + t isnt [op,:itrl,body] => NIL + -- determine the mode of the repeat loop. At the moment, if there + -- there are no iterators and there are no "break" statements, then + -- the return type is Exit, otherwise Void. + repeatMode := + null(itrl) and ($breakCount=0) => $Void + $Void + + -- if interpreting, go do that + $interpOnly => interpREPEAT(op,itrl,body,repeatMode) + + -- analyze iterators and loop body + upLoopIters itrl + bottomUpCompile body + + -- now that the body is analyzed, we should know everything that + -- is in the UNTIL clause + for itr in itrl repeat + itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") + + -- now go do it + evalREPEAT(op,rest t,repeatMode) + putModeSet(op,[repeatMode]) + +evalREPEAT(op,[:itrl,body],repeatMode) == + -- generate code for loop + bodyMode := computedMode body + bodyCode := getArgValue(body,bodyMode) + if $iterateCount > 0 then + bodyCode := ["CATCH",$repeatBodyLabel,bodyCode] + code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode] + if repeatMode = $Void then code := ['OR,code,'(voidValue)] + code := timedOptimization code + if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] + val:= + $genValue => + timedEVALFUN code + objNewWrap(voidValue(),repeatMode) + objNew(code,repeatMode) + putValue(op,val) + +interpOnlyREPEAT t == + -- interpret-code mode call to upREPEAT + $genValue: local := true + $interpOnly: local := true + upREPEAT1 t + +interpREPEAT(op,itrl,body,repeatMode) == + -- performs interpret-code repeat + $indexVars: local := NIL + $indexTypes: local := NIL + code := + -- we must insert a CATCH for the iterate clause + ["REPEAT",:[interpIter itr for itr in itrl], + ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars, + $indexTypes,nil)]] + SPADCATCH(eval $repeatLabel,timedEVALFUN code) + val:= objNewWrap(voidValue(),repeatMode) + putValue(op,val) + putModeSet(op,[repeatMode]) + +interpLoop(expr,indexList,indexTypes,requiredType) == + -- generates code for interp-only repeat body + ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList], + MKQ indexTypes, MKQ requiredType] + +interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == + -- call interpreter on exp with loop vars in indexList with given + -- values and types, requiredType is used from interpCOLLECT + -- to indicate the required type of the result + emptyAtree exp + for i in indexList for val in indexVals for type in indexTypes repeat + put(i,'value,objNewWrap(val,type),$env) + bottomUp exp + v:= getValue exp + val := + null requiredType => v + coerceInteractive(v,requiredType) + null val => + throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) + objValUnwrap val + +--% Handler for return + +upreturn t == + -- make sure we are in a user function + t isnt [op,val] => NIL + (null $compilingMap) and (null $interpOnly) => + throwKeyedMsg("S2IS0047",NIL) + if $mapTarget then putTarget(val,$mapTarget) + bottomUp val + if $mapTarget + then + val' := getArgValue(val, $mapTarget) + m := $mapTarget + else + val' := wrapped2Quote objVal getValue val + m := computedMode val + cn := mapCatchName $mapName + $mapReturnTypes := insert(m, $mapReturnTypes) + $mapThrowCount := $mapThrowCount + 1 + -- if $genValue then we are interpreting the map + $genValue => THROW(cn,objNewWrap(removeQuote val',m)) + putValue(op,objNew(['THROW,MKQ cn,val'],m)) + putModeSet(op,[$Exit]) + +--% Handler for SEQ + +upSEQ u == + -- assumes that exits were translated into if-then-elses + -- handles flat SEQs and embedded returns + u isnt [op,:args] => NIL + if (target := getTarget(op)) then putTarget(last args, target) + for x in args repeat bottomUp x + null (m := computedMode last args) => + keyedSystemError("S2GE0016",['"upSEQ", + '"last line of SEQ has no mode"]) + evalSEQ(op,args,m) + putModeSet(op,[m]) + +evalSEQ(op,args,m) == + -- generate code for SEQ + [:argl,last] := args + val:= + $genValue => getValue last + bodyCode := nil + for x in args repeat + (m1 := computedMode x) and (m1 ^= '$ThrowAwayMode) => + (av := getArgValue(x,m1)) ^= voidValue() => + bodyCode := [av,:bodyCode] + code:= + bodyCode is [c] => c + ['PROGN,:reverse bodyCode] + objNew(code,m) + putValue(op,val) + +--% Handlers for Tuple + +upTuple t == + --Computes the common mode set of the construct by resolving across + --the argument list, and evaluating + t isnt [op,:l] => nil + dol := getAtree(op,'dollar) + tar := getTarget(op) or dol + null l => upNullTuple(op,l,tar) + isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) + aggs := '(List) + if tar and PAIRP(tar) and ^isPartialMode(tar) then + CAR(tar) in aggs => + ud := CADR tar + for x in l repeat if not getTarget(x) then putTarget(x,ud) + CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => + vec := ['List,underDomainOf tar] + for x in l repeat if not getTarget(x) then putTarget(x,vec) + argModeSetList:= [bottomUp x for x in l] + eltTypes := replaceSymbols([first x for x in argModeSetList],l) + if not isPartialMode(tar) and tar is ['Tuple,ud] then + mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)] + else mode := ['Tuple, resolveTypeListAny eltTypes] + if isPartialMode tar then tar:=resolveTM(mode,tar) + evalTuple(op,l,mode,tar) + +evalTuple(op,l,m,tar) == + [agg,:.,underMode]:= m + code := asTupleNewCode(#l, + [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) + val := + $genValue => objNewWrap(timedEVALFUN code,m) + objNew(code,m) + if tar then val1 := coerceInteractive(val,tar) else val1 := val + + val1 => + putValue(op,val1) + putModeSet(op,[tar or m]) + putValue(op,val) + putModeSet(op,[m]) + +upNullTuple(op,l,tar) == + -- handler for the empty tuple + defMode := + tar and tar is [a,b] and (a in '(Stream Vector List)) and + not isPartialMode(b) => ['Tuple,b] + '(Tuple (None)) + val := objNewWrap(asTupleNew(0,NIL), defMode) + tar and not isPartialMode(tar) => + null (val' := coerceInteractive(val,tar)) => + throwKeyedMsg("S2IS0013",[tar]) + putValue(op,val') + putModeSet(op,[tar]) + putValue(op,val) + putModeSet(op,[defMode]) + +--% Handler for typeOf + +uptypeOf form == + form isnt [op, arg] => NIL + if VECP arg then transferPropsToNode(getUnname arg,arg) + if m := isType(arg) then + m := + categoryForm?(m) => '(SubDomain (Domain)) + isPartialMode m => '(Mode) + '(Domain) + else if not (m := getMode arg) then [m] := bottomUp arg + t := typeOfType m + putValue(op, objNew(m,t)) + putModeSet(op,[t]) + +typeOfType type == + type in '((Mode) (Domain)) => '(SubDomain (Domain)) + '(Domain) + +--% Handler for where + +upwhere t == + -- upwhere does the puts in where into a local environment + t isnt [op,tree,clause] => NIL + -- since the "clause" might be a local macro, we now call mkAtree + -- on the "tree" part (it is not yet a vat) + not $genValue => + compFailure [:bright '" where", + '"for compiled code is not yet implemented."] + $whereCacheList : local := nil + [env,:e] := upwhereClause(clause,$env,$e) + tree := upwhereMkAtree(tree,env,e) + if x := getAtree(op,'dollar) then + atom tree => throwKeyedMsg("S2IS0048",NIL) + putAtree(CAR tree,'dollar,x) + upwhereMain(tree,env,e) + val := getValue tree + putValue(op,val) + result := putModeSet(op,getModeSet tree) + wcl := [op for op in $whereCacheList] + for op in wcl repeat clearDependencies(op,'T) + result + +upwhereClause(tree,env,e) == + -- uses the variable bindings from env and e and returns an environment + -- of its own bindings + $env: local := copyHack env + $e: local := copyHack e + bottomUp tree + [$env,:$e] + +upwhereMkAtree(tree,$env,$e) == mkAtree tree + +upwhereMain(tree,$env,$e) == + -- uses local copies of $env and $e while evaluating tree + bottomUp tree + +copyHack(env) == + -- makes a copy of an environment with the exception of pairs + -- (localModemap . something) + c:= CAAR env + d:= [fn p for p in c] where fn(p) == + CONS(CAR p,[(EQCAR(q,'localModemap) => q; copy q) for q in CDR p]) + [[d]] + +-- Creates the function names of the special function handlers and puts +-- them on the property list of the function name + +for name in $specialOps repeat + functionName:=INTERNL('up,name) + MAKEPROP(name,'up,functionName) + CREATE_-SBC functionName + diff --git a/src/interp/i-spec2.boot.pamphlet b/src/interp/i-spec2.boot.pamphlet deleted file mode 100644 index 8d57009a..00000000 --- a/src/interp/i-spec2.boot.pamphlet +++ /dev/null @@ -1,1215 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-spec2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Handlers for Special Forms (2 of 2) - -This file contains the functions which do type analysis and -evaluation of special functions in the interpreter. -Special functions are ones which are not defined in the algebra -code, such as assignment, construct, COLLECT and declaration. - -Operators which require special handlers all have a LISP "up" -property which is the name of the special handler, which is -always the word "up" followed by the operator name. -If an operator has this "up" property the handler is called -automatically from bottomUp instead of general modemap selection. - -The up handlers are usually split into two pieces, the first is -the up function itself, which performs the type analysis, and an -"eval" function, which generates (and executes, if required) the -code for the function. -The up functions always take a single argument, which is the -entire attributed tree for the operation, and return the modeSet -of the node, which is a singleton list containing the type -computed for the node. -The eval functions can take any arguments deemed necessary. -Actual evaluation is done if $genValue is true, otherwise code is -generated. -(See the function analyzeMap for other things that may affect -what is generated in these functions.) - -These functions are required to do two things: - 1) do a putValue on the operator vector with the computed value - of the node, which is a triple. This is usually done in the - eval functions. - 2) do a putModeSet on the operator vector with a list of the - computed type of the node. This is usually done in the - up functions. - -There are several special modes used in these functions: - 1) Void is the mode that should be used for all statements - that do not otherwise return values, such as declarations, - loops, IF-THEN's without ELSE's, etc.. - 2) $NoValueMode and $ThrowAwayMode used to be used in situations - where Void is now used, and are being phased out completely. -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"i-spec1" -)package "BOOT" - --- Functions which require special handlers (also see end of file) - ---% Handlers for map definitions - -upDEF t == - -- performs map definitions. value is thrown away - t isnt [op,def,pred,.] => nil - v:=addDefMap(["DEF",:def],pred) - null(LISTP(def)) or null(def) => - keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) - mapOp := first def - if LISTP(mapOp) then - null mapOp => - keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) - mapOp := first mapOp - put(mapOp,"value",v,$e) - putValue(op,objNew(voidValue(), $Void)) - putModeSet(op,[$Void]) - ---% Handler for package calling and $ constants - -upDollar t == - -- Puts "dollar" property in atree node, and calls bottom up - t isnt [op,D,form] => nil - t2 := t - (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] => - keyedMsgCompFailure("S2IS0032",NIL) - EQ(D,"Lisp") => upLispCall(op,form) - if VECP D and (SIZE(D) > 0) then D := D.0 - t := evaluateType unabbrev D - categoryForm? t => - throwKeyedMsg("S2IE0012", [t]) - f := getUnname form - if f = $immediateDataSymbol then - f := objValUnwrap coerceInteractive(getValue form,$OutputForm) - if f = '(construct) then f := "nil" - ATOM(form) and (f ^= $immediateDataSymbol) and - (u := findUniqueOpInDomain(op,f,t)) => u - f in '(One Zero true false nil) and constantInDomain?([f],t) => - isPartialMode t => throwKeyedMsg("S2IS0020",NIL) - if $genValue then - val := wrap getConstantFromDomain([f],t) - else val := ["getConstantFromDomain",["LIST",MKQ f],MKQ t] - putValue(op,objNew(val,t)) - putModeSet(op,[t]) - - nargs := #rest form - - (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms - - f ^= "construct" and null isOpInDomain(f,t,nargs) => - throwKeyedMsg("S2IS0023",[f,t]) - if (sig := findCommonSigInDomain(f,t,nargs)) then - for x in sig for y in form repeat - if x then putTarget(y,x) - putAtree(first form,"dollar",t) - ms := bottomUp form - f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm => - throwKeyedMsg("S2IS0021",[f,t]) - putValue(op,getValue first form) - putModeSet(op,ms) - - -upDollarTuple(op, f, t, t2, args, nargs) == - -- this function tries to find a tuple function to use - nargs = 1 and getUnname first args = "Tuple" => NIL - nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL - null (singles := isOpInDomain(f,t,1)) => NIL - tuple := NIL - for [[.,arg], :.] in singles while null tuple repeat - if arg is ['Tuple,.] then tuple := arg - null tuple => NIL - [.,D,form] := t2 - newArg := [mkAtreeNode "Tuple",:args] - putTarget(newArg, tuple) - ms := bottomUp newArg - first ms ^= tuple => NIL - form := [first form, newArg] - putAtree(first form,"dollar",t) - ms := bottomUp form - putValue(op,getValue first form) - putModeSet(op,ms) - -upLispCall(op,t) == - -- process $Lisp calls - if atom t then code:=getUnname t else - [lispOp,:argl]:= t - null functionp lispOp.0 => - throwKeyedMsg("S2IS0024",[lispOp.0]) - for arg in argl repeat bottomUp arg - code:=[getUnname lispOp, - :[getArgValue(arg,computedMode arg) for arg in argl]] - code := - $genValue => wrap timedEVALFUN code - code - rt := '(SExpression) - putValue(op,objNew(code,rt)) - putModeSet(op,[rt]) - ---% Handlers for equation - -upequation tree == - -- only handle this if there is a target of Boolean - -- this should speed things up a bit - tree isnt [op,lhs,rhs] => NIL - $Boolean ^= getTarget(op) => NIL - null VECP op => NIL - -- change equation into '=' - op.0 := "=" - bottomUp tree - ---% Handler for error - -uperror t == - -- when compiling a function, this merely inserts another argument - -- which is the name of the function. - not $compilingMap => NIL - t isnt [op,msg] => NIL - msgMs := bottomUp msg - msgMs isnt [=$String] => NIL - RPLACD(t,[mkAtree object2String $mapName,msg]) - bottomUp t - ---% Handlers for free and local - -upfree t == - putValue(t,objNew('(voidValue),$Void)) - putModeSet(t,[$Void]) - -uplocal t == - putValue(t,objNew('(voidValue),$Void)) - putModeSet(t,[$Void]) - -upfreeWithType(var,type) == - sayKeyedMsg("S2IS0055",['"free",var]) - var - -uplocalWithType(var,type) == - sayKeyedMsg("S2IS0055",['"local",var]) - var - ---% Handlers for has - -uphas t == - t isnt [op,type,prop] => nil - -- handler for category and attribute queries - type := - isLocalVar(type) => ["unabbrev", type] - MKQ unabbrev type - catCode := - prop := unabbrev prop - evaluateType0 prop => ["evaluateType", MKQ prop] - MKQ prop - code:=["newHasTest",["evaluateType", type], catCode] - if $genValue then code := wrap timedEVALFUN code - putValue(op,objNew(code,$Boolean)) - putModeSet(op,[$Boolean]) - ---hasTest(a,b) == --- newHasTest(a,b) --see NRUNFAST BOOT - ---% Handlers for IF - -upIF t == - t isnt [op,cond,a,b] => nil - bottomUpPredicate(cond,'"if/when") - $genValue => interpIF(op,cond,a,b) - compileIF(op,cond,a,b,t) - -compileIF(op,cond,a,b,t) == - -- type analyzer for compiled case where types of both branches of - -- IF are resolved. - ms1 := bottomUp a - [m1] := ms1 - b = "noBranch" => - evalIF(op,rest t,$Void) - putModeSet(op,[$Void]) - b = "noMapVal" => - -- if this was a return statement, we take the mode to be that - -- of what is being returned. - if getUnname a = 'return then - ms1 := bottomUp CADR a - [m1] := ms1 - evalIF(op,rest t,m1) - putModeSet(op,ms1) - ms2 := bottomUp b - [m2] := ms2 - m:= - m2=m1 => m1 - m2 = $Exit => m1 - m1 = $Exit => m2 - if EQCAR(m1,"Symbol") then - m1:=getMinimalVarMode(getUnname a,$declaredMode) - if EQCAR(m2,"Symbol") then - m2:=getMinimalVarMode(getUnname b,$declaredMode) - (r := resolveTTAny(m2,m1)) => r - rempropI($mapName,'localModemap) - rempropI($mapName,'localVars) - rempropI($mapName,'mapBody) - throwKeyedMsg("S2IS0026",[m2,m1]) - evalIF(op,rest t,m) - putModeSet(op,[m]) - -evalIF(op,[cond,a,b],m) == - -- generate code form compiled IF - elseCode:= - b="noMapVal" => - [[MKQ true, ["throwKeyedMsg",MKQ "S2IM0018", - ["CONS",MKQ object2Identifier $mapName,NIL]]]] - b='noBranch => - $lastLineInSEQ => [[MKQ true,["voidValue"]]] - NIL - [[MKQ true,genIFvalCode(b,m)]] - code:=["COND",[getArgValue(cond,$Boolean), - genIFvalCode(a,m)],:elseCode] - triple:= objNew(code,m) - putValue(op,triple) - -genIFvalCode(t,m) == - -- passes type information down braches of IF statement - -- So that coercions can be performed on data at branches of IF. - m1 := computedMode t - m1=m => getArgValue(t,m) - code:=objVal getValue t - IFcodeTran(code,m,m1) - -IFcodeTran(code,m,m1) == - -- coerces values at branches of IF - null code => code - code is ["spadThrowBrightly",:.] => code - m1 = $Exit => code - code isnt ["COND",[p1,a1],[''T,a2]] => - m = $Void => code - code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => - wrapped2Quote objVal code' - throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) - a1:=IFcodeTran(a1,m,m1) - a2:=IFcodeTran(a2,m,m1) - ['COND,[p1,a1],[''T,a2]] - -interpIF(op,cond,a,b) == - -- non-compiled version of IF type analyzer. Doesn't resolve accross - -- branches of the IF. - val:= getValue cond - val:= coerceInteractive(val,$Boolean) => - objValUnwrap(val) => upIFgenValue(op,a) - EQ(b,"noBranch") => - putValue(op,objNew(voidValue(), $Void)) - putModeSet(op,[$Void]) - upIFgenValue(op,b) - throwKeyedMsg("S2IS0031",NIL) - -upIFgenValue(op,tree) == - -- evaluates tree and transfers the results to op - ms:=bottomUp tree - val:= getValue tree - putValue(op,val) - putModeSet(op,ms) - ---% Handlers for is - -upis t == - t isnt [op,a,pattern] => nil - $opIsIs : local := true - upisAndIsnt t - -upisnt t == - t isnt [op,a,pattern] => nil - $opIsIs : local := nil - upisAndIsnt t - -upisAndIsnt(t:=[op,a,pattern]) == - -- handler for "is" pattern matching - mS:= bottomUp a - mS isnt [m] => - keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) - putPvarModes(removeConstruct pattern,m) - evalis(op,rest t,m) - putModeSet(op,[$Boolean]) - -putPvarModes(pattern,m) == - -- Puts the modes for the pattern variables into $env - m isnt ["List",um] => throwKeyedMsg("S2IS0030",NIL) - for pvar in pattern repeat - IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) - pvar is ['_:,var] => - null (var=$quadSymbol) and put(var,"mode",m,$env) - pvar is ['_=,var] => - null (var=$quadSymbol) and put(var,"mode",um,$env) - putPvarModes(pvar,um) - -evalis(op,[a,pattern],mode) == - -- actually handles is and isnt - if $opIsIs - then fun := 'evalIsPredicate - else fun := 'evalIsntPredicate - if isLocalPred pattern then - code:= compileIs(a,pattern) - else code:=[fun,getArgValue(a,mode), - MKQ pattern,MKQ mode] - triple:= - $genValue => objNewWrap(timedEVALFUN code,$Boolean) - objNew(code,$Boolean) - putValue(op,triple) - -isLocalPred pattern == - -- returns true if the is predicate is to be compiled - for pat in pattern repeat - IDENTP pat and isLocalVar(pat) => return true - pat is [":",var] and isLocalVar(var) => return true - pat is ["=",var] and isLocalVar(var) => return true - -compileIs(val,pattern) == - -- produce code for compiled "is" predicate. makes pattern variables - -- into local variables of the function - vars:= NIL - for pat in CDR pattern repeat - IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars] - pat is [":",var] => vars:= [var,:vars] - pat is ["=",var] => vars:= [var,:vars] - predCode:=["LET",g:=GENSYM(),["isPatternMatch", - getArgValue(val,computedMode val),MKQ removeConstruct pattern]] - for var in REMDUP vars repeat - assignCode:=[["LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode] - null $opIsIs => - ["COND",[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,MKQ 'T]]] - ["COND",[["NOT",["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,MKQ 'T]]] - -evalIsPredicate(value,pattern,mode) == - --This function pattern matches value to pattern, and returns - --true if it matches, and false otherwise. As a side effect - --if the pattern matches then the bindings given in the pattern - --are made - pattern:= removeConstruct pattern - ^((valueAlist:=isPatternMatch(value,pattern))='failed) => - for [id,:value] in valueAlist repeat - evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) - true - false - -evalIsntPredicate(value,pattern,mode) == - evalIsPredicate(value,pattern,mode) => NIL - 'TRUE - -removeConstruct pat == - -- removes the "construct" from the beginning of patterns - if pat is ["construct",:p] then pat:=p - if pat is ["cons", a, b] then pat := [a, [":", b]] - atom pat => pat - RPLACA(pat,removeConstruct CAR pat) - RPLACD(pat,removeConstruct CDR pat) - pat - -isPatternMatch(l,pats) == - -- perform the actual pattern match - $subs: local := NIL - isPatMatch(l,pats) - $subs - -isPatMatch(l,pats) == - null pats => - null l => $subs - $subs:='failed - null l => - null pats => $subs - pats is [[":",var]] => - $subs := [[var],:$subs] - $subs:='failed - pats is [pat,:restPats] => - IDENTP pat => - $subs:=[[pat,:first l],:$subs] - isPatMatch(rest l,restPats) - pat is ["=",var] => - p:=ASSQ(var,$subs) => - CAR l = CDR p => isPatMatch(rest l, restPats) - $subs:="failed" - $subs:="failed" - pat is [":",var] => - n:=#restPats - m:=#l-n - m<0 => $subs:="failed" - ZEROP n => $subs:=[[var,:l],:$subs] - $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] - isPatMatch(DROP(m,l),restPats) - isPatMatch(first l,pat) = "failed" => "failed" - isPatMatch(rest l,restPats) - keyedSystemError("S2GE0016",['"isPatMatch", - '"unknown form of is predicate"]) - ---% Handler for iterate - -upiterate t == - null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) - $iterateCount := $iterateCount + 1 - code := ["THROW",$repeatBodyLabel,'(voidValue)] - $genValue => THROW(eval $repeatBodyLabel,voidValue()) - putValue(t,objNew(code,$Void)) - putModeSet(t,[$Void]) - ---% Handler for break - -upbreak t == - t isnt [op,.] => nil - null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) - $breakCount := $breakCount + 1 - code := ["THROW",$repeatLabel,'(voidValue)] - $genValue => THROW(eval $repeatLabel,voidValue()) - putValue(op,objNew(code,$Void)) - putModeSet(op,[$Void]) - ---% Handlers for LET - -upLET t == - -- analyzes and evaluates the righthand side, and does the variable - -- binding - t isnt [op,lhs,rhs] => nil - $declaredMode: local := NIL - PAIRP lhs => - var:= getUnname first lhs - var = "construct" => upLETWithPatternOnLhs t - var = "QUOTE" => throwKeyedMsg("S2IS0027",['"A quoted form"]) - upLETWithFormOnLhs(op,lhs,rhs) - var:= getUnname lhs - var = $immediateDataSymbol => - -- following will be immediate data, so probably ok to not - -- specially format it - obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) - throwKeyedMsg("S2IS0027",[obj]) - var in '(% %%) => -- for history - throwKeyedMsg("S2IS0027",[var]) - (IDENTP var) and not (var in '(true false elt QUOTE)) => - var ^= (var' := unabbrev(var)) => -- constructor abbreviation - throwKeyedMsg("S2IS0028",[var,var']) - if get(var,'isInterpreterFunction,$e) then - putHist(var,'isInterpreterFunction,false,$e) - sayKeyedMsg("S2IS0049",['"Function",var]) - else if get(var,'isInterpreterRule,$e) then - putHist(var,'isInterpreterRule,false,$e) - sayKeyedMsg("S2IS0049",['"Rule",var]) - not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m) - transferPropsToNode(var,lhs) - if ( m:= getMode(lhs) ) then - $declaredMode := m - putTarget(rhs,m) - if (val := getValue lhs) and (objMode val = $Boolean) and - getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) - (rhsMs:= bottomUp rhs) = [$Void] => - throwKeyedMsg("S2IS0034",[var]) - val:=evalLET(lhs,rhs) - putValue(op,val) - putModeSet(op,[objMode(val)]) - throwKeyedMsg("S2IS0027",[var]) - -isTupleForm f == - -- have to do following since "Tuple" is an internal form name - getUnname f ^= "Tuple" => false - f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" => - #args ^= 1 => true - isTupleForm first args => true - isType first args => false - true - false - -evalLET(lhs,rhs) == - -- lhs is a vector for a variable, and rhs is the evaluated atree - -- for the value which is coerced to the mode of lhs - $useConvertForCoercions: local := true - v' := (v:= getValue rhs) - ((not getMode lhs) and (getModeSet rhs is [.])) or - get(getUnname lhs,'autoDeclare,$env) => - v:= - $genValue => v - objNew(wrapped2Quote objVal v,objMode v) - evalLETput(lhs,v) - t1:= objMode v - t2' := (t2 := getMode lhs) - value:= - t1 = t2 => - $genValue => v - objNew(wrapped2Quote objVal v,objMode v) - if isPartialMode t2 then - if EQCAR(t1,'Symbol) and $declaredMode then - t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) - t' := t2 - null (t2 := resolveTM(t1,t2)) => - if not t2 then t2 := t' - throwKeyedMsg("S2IS0035",[t1,t2]) - null (v := getArgValue(rhs,t2)) => - isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => - throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) - throwKeyedMsg("S2IS0037",[t2]) - t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2) - value => evalLETput(lhs,value) - throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) - -evalLETput(lhs,value) == - -- put value into the cell for lhs - name:= getUnname lhs - if not $genValue then - code:= - isLocalVar(name) => - om := objMode(value) - dm := get(name,'mode,$env) - dm and not ((om = dm) or isSubDomain(om,dm) or - isSubDomain(dm,om)) => - compFailure ['" The type of the local variable", - :bright name,'"has changed in the computation."] - if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) - ['LET,name,objVal value,$mapName] - -- $mapName is set in analyzeMap - om := objMode value - dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) - dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => - THROW('loopCompiler,'tryInterpOnly) - ['unwrap,['evalLETchangeValue,MKQ name, - objNewCode(['wrap,objVal value],objMode value)]] - value:= objNew(code,objMode value) - isLocalVar(name) => - if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) - put(name,'mode,objMode(value),$env) - put(name,'automode,objMode(value),$env) - $genValue and evalLETchangeValue(name,value) - putValue(lhs,value) - -upLETWithPatternOnLhs(t := [op,pattern,a]) == - $opIsIs : local := true - [m] := bottomUp a - putPvarModes(pattern,m) - object := evalis(op,[a,pattern],m) - -- have to change code to return value of a - failCode := - ['spadThrowBrightly,['concat, - '" Pattern",['QUOTE,bright form2String pattern], - '"is not matched in assignment to right-hand side."]] - if $genValue - then - null objValUnwrap object => eval failCode - putValue(op,getValue a) - else - code := ['COND,[objVal object,objVal getValue a],[''T,failCode]] - putValue(op,objNew(code,m)) - putModeSet(op,[m]) - -evalLETchangeValue(name,value) == - -- write the value of name into the environment, clearing dependent - -- maps if its type changes from its last value - localEnv := PAIRP $env - clearCompilationsFlag := - val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) - null val => - not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) - objMode val ^= objMode(value) - if clearCompilationsFlag then - clearDependencies(name,true) - if localEnv and isLocalVar(name) - then $env:= putHist(name,'value,value,$env) - else putIntSymTab(name,'value,value,$e) - objVal value - -upLETWithFormOnLhs(op,lhs,rhs) == - -- bottomUp for assignment to forms (setelt, table or tuple) - lhs' := getUnnameIfCan lhs - rhs' := getUnnameIfCan rhs - lhs' = 'Tuple => - rhs' ^= 'Tuple => throwKeyedMsg("S2IS0039",NIL) - #(lhs) ^= #(rhs) => throwKeyedMsg("S2IS0038",NIL) - -- generate a sequence of assignments, using local variables - -- to first hold the assignments so that things like - -- (t1,t2) := (t2,t1) will work. - seq := [] - temps := [GENSYM() for l in rest lhs] - for lvar in temps repeat mkLocalVar($mapName,lvar) - for l in reverse rest lhs for t in temps repeat - transferPropsToNode(getUnname l,l) - let := mkAtreeNode 'LET - t' := mkAtreeNode t - if m := getMode(l) then putMode(t',m) - seq := cons([let,l,t'],seq) - for t in temps for r in reverse rest rhs - for l in reverse rest lhs repeat - let := mkAtreeNode 'LET - t' := mkAtreeNode t - if m := getMode(l) then putMode(t',m) - seq := cons([let,t',r],seq) - seq := cons(mkAtreeNode 'SEQ,seq) - ms := bottomUp seq - putValue(op,getValue seq) - putModeSet(op,ms) - rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL) - tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) - throwKeyedMsg("S2IS0060", NIL) --- upTableSetelt(op,lhs,rhs) - -seteltable(lhs is [f,:argl],rhs) == - -- produces the setelt form for trees such as "l.2:= 3" - null (g := getUnnameIfCan f) => NIL - EQ(g,"elt") => altSeteltable [:argl, rhs] - get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL - transferPropsToNode(g,f) - getValue(lhs) or getMode(lhs) => - f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs] - altSeteltable [:lhs,rhs] - NIL - -altSeteltable args == - for x in args repeat bottomUp x - newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"] - form := NIL - - -- first look for exact matches for any of the possibilities - while ^form for newOp in newOps repeat - if selectMms(newOp, args, NIL) then form := [newOp, :args] - - -- now try retracting arguments after the first - while ^form and ( "and"/[retractAtree(a) for a in rest args] ) repeat - while ^form for newOp in newOps repeat - if selectMms(newOp, args, NIL) then form := [newOp, :args] - - form - - -upSetelt(op,lhs,tree) == - -- type analyzes implicit setelt forms - var:=opOf lhs - transferPropsToNode(getUnname var,var) - if (m1:=getMode var) then $declaredMode:= m1 - if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then - putModeSet(var,[m1]) - ms := bottomUp tree - putValue(op,getValue tree) - putModeSet(op,ms) - -upTableSetelt(op,lhs is [htOp,:args],rhs) == - -- called only for undeclared, uninitialized table setelts - ("*" = (PNAME getUnname htOp).0) and (1 ^= # args) => - throwKeyedMsg("S2IS0040",NIL) - # args ^= 1 => - throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", - getUnname first args, - ['",",getUnname arg for arg in rest args],'"]"]]) - keyMode := '(Any) - putMode (htOp,['Table,keyMode,'(Any)]) - -- if we are to use a new table, we must call the "table" - -- function to give it an initial value. - bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]] - tableCode := objVal getValue htOp - r := upSetelt(op, lhs, [mkAtreeNode "setelt",:lhs,rhs]) - $genValue => r - -- construct code - t := getValue op - putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) - r - -unVectorize body == - -- transforms from an atree back into a tree - VECP body => - name := getUnname body - name ^= $immediateDataSymbol => name - objValUnwrap getValue body - atom body => body - body is [op,:argl] => - newOp:=unVectorize op - if newOp = 'SUCHTHAT then newOp := "|" - if newOp = 'COERCE then newOp := "::" - if newOp = 'Dollar then newOp := "$elt" - [newOp,:unVectorize argl] - systemErrorHere '"unVectorize" - -isType t == - -- Returns the evaluated type if t is a tree representing a type, - -- and NIL otherwise - op:=opOf t - VECP op => - isMap(op:= getUnname op) => NIL - op = 'Mapping => - argTypes := [isType type for type in rest t] - "or"/[null type for type in argTypes] => nil - ['Mapping, :argTypes] - isLocalVar(op) => NIL - d := isDomainValuedVariable op => d - type:= - -- next line handles subscripted vars - (abbreviation?(op) or (op = 'typeOf) or - constructor?(op) or (op in '(Record Union Enumeration))) and - unabbrev unVectorize t - type and evaluateType type - d := isDomainValuedVariable op => d - NIL - -upLETtype(op,lhs,type) == - -- performs type assignment - opName:= getUnname lhs - (not $genValue) and "or"/[CONTAINED(var,type) for var in $localVars] => - compFailure ['" Cannot compile type assignment to",:bright opName] - mode := - if isPartialMode type then '(Mode) - else if categoryForm?(type) then '(SubDomain (Domain)) - else '(Domain) - val:= objNew(type,mode) - if isLocalVar(opName) then put(opName,'value,val,$env) - else putHist(opName,'value,val,$e) - putValue(op,val) - -- have to fix the following - putModeSet(op,[mode]) - -assignSymbol(symbol, value, domain) == --- Special function for binding an interpreter variable from within algebra --- code. Does not do the assignment and returns nil, if the variable is --- already assigned - val := get(symbol, 'value, $e) => nil - obj := objNew(wrap value, devaluate domain) - put(symbol, 'value, obj, $e) - true - ---% Handler for Interpreter Macros - -getInterpMacroNames() == - names := [n for [n,:.] in $InterpreterMacroAlist] - if (e := CAAR $InteractiveFrame) and (m := assoc("--macros--",e)) then - names := append(names,[n for [n,:.] in CDR m]) - MSORT names - -isInterpMacro name == - -- look in local and then global environment for a macro - null IDENTP name => NIL - name in $specialOps => NIL - (m := get("--macros--",name,$env)) => m - (m := get("--macros--",name,$e)) => m - (m := get("--macros--",name,$InteractiveFrame)) => m - -- $InterpreterMacroAlist will probably be phased out soon - (sv := assoc(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv) - NIL - ---% Handlers for prefix QUOTE - -upQUOTE t == - t isnt [op,expr] => NIL - ms:= list - m:= getBasicMode expr => m - IDENTP expr => --- $useSymbolNotVariable => $Symbol - ['Variable,expr] - $OutputForm - evalQUOTE(op,[expr],ms) - putModeSet(op,ms) - -evalQUOTE(op,[expr],[m]) == - triple:= - $genValue => objNewWrap(expr,m) - objNew(['QUOTE,expr],m) - putValue(op,triple) - ---% Handler for pretend - -uppretend t == - t isnt [op,expr,type] => NIL - mode := evaluateType unabbrev type - not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) - bottomUp expr - putValue(op,objNew(objVal getValue expr,mode)) - putModeSet(op,[mode]) - ---% Handlers for REDUCE - -getReduceFunction(op,type,result, locale) == - -- return the function cell for operation with the signature - -- (type,type) -> type, possible from locale - if type is ['Variable,var] then - args := [arg := mkAtreeNode var,arg] - putValue(arg,objNewWrap(var,type)) - else - args := [arg := mkAtreeNode "%1",arg] - if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) - putModeSet(arg,[type]) - vecOp:=mkAtreeNode op - transferPropsToNode(op,vecOp) - if locale then putAtree(vecOp,'dollar,locale) - mmS:= selectMms(vecOp,args,result) - mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | - (isHomogeneousArgs sig) and "and"/[null c for c in cond]] - null mm => 'failed - [[dc,:sig],fun,:.]:=mm - dc='local => [MKQ [fun,:'local],:CAR sig] - dcVector := evalDomain dc - $compilingMap => - k := NRTgetMinivectorIndex( - NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) - ['ELT,"$$$",k] --$$$ denotes minivector - env:= - NRTcompiledLookup(op,sig,dcVector) - MKQ env - -isHomogeneous sig == - --return true if sig describes a homogeneous binary operation - sig.0=sig.1 and sig.1=sig.2 - -isHomogeneousArgs sig == - --return true if sig describes a homogeneous binary operation - sig.1=sig.2 - ---% Handlers for REPEAT - -transformREPEAT [:itrl,body] == - -- syntactic transformation of repeat iterators, called from mkAtree2 - iterList:=[:iterTran1 for it in itrl] where iterTran1() == - it is ["STEP",index,lower,step,:upperList] => - [["STEP",index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper - for upper in upperList]]] - it is ["IN",index,s] => - [['IN,index,mkAtree1 s]] - it is ["ON",index,s] => - [['IN,index,mkAtree1 ['tails,s]]] - it is ["WHILE",b] => - [["WHILE",mkAtree1 b]] - it is ["|",pred] => - [["SUCHTHAT",mkAtree1 pred]] - it is [op,:.] and (op in '(VALUE UNTIL)) => nil - bodyTree:=mkAtree1 body - iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2() == - it is ["STEP",:.] => nil - it is ["IN",:.] => nil - it is ["ON",:.] => nil - it is ["WHILE",:.] => nil - it is [op,b] and (op in '(UNTIL VALUE)) => - [[op,mkAtree1 b]] - it is ['_|,pred] => nil - keyedSystemError("S2GE0016", - ['"transformREPEAT",'"Unknown type of iterator"]) - [:iterList,bodyTree] - -upREPEAT t == - -- REPEATS always return void() of Void - -- assures throw to interpret-code mode goes to outermost loop - $repeatLabel : local := MKQ GENSYM() - $breakCount : local := 0 - $repeatBodyLabel : local := MKQ GENSYM() - $iterateCount : local := 0 - $compilingLoop => upREPEAT1 t - upREPEAT0 t - -upREPEAT0 t == - -- sets up catch point for interp-only mode - $compilingLoop: local := true - ms := CATCH('loopCompiler,upREPEAT1 t) - ms = 'tryInterpOnly => interpOnlyREPEAT t - ms - -upREPEAT1 t == - -- repeat loop handler with compiled body - -- see if it has the expected form - t isnt [op,:itrl,body] => NIL - -- determine the mode of the repeat loop. At the moment, if there - -- there are no iterators and there are no "break" statements, then - -- the return type is Exit, otherwise Void. - repeatMode := - null(itrl) and ($breakCount=0) => $Void - $Void - - -- if interpreting, go do that - $interpOnly => interpREPEAT(op,itrl,body,repeatMode) - - -- analyze iterators and loop body - upLoopIters itrl - bottomUpCompile body - - -- now that the body is analyzed, we should know everything that - -- is in the UNTIL clause - for itr in itrl repeat - itr is ["UNTIL", pred] => bottomUpCompilePredicate(pred,'"until") - - -- now go do it - evalREPEAT(op,rest t,repeatMode) - putModeSet(op,[repeatMode]) - -evalREPEAT(op,[:itrl,body],repeatMode) == - -- generate code for loop - bodyMode := computedMode body - bodyCode := getArgValue(body,bodyMode) - if $iterateCount > 0 then - bodyCode := ["CATCH",$repeatBodyLabel,bodyCode] - code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode] - if repeatMode = $Void then code := ['OR,code,'(voidValue)] - code := timedOptimization code - if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] - val:= - $genValue => - timedEVALFUN code - objNewWrap(voidValue(),repeatMode) - objNew(code,repeatMode) - putValue(op,val) - -interpOnlyREPEAT t == - -- interpret-code mode call to upREPEAT - $genValue: local := true - $interpOnly: local := true - upREPEAT1 t - -interpREPEAT(op,itrl,body,repeatMode) == - -- performs interpret-code repeat - $indexVars: local := NIL - $indexTypes: local := NIL - code := - -- we must insert a CATCH for the iterate clause - ["REPEAT",:[interpIter itr for itr in itrl], - ["CATCH",$repeatBodyLabel,interpLoop(body,$indexVars, - $indexTypes,nil)]] - SPADCATCH(eval $repeatLabel,timedEVALFUN code) - val:= objNewWrap(voidValue(),repeatMode) - putValue(op,val) - putModeSet(op,[repeatMode]) - -interpLoop(expr,indexList,indexTypes,requiredType) == - -- generates code for interp-only repeat body - ['interpLoopIter,MKQ expr,MKQ indexList,["LIST",:indexList], - MKQ indexTypes, MKQ requiredType] - -interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == - -- call interpreter on exp with loop vars in indexList with given - -- values and types, requiredType is used from interpCOLLECT - -- to indicate the required type of the result - emptyAtree exp - for i in indexList for val in indexVals for type in indexTypes repeat - put(i,'value,objNewWrap(val,type),$env) - bottomUp exp - v:= getValue exp - val := - null requiredType => v - coerceInteractive(v,requiredType) - null val => - throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) - objValUnwrap val - ---% Handler for return - -upreturn t == - -- make sure we are in a user function - t isnt [op,val] => NIL - (null $compilingMap) and (null $interpOnly) => - throwKeyedMsg("S2IS0047",NIL) - if $mapTarget then putTarget(val,$mapTarget) - bottomUp val - if $mapTarget - then - val' := getArgValue(val, $mapTarget) - m := $mapTarget - else - val' := wrapped2Quote objVal getValue val - m := computedMode val - cn := mapCatchName $mapName - $mapReturnTypes := insert(m, $mapReturnTypes) - $mapThrowCount := $mapThrowCount + 1 - -- if $genValue then we are interpreting the map - $genValue => THROW(cn,objNewWrap(removeQuote val',m)) - putValue(op,objNew(['THROW,MKQ cn,val'],m)) - putModeSet(op,[$Exit]) - ---% Handler for SEQ - -upSEQ u == - -- assumes that exits were translated into if-then-elses - -- handles flat SEQs and embedded returns - u isnt [op,:args] => NIL - if (target := getTarget(op)) then putTarget(last args, target) - for x in args repeat bottomUp x - null (m := computedMode last args) => - keyedSystemError("S2GE0016",['"upSEQ", - '"last line of SEQ has no mode"]) - evalSEQ(op,args,m) - putModeSet(op,[m]) - -evalSEQ(op,args,m) == - -- generate code for SEQ - [:argl,last] := args - val:= - $genValue => getValue last - bodyCode := nil - for x in args repeat - (m1 := computedMode x) and (m1 ^= '$ThrowAwayMode) => - (av := getArgValue(x,m1)) ^= voidValue() => - bodyCode := [av,:bodyCode] - code:= - bodyCode is [c] => c - ['PROGN,:reverse bodyCode] - objNew(code,m) - putValue(op,val) - ---% Handlers for Tuple - -upTuple t == - --Computes the common mode set of the construct by resolving across - --the argument list, and evaluating - t isnt [op,:l] => nil - dol := getAtree(op,'dollar) - tar := getTarget(op) or dol - null l => upNullTuple(op,l,tar) - isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) - aggs := '(List) - if tar and PAIRP(tar) and ^isPartialMode(tar) then - CAR(tar) in aggs => - ud := CADR tar - for x in l repeat if not getTarget(x) then putTarget(x,ud) - CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => - vec := ['List,underDomainOf tar] - for x in l repeat if not getTarget(x) then putTarget(x,vec) - argModeSetList:= [bottomUp x for x in l] - eltTypes := replaceSymbols([first x for x in argModeSetList],l) - if not isPartialMode(tar) and tar is ['Tuple,ud] then - mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)] - else mode := ['Tuple, resolveTypeListAny eltTypes] - if isPartialMode tar then tar:=resolveTM(mode,tar) - evalTuple(op,l,mode,tar) - -evalTuple(op,l,m,tar) == - [agg,:.,underMode]:= m - code := asTupleNewCode(#l, - [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - if tar then val1 := coerceInteractive(val,tar) else val1 := val - - val1 => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -upNullTuple(op,l,tar) == - -- handler for the empty tuple - defMode := - tar and tar is [a,b] and (a in '(Stream Vector List)) and - not isPartialMode(b) => ['Tuple,b] - '(Tuple (None)) - val := objNewWrap(asTupleNew(0,NIL), defMode) - tar and not isPartialMode(tar) => - null (val' := coerceInteractive(val,tar)) => - throwKeyedMsg("S2IS0013",[tar]) - putValue(op,val') - putModeSet(op,[tar]) - putValue(op,val) - putModeSet(op,[defMode]) - ---% Handler for typeOf - -uptypeOf form == - form isnt [op, arg] => NIL - if VECP arg then transferPropsToNode(getUnname arg,arg) - if m := isType(arg) then - m := - categoryForm?(m) => '(SubDomain (Domain)) - isPartialMode m => '(Mode) - '(Domain) - else if not (m := getMode arg) then [m] := bottomUp arg - t := typeOfType m - putValue(op, objNew(m,t)) - putModeSet(op,[t]) - -typeOfType type == - type in '((Mode) (Domain)) => '(SubDomain (Domain)) - '(Domain) - ---% Handler for where - -upwhere t == - -- upwhere does the puts in where into a local environment - t isnt [op,tree,clause] => NIL - -- since the "clause" might be a local macro, we now call mkAtree - -- on the "tree" part (it is not yet a vat) - not $genValue => - compFailure [:bright '" where", - '"for compiled code is not yet implemented."] - $whereCacheList : local := nil - [env,:e] := upwhereClause(clause,$env,$e) - tree := upwhereMkAtree(tree,env,e) - if x := getAtree(op,'dollar) then - atom tree => throwKeyedMsg("S2IS0048",NIL) - putAtree(CAR tree,'dollar,x) - upwhereMain(tree,env,e) - val := getValue tree - putValue(op,val) - result := putModeSet(op,getModeSet tree) - wcl := [op for op in $whereCacheList] - for op in wcl repeat clearDependencies(op,'T) - result - -upwhereClause(tree,env,e) == - -- uses the variable bindings from env and e and returns an environment - -- of its own bindings - $env: local := copyHack env - $e: local := copyHack e - bottomUp tree - [$env,:$e] - -upwhereMkAtree(tree,$env,$e) == mkAtree tree - -upwhereMain(tree,$env,$e) == - -- uses local copies of $env and $e while evaluating tree - bottomUp tree - -copyHack(env) == - -- makes a copy of an environment with the exception of pairs - -- (localModemap . something) - c:= CAAR env - d:= [fn p for p in c] where fn(p) == - CONS(CAR p,[(EQCAR(q,'localModemap) => q; copy q) for q in CDR p]) - [[d]] - --- Creates the function names of the special function handlers and puts --- them on the property list of the function name - -for name in $specialOps repeat - functionName:=INTERNL('up,name) - MAKEPROP(name,'up,functionName) - CREATE_-SBC functionName - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot new file mode 100644 index 00000000..6c91b725 --- /dev/null +++ b/src/interp/i-syscmd.boot @@ -0,0 +1,3131 @@ +-- 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. + + +import '"i-object" +)package "BOOT" + +--% Utility Variable Initializations + +$cacheAlist := nil +$compileRecurrence := true +$errorReportLevel := 'warning +$sourceFileTypes := '(INPUT SPAD BOOT LISP LISP370 META) + +$SYSCOMMANDS := [CAR x for x in $systemCommands] + +UNDERBAR == '"__" + + +$whatOptions := '( _ + operations _ + categories _ + domains _ + packages _ + commands _ + synonyms _ + things _ + ) + +$clearOptions := '( _ + modes _ + operations _ + properties _ + types _ + values _ + ) + +$displayOptions := '( _ + abbreviations _ + all _ + macros _ + modes _ + names _ + operations _ + properties _ + types _ + values _ + ) + +$countAssoc := '( (cache countCache) ) + +--% Top level system command + +initializeSystemCommands() == + l := $systemCommands + $SYSCOMMANDS := NIL + while l repeat + $SYSCOMMANDS := CONS(CAAR l, $SYSCOMMANDS) + l := CDR l + $SYSCOMMANDS := NREVERSE $SYSCOMMANDS + +systemCommand [[op,:argl],:options] == + $options: local:= options + $e:local := $CategoryFrame + fun := selectOptionLC(op,$SYSCOMMANDS,'commandError) + argl and (argl.0 = '_?) and fun ^= 'synonym => + helpSpad2Cmd [fun] + fun := selectOption(fun,commandsForUserLevel $systemCommands, + 'commandUserLevelError) + FUNCALL(fun, argl) + +commandsForUserLevel l == --[a for [a,:b] in l | satisfiesUserLevel(a)] + c := nil + for [a,:b] in l repeat + satisfiesUserLevel b => c := [a,:c] + reverse c + +synonymsForUserLevel l == + -- l is a list of synonyms, and this returns a sublist of applicable + -- synonyms at the current user level. + $UserLevel = 'development => l + nl := NIL + for syn in reverse l repeat + cmd := STRING2ID_-N(CDR syn,1) + null selectOptionLC(cmd,commandsForUserLevel + $systemCommands,NIL) => nil + nl := [syn,:nl] + nl + +satisfiesUserLevel x == + x = 'interpreter => true + $UserLevel = 'interpreter => false + x = 'compiler => true + $UserLevel = 'compiler => false + true + +unAbbreviateKeyword x == + x' :=selectOptionLC(x,$SYSCOMMANDS,'commandErrorIfAmbiguous) + if not x' then + x' := 'system + SETQ(LINE, CONCAT('")system ", SUBSTRING(LINE, 1, #LINE-1))) + $currentLine := LINE + selectOption(x',commandsForUserLevel $systemCommands, + 'commandUserLevelError) + +hasOption(al,opt) == + optPname:= PNAME opt + found := NIL + for pair in al while not found repeat + stringPrefix?(PNAME CAR pair,optPname) => found := pair + found + +selectOptionLC(x,l,errorFunction) == + selectOption(DOWNCASE object2Identifier x,l,errorFunction) + +selectOption(x,l,errorFunction) == + member(x,l) => x --exact spellings are always OK + null IDENTP x => + errorFunction => FUNCALL(errorFunction,x,u) + nil + u := [y for y in l | stringPrefix?(PNAME x,PNAME y)] + u is [y] => y + errorFunction => FUNCALL(errorFunction,x,u) + nil + +terminateSystemCommand() == TERSYSCOMMAND() + +commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u) + +optionUserLevelError(x,u) == userLevelErrorMessage("option",x,u) + +userLevelErrorMessage(kind,x,u) == + null u => + sayKeyedMsg("S2IZ0007",[$UserLevel,kind]) + terminateSystemCommand() + commandAmbiguityError(kind,x,u) + +commandError(x,u) == commandErrorMessage("command",x,u) + +optionError(x,u) == commandErrorMessage("option",x,u) + +commandErrorIfAmbiguous(x, u) == + null u => nil + SETQ($OLDLINE, LINE) + commandAmbiguityError("command", x, u) + +commandErrorMessage(kind,x,u) == + SETQ ($OLDLINE,LINE) + null u => + sayKeyedMsg("S2IZ0008",[kind,x]) + terminateSystemCommand() + commandAmbiguityError(kind,x,u) + +commandAmbiguityError(kind,x,u) == + sayKeyedMsg("S2IZ0009",[kind,x]) + for a in u repeat sayMSG ['" ",:bright a] + terminateSystemCommand() + +--% Utility for access to original command line + +getSystemCommandLine() == + p := STRPOS('")",$currentLine,0,NIL) + line := if p then SUBSTRING($currentLine,p,NIL) else $currentLine + maxIndex:= MAXINDEX line + for i in 0..maxIndex while (line.i^=" ") repeat index:= i + if index=maxIndex then line := '"" + else line := SUBSTRING(line,index+2,nil) + line + +------------ start of commands ------------------------------------------ + +--% )abbreviations + +abbreviations l == abbreviationsSpad2Cmd l + +abbreviationsSpad2Cmd l == + null l => helpSpad2Cmd '(abbreviations) + abopts := '(query domain category package remove) + + quiet := nil + for [opt] in $options repeat + opt := selectOptionLC(opt,'(quiet),'optionError) + opt = 'quiet => quiet := true + + l is [opt,:al] => + key := opOf CAR al + type := selectOptionLC(opt,abopts,'optionError) + type is 'query => + null al => listConstructorAbbreviations() + constructor := abbreviation?(key) => abbQuery(constructor) + abbQuery(key) + type is 'remove => + DELDATABASE(key,'ABBREVIATION) + ODDP SIZE al => sayKeyedMsg("S2IZ0002",[type]) + repeat + null al => return 'fromLoop + [a,b,:al] := al + mkUserConstructorAbbreviation(b,a,type) + SETDATABASE(b,'ABBREVIATION,a) + SETDATABASE(b,'CONSTRUCTORKIND,type) + null quiet => + sayKeyedMsg("S2IZ0001",[a,type,opOf b]) + nil + nil + +listConstructorAbbreviations() == + x := UPCASE queryUserKeyedMsg("S2IZ0056",NIL) + MEMQ(STRING2ID_-N(x,1),'(Y YES)) => + whatSpad2Cmd '(categories) + whatSpad2Cmd '(domains) + whatSpad2Cmd '(packages) + sayKeyedMsg("S2IZ0057",NIL) + +--% )clear + +clear l == clearSpad2Cmd l + +clearSpad2Cmd l == + -- new version which changes the environment and updates history + $clearExcept: local := nil + if $options then $clearExcept := + "and"/[selectOptionLC(opt,'(except),'optionError) = + 'except for [opt,:.] in $options] + null l => + optList:= "append"/[['%l,'" ",x] for x in $clearOptions] + sayKeyedMsg("S2IZ0010",[optList]) + arg := selectOptionLC(first l,'(all completely scaches),NIL) + arg = 'all => clearCmdAll() + arg = 'completely => clearCmdCompletely() + arg = 'scaches => clearCmdSortedCaches() + $clearExcept => clearCmdExcept(l) + clearCmdParts(l) + updateCurrentInterpreterFrame() + +clearCmdSortedCaches() == + $lookupDefaults: local := false + for [.,.,:domain] in HGET($ConstructorCache,'SortedCache) repeat + pair := compiledLookupCheck('clearCache,[$Void],domain) + SPADCALL pair + +clearCmdCompletely() == + clearCmdAll() + $localExposureData := COPY_-SEQ $localExposureDataDefault + $xdatabase := NIL + $CatOfCatDatabase := NIL + $DomOfCatDatabase := NIL + $JoinOfCatDatabase := NIL + $JoinOfDomDatabase := NIL + $attributeDb := NIL + $functionTable := NIL + sayKeyedMsg("S2IZ0013",NIL) + clearClams() + clearConstructorCaches() + $existingFiles := MAKE_-HASHTABLE 'UEQUAL + sayKeyedMsg("S2IZ0014",NIL) + RECLAIM() + sayKeyedMsg("S2IZ0015",NIL) + NIL + +clearCmdAll() == + clearCmdSortedCaches() + ------undo special variables------ + $frameRecord := nil + $previousBindings := nil + $variableNumberAlist := nil + untraceMapSubNames _/TRACENAMES + $InteractiveFrame := LIST LIST NIL + resetInCoreHist() + if $useInternalHistoryTable + then $internalHistoryTable := NIL + else deleteFile histFileName() + $IOindex := 1 + updateCurrentInterpreterFrame() + $currentLine := '")clear all" --restored 3/94; needed for undo (RDJ) + clearMacroTable() + if $frameMessages then sayKeyedMsg("S2IZ0011",[$interpreterFrameName]) + else sayKeyedMsg("S2IZ0012",NIL) + +clearCmdExcept(l is [opt,:vl]) == + --clears elements of vl of all options EXCEPT opt + for option in $clearOptions | + ^stringPrefix?(object2String opt,object2String option) + repeat clearCmdParts [option,:vl] + +clearCmdParts(l is [opt,:vl]) == + -- clears the bindings indicated by opt of all variables in vl + + option:= selectOptionLC(opt,$clearOptions,'optionError) + option:= INTERN PNAME option + + -- the option can be plural but the key in the alist is sometimes + -- singular + + option := + option = 'types => 'mode + option = 'modes => 'mode + option = 'values => 'value + option + + null vl => sayKeyedMsg("S2IZ0055",NIL) + pmacs := getParserMacroNames() + imacs := getInterpMacroNames() + if vl='(all) then + vl := ASSOCLEFT CAAR $InteractiveFrame + vl := REMDUP(append(vl, pmacs)) + $e : local := $InteractiveFrame + for x in vl repeat + clearDependencies(x,true) + if option='properties and x in pmacs then clearParserMacro(x) + if option='properties and x in imacs and ^(x in pmacs) then + sayMessage ['" You cannot clear the definition of the system-defined macro ", + fixObjectForPrinting x,"."] + p1 := assoc(x,CAAR $InteractiveFrame) => + option='properties => + if isMap x then + (lm := get(x,'localModemap,$InteractiveFrame)) => + PAIRP lm => untraceMapSubNames [CADAR lm] + NIL + for p2 in CDR p1 repeat + prop:= CAR p2 + recordOldValue(x,prop,CDR p2) + recordNewValue(x,prop,NIL) + SETF(CAAR $InteractiveFrame,deleteAssoc(x,CAAR $InteractiveFrame)) + p2:= assoc(option,CDR p1) => + recordOldValue(x,option,CDR p2) + recordNewValue(x,option,NIL) + RPLACD(p2,NIL) + nil + +--% )close + +queryClients () == + -- Returns the number of active scratchpad clients + sockSendInt($SessionManager, $QueryClients) + sockGetInt $SessionManager + + +close args == + $saturn => + sayErrorly('"Obsolete system command", _ + ['" The )close system command is obsolete in this version of AXIOM.", + '" Please use Close from the File menu instead."]) + quiet:local:= false + null $SpadServer => + throwKeyedMsg('"S2IZ0071", []) + numClients := queryClients() + numClients > 1 => + sockSendInt($SessionManager, $CloseClient) + sockSendInt($SessionManager, $currentFrameNum) + closeInterpreterFrame(NIL) + for [opt,:.] in $options repeat + fullopt := selectOptionLC(opt, '(quiet), 'optionError) + fullopt = 'quiet => + quiet:=true + quiet => + sockSendInt($SessionManager, $CloseClient) + sockSendInt($SessionManager, $currentFrameNum) + closeInterpreterFrame(NIL) + x := UPCASE queryUserKeyedMsg('"S2IZ0072", nil) + MEMQ(STRING2ID_-N(x,1), '(YES Y)) => + BYE() + nil + +--% )constructor + +constructor args == + sayMessage '" Not implemented yet." + NIL + +--% )compiler + +compiler args == + $newConlist: local := nil --reset by compDefineLisplib and astran + null args and null $options and null _/EDITFILE => helpSpad2Cmd '(compiler) + if null args then args := [_/EDITFILE] + + -- first see if the user has explicitly specified the compiler + -- to use. + + optlist := '(new old translate constructor) + haveNew := nil + haveOld := nil + for opt in $options while ^(haveNew and haveOld) repeat + [optname,:optargs] := opt + fullopt := selectOptionLC(optname,optlist,nil) + fullopt = 'new => haveNew := true + fullopt = 'translate => haveOld := true + fullopt = 'constructor => haveOld := true + fullopt = 'old => haveOld := true + + haveNew and haveOld => throwKeyedMsg("S2IZ0081", nil) + + af := pathname args + aft := pathnameType af +-- Whats this for? MCD/PAB 21-9-95 +-- if haveNew and (null(aft) or (aft = '"")) then +-- af := pathname [af, '"as"] +-- aft = '"as" +-- if haveOld and (null(aft) or (aft = '"")) then +-- af := pathname [af, '"spad"] +-- aft = '"spad" + + haveNew or (aft = '"as") => + not (af1 := $FINDFILE (af, '(as))) => + throwKeyedMsg("S2IL0003",[NAMESTRING af]) + compileAsharpCmd [af1] + haveOld or (aft = '"spad") => + not (af1 := $FINDFILE (af, '(spad))) => + throwKeyedMsg("S2IL0003",[NAMESTRING af]) + compileSpad2Cmd [af1] + aft = '"lsp" => + not (af1 := $FINDFILE (af, '(lsp))) => + throwKeyedMsg("S2IL0003",[NAMESTRING af]) + compileAsharpLispCmd [af1] + aft = '"NRLIB" => + not (af1 := $FINDFILE (af, '(NRLIB))) => + throwKeyedMsg("S2IL0003",[NAMESTRING af]) + compileSpadLispCmd [af1] + aft = '"ao" => + not (af1 := $FINDFILE (af, '(ao))) => + throwKeyedMsg("S2IL0003",[NAMESTRING af]) + compileAsharpCmd [af1] + aft = '"al" => -- archive library of .ao files + not (af1 := $FINDFILE (af, '(al))) => + throwKeyedMsg("S2IL0003",[NAMESTRING af]) + compileAsharpArchiveCmd [af1] + + -- see if we something with the appropriate file extension + -- lying around + + af1 := $FINDFILE (af, '(as spad ao asy)) + + af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] + af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] + af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] + af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] + + -- maybe /EDITFILE has some stuff that can help us + ef := pathname _/EDITFILE + ef := mergePathnames(af,ef) + + ef = af => throwKeyedMsg("S2IZ0039", nil) + af := ef + + pathnameType(af) = '"as" => compileAsharpCmd args + pathnameType(af) = '"ao" => compileAsharpCmd args + pathnameType(af) = '"spad" => compileSpad2Cmd args + + -- see if we something with the appropriate file extension + -- lying around + af1 := $FINDFILE (af, '(as spad ao asy)) + + af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] + af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] + af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] + af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] + + throwKeyedMsg("S2IZ0039", nil) + +compileAsharpCmd args == + compileAsharpCmd1 args + terminateSystemCommand() + spadPrompt() + +compileAsharpCmd1 args == + -- Assume we entered from the "compiler" function, so args ^= nil + -- and is a file with file extension .as or .ao + + path := pathname args + pathType := pathnameType path + (pathType ^= '"as") and (pathType ^= '"ao") => throwKeyedMsg("S2IZ0083", nil) + ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) + + SETQ(_/EDITFILE, path) + updateSourceFiles path + + optList := '( _ + new _ + old _ + translate _ + onlyargs _ + moreargs _ + quiet _ + nolispcompile _ + noquiet _ + library _ + nolibrary _ + ) + + beQuiet := false -- be verbose here + doLibrary := true -- so a )library after compilation + doCompileLisp := true -- do compile generated lisp code + + moreArgs := NIL + onlyArgs := NIL + + for opt in $options repeat + [optname,:optargs] := opt + fullopt := selectOptionLC(optname,optList,nil) + + fullopt = 'new => nil + fullopt = 'old => error "Internal error: compileAsharpCmd got )old" + fullopt = 'translate => error "Internal error: compileAsharpCmd got )translate" + + fullopt = 'quiet => beQuiet := true + fullopt = 'noquiet => beQuiet := false + + fullopt = 'nolispcompile => doCompileLisp := false + + fullopt = 'moreargs => moreArgs := optargs + fullopt = 'onlyargs => onlyArgs := optargs + + fullopt = 'library => doLibrary := true + fullopt = 'nolibrary => doLibrary := false + + throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) + + tempArgs := + pathType = '"ao" => + -- want to strip out -Fao + (p := STRPOS('"-Fao", $asharpCmdlineFlags, 0, NIL)) => + p = 0 => SUBSTRING($asharpCmdlineFlags, 5, NIL) + STRCONC(SUBSTRING($asharpCmdlineFlags, 0, p), '" ", + SUBSTRING($asharpCmdlineFlags, p+5, NIL)) + $asharpCmdlineFlags + $asharpCmdlineFlags + + asharpArgs := + onlyArgs => + s := "" + for a in onlyArgs repeat + s := STRCONC(s, '" ", object2String a) + s + moreArgs => + s := tempArgs + for a in moreArgs repeat + s := STRCONC(s, '" ", object2String a) + s + tempArgs + + if ^beQuiet then sayKeyedMsg("S2IZ0038A",[namestring args, asharpArgs]) + + command := + STRCONC(STRCONC(GETENV('"ALDORROOT"),'"/bin/"),_ + "aldor ", asharpArgs, '" ", namestring args) + rc := OBEY command + + if (rc = 0) and doCompileLisp then + lsp := fnameMake('".", pathnameName args, '"lsp") + if fnameReadable?(lsp) then + if ^beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) + compileFileQuietly(lsp) + else + sayKeyedMsg("S2IL0003", [namestring lsp]) + + if rc = 0 and doLibrary then + -- do we need to worry about where the compilation output went? + if ^beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) + withAsharpCmd [ pathnameName path ] + else if ^beQuiet then + sayKeyedMsg("S2IZ0084", nil) + + extendLocalLibdb $newConlist + +compileAsharpArchiveCmd args == + -- Assume we entered from the "compiler" function, so args ^= nil + -- and is a file with file extension .al. We also assume that + -- the name is fully qualified. + + path := pathname args + ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) + + -- here is the plan: + -- 1. extract the file name and try to make a directory based + -- on that name. + -- 2. cd to that directory and ar x the .al file + -- 3. for each .ao file that shows up, compile it + -- 4. delete the generated .ao files + + -- First try to make the directory in the current directory + + dir := fnameMake('".", pathnameName path, '"axldir") + exists := PROBE_-FILE dir + isDir := directoryp namestring dir + exists and isDir ^= 1=> + throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) + + if isDir ^= 1 then + cmd := STRCONC('"mkdir ", namestring dir) + rc := OBEY cmd + rc ^= 0 => throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) + + curDir := $CURRENT_-DIRECTORY + + -- cd to that directory and try to unarchive the .al file + + cd [ object2Identifier namestring dir ] + + cmd := STRCONC( '"ar x ", namestring path ) + rc := OBEY cmd + rc ^= 0 => + cd [ object2Identifier namestring curDir ] + throwKeyedMsg("S2IL0028",[namestring dir, namestring args]) + + -- Look for .ao files + + asos := DIRECTORY '"*.ao" + null asos => + cd [ object2Identifier namestring curDir ] + throwKeyedMsg("S2IL0029",[namestring dir, namestring args]) + + -- Compile the .ao files + + for aso in asos repeat + compileAsharpCmd1 [ namestring aso ] + + -- Reset the current directory + + cd [ object2Identifier namestring curDir ] + + terminateSystemCommand() + spadPrompt() + +compileAsharpLispCmd args == + -- Assume we entered from the "compiler" function, so args ^= nil + -- and is a file with file extension .lsp + + path := pathname args + ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) + + optList := '( _ + quiet _ + noquiet _ + library _ + nolibrary _ + ) + + beQuiet := false -- be verbose here + doLibrary := true -- so a )library after compilation + + for opt in $options repeat + [optname,:optargs] := opt + fullopt := selectOptionLC(optname,optList,nil) + + fullopt = 'quiet => beQuiet := true + fullopt = 'noquiet => beQuiet := false + + fullopt = 'library => doLibrary := true + fullopt = 'nolibrary => doLibrary := false + + throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) + + lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) + if fnameReadable?(lsp) then + if ^beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) + compileFileQuietly(lsp) + else + sayKeyedMsg("S2IL0003", [namestring lsp]) + + if doLibrary then + -- do we need to worry about where the compilation output went? + if ^beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) + withAsharpCmd [ pathnameName path ] + else if ^beQuiet then + sayKeyedMsg("S2IZ0084", nil) + terminateSystemCommand() + spadPrompt() + +compileSpadLispCmd args == + -- Assume we entered from the "compiler" function, so args ^= nil + -- and is a file with file extension .NRLIB + + path := pathname fnameMake(first args, '"code", '"lsp") + ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) + + optList := '( _ + quiet _ + noquiet _ + library _ + nolibrary _ + ) + + beQuiet := false -- be verbose here + doLibrary := true -- so a )library after compilation + + for opt in $options repeat + [optname,:optargs] := opt + fullopt := selectOptionLC(optname,optList,nil) + + fullopt = 'quiet => beQuiet := true + fullopt = 'noquiet => beQuiet := false + + fullopt = 'library => doLibrary := true + fullopt = 'nolibrary => doLibrary := false + + throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) + + lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) + if fnameReadable?(lsp) then + if ^beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) + --compileFileQuietly(lsp) + RECOMPILE_-LIB_-FILE_-IF_-NECESSARY lsp + else + sayKeyedMsg("S2IL0003", [namestring lsp]) + + if doLibrary then + -- do we need to worry about where the compilation output went? + if ^beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) + LOCALDATABASE([ pathnameName first args ],[]) + else if ^beQuiet then + sayKeyedMsg("S2IZ0084", nil) + terminateSystemCommand() + spadPrompt() + +withAsharpCmd args == + $options: local := nil + LOCALDATABASE(args, $options) + +--% )copyright -- display copyright notice + +summary l == + OBEY STRCONC ('"cat ", systemRootDirectory(),'"/lib/summary") + +copyright () == + OBEY STRCONC ('"cat ", systemRootDirectory(),'"/lib/copyright") + +--% )credits -- display credit list + +CREDITS := '( + "An alphabetical listing of contributors to AXIOM (to October, 2006):" + "Cyril Alberga Roy Adler Christian Aistleitner" + "Richard Anderson George Andrews" + "Henry Baker Stephen Balzac Yurij Baransky" + "David R. Barton Gerald Baumgartner Gilbert Baumslag" + "Fred Blair Vladimir Bondarenko Mark Botch" + "Alexandre Bouyer Peter A. Broadbery Martin Brock" + "Manuel Bronstein Florian Bundschuh Luanne Burns" + "William Burge" + "Quentin Carpent Robert Caviness Bruce Char" + "Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" + "Josh Cohen Christophe Conil Don Coppersmith" + "George Corliss Robert Corless Gary Cornell" + "Meino Cramer Claire Di Crescenzo" + "Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" + "Jean Della Dora Gabriel Dos Reis Michael Dewar" + "Claire DiCrescendo Sam Dooley Lionel Ducos" + "Martin Dunstan Brian Dupee Dominique Duval" + "Robert Edwards Heow Eide-Goodman Lars Erickson" + "Richard Fateman Bertfried Fauser Stuart Feldman" + "Brian Ford Albrecht Fortenbacher George Frances" + "Constantine Frangos Timothy Freeman Korrinn Fu" + "Marc Gaetano Rudiger Gebauer Kathy Gerber" + "Patricia Gianni Holger Gollan Teresa Gomez-Diaz" + "Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" + "Matt Grayson James Griesmer Vladimir Grinberg" + "Oswald Gschnitzer Jocelyn Guidry" + "Steve Hague Vilya Harvey Satoshi Hamaguchi" + "Martin Hassner Waldek Hebisch Ralf Hemmecke" + "Henderson Antoine Hersen" + "Pietro Iglio" + "Richard Jenks" + "Kai Kaminski Grant Keady Tony Kennedy" + "Paul Kosinski Klaus Kusche Bernhard Kutzler" + "Larry Lambe Frederic Lehobey Michel Levaud" + "Howard Levy Rudiger Loos Michael Lucks" + "Richard Luczak" + "Camm Maguire Bob McElrath Michael McGettrick" + "Ian Meikle David Mentre Victor S. Miller" + "Gerard Milmeister Mohammed Mobarak H. Michael Moeller" + "Michael Monagan Marc Moreno-Maza Scott Morrison" + "Mark Murray" + "William Naylor C. Andrew Neff John Nelder" + "Godfrey Nolan Arthur Norman Jinzhong Niu" + "Michael O'Connor Kostas Oikonomou" + "Julian A. Padget Bill Page Susan Pelzel" + "Michel Petitot Didier Pinchon Jose Alfredo Portes" + "Claude Quitte" + "Norman Ramsey Michael Richardson Renaud Rioboo" + "Jean Rivlin Nicolas Robidoux Simon Robinson" + "Michael Rothstein Martin Rubey" + "Philip Santas Alfred Scheerhorn William Schelter" + "Gerhard Schneider Martin Schoenert Marshall Schor" + "Frithjof Schulze Fritz Schwarz Nick Simicich" + "William Sit Elena Smirnova Jonathan Steinbach" + "Christine Sundaresan Robert Sutor Moss E. Sweedler" + "Eugene Surowitz" + "James Thatcher Balbir Thomas Mike Thomas" + "Dylan Thurston Barry Trager Themos T. Tsikas" + "Gregory Vanuxem" + "Bernhard Wall Stephen Watt Jaap Weel" + "Juergen Weiss M. Weller Mark Wegman" + "James Wen Thorsten Werther Michael Wester" + "John M. Wiley Berhard Will Clifton J. Williamson" + "Stephen Wilson Shmuel Winograd Robert Wisbauer" + "Sandra Wityak Waldemar Wiwianka Knut Wolf" + "Clifford Yapp David Yun" + "Richard Zippel Evelyn Zoernack Bruno Zuercher" + "Dan Zwillinger" + ) + +credits() == + for i in CREDITS repeat + PRINC(i) + TERPRI() + +--% )display + +display l == displaySpad2Cmd l + +displaySpad2Cmd l == + $e: local := $EmptyEnvironment + l is [opt,:vl] and opt ^= "?" => + option := selectOptionLC(opt,$displayOptions,'optionError) => + + -- the option may be given in the plural but the property in + -- the alist is sometimes singular + + option := + option = 'all => + l := ['properties] + 'properties + (option = 'modes) or (option = 'types) => + l := ['type, :vl] + 'type + option = 'values => + l := ['value, :vl] + 'value + option + + option = 'abbreviations => + null vl => listConstructorAbbreviations() + for v in vl repeat abbQuery(opOf v) + + option = 'operations => displayOperations vl + option = 'macros => displayMacros vl + option = 'names => displayWorkspaceNames() + displayProperties(option,l) + optList:= [:['%l,'" ",x] for x in $displayOptions] + msg := [:bright '" )display",'"keyword arguments are", + :bright optList,'%l,'" or abbreviations thereof."] + sayMessage msg + +displayMacros names == + imacs := getInterpMacroNames() + pmacs := getParserMacroNames() + macros := + null names => APPEND (imacs, pmacs) + names + macros := REMDUP macros + + null macros => sayBrightly '" There are no Axiom macros." + + -- first do user defined ones + + first := true + for macro in macros repeat + macro in pmacs => + if first then + sayBrightly ['%l,'"User-defined macros:"] + first := NIL + displayParserMacro macro + macro in imacs => 'iterate + sayBrightly ([" ",'%b, macro, '%d, " is not a known Axiom macro."]) + + -- now system ones + + first := true + for macro in macros repeat + macro in imacs => + macro in pmacs => 'iterate + if first then + sayBrightly ['%l,'"System-defined macros:"] + first := NIL + displayMacro macro + macro in pmacs => 'iterate + NIL + +getParserMacroNames() == + REMDUP [CAR mac for mac in getParserMacros()] + +--------------------> NEW DEFINITION (override in patches.lisp.pamphlet) +clearParserMacro(macro) == + -- first see if it is one + not IFCDR assoc(macro, ($pfMacros)) => NIL + $pfMacros := REMALIST($pfMacros, macro) + +displayMacro name == + m := isInterpMacro name + null m => + sayBrightly ['" ",:bright name,'"is not an interpreter macro."] + -- $op is needed in the output routines. + $op : local := STRCONC('"macro ",object2String name) + [args,:body] := m + args := + null args => nil + null rest args => first args + ['Tuple,:args] + mathprint ['MAP,[args,:body]] + +displayWorkspaceNames() == + imacs := getInterpMacroNames() + pmacs := getParserMacroNames() + sayMessage '"Names of User-Defined Objects in the Workspace:" + names := MSORT append(getWorkspaceNames(),pmacs) + if null names + then sayBrightly " * None *" + else sayAsManyPerLineAsPossible [object2String x for x in names] + imacs := SETDIFFERENCE(imacs,pmacs) + if imacs then + sayMessage '"Names of System-Defined Objects in the Workspace:" + sayAsManyPerLineAsPossible [object2String x for x in imacs] + + +getWorkspaceNames() == + NMSORT [n for [n,:.] in CAAR $InteractiveFrame | + (n ^= "--macros--" and n^= "--flags--")] + +displayOperations l == + null l => + x := UPCASE queryUserKeyedMsg("S2IZ0058",NIL) + if MEMQ(STRING2ID_-N(x,1),'(Y YES)) + then for op in allOperations() repeat reportOpSymbol op + else sayKeyedMsg("S2IZ0059",NIL) + nil + for op in l repeat reportOpSymbol op + +interpFunctionDepAlists() == + $e : local := $InteractiveFrame + deps := getFlag "$dependencies" + $dependentAlist := [[NIL,:NIL]] + $dependeeAlist := [[NIL,:NIL]] + for [dependee,dependent] in deps repeat + $dependentAlist := PUTALIST($dependentAlist,dependee, + CONS(dependent,GETALIST($dependentAlist,dependee))) + $dependeeAlist := PUTALIST($dependeeAlist,dependent, + CONS(dependee,GETALIST($dependeeAlist,dependent))) + +fixObjectForPrinting(v) == + v' := object2Identifier v + EQ(v',"%") => '"\%" + v' in $msgdbPrims => STRCONC('"\",PNAME v') + v + +displayProperties(option,l) == + $dependentAlist : local + $dependeeAlist : local + [opt,:vl]:= (l or ['properties]) + imacs := getInterpMacroNames() + pmacs := getParserMacroNames() + macros := REMDUP append(imacs, pmacs) + if vl is ['all] or null vl then + vl := MSORT append(getWorkspaceNames(),macros) + if $frameMessages then sayKeyedMsg("S2IZ0065",[$interpreterFrameName]) + null vl => + null $frameMessages => sayKeyedMsg("S2IZ0066",NIL) + sayKeyedMsg("S2IZ0067",[$interpreterFrameName]) + interpFunctionDepAlists() + for v in vl repeat + isInternalMapName(v) => 'iterate + pl := getIProplist(v) + option = 'flags => getAndSay(v,"flags") + option = 'value => displayValue(v,getI(v,'value),nil) + option = 'condition => displayCondition(v,getI(v,"condition"),nil) + option = 'mode => displayMode(v,getI(v,'mode),nil) + option = 'type => displayType(v,getI(v,'value),nil) + option = 'properties => + v = "--flags--" => nil + pl is [['cacheInfo,:.],:.] => nil + v1 := fixObjectForPrinting(v) + sayMSG ['"Properties of",:bright prefix2String v1,'":"] + null pl => + v in pmacs => + sayMSG '" This is a user-defined macro." + displayParserMacro v + isInterpMacro v => + sayMSG '" This is a system-defined macro." + displayMacro v + sayMSG '" none" + propsSeen:= nil + for [prop,:val] in pl | ^MEMQ(prop,propsSeen) and val repeat + prop in '(alias generatedCode IS_-GENSYM mapBody localVars) => + nil + prop = 'condition => + displayCondition(prop,val,true) + prop = 'recursive => + sayMSG '" This is recursive." + prop = 'isInterpreterFunction => + sayMSG '" This is an interpreter function." + sayFunctionDeps v where + sayFunctionDeps x == + if dependents := GETALIST($dependentAlist,x) then + null rest dependents => + sayMSG ['" The following function or rule ", + '"depends on this:",:bright first dependents] + sayMSG + '" The following functions or rules depend on this:" + msg := ["%b",'" "] + for y in dependents repeat msg := ['" ",y,:msg] + sayMSG [:nreverse msg,"%d"] + if dependees := GETALIST($dependeeAlist,x) then + null rest dependees => + sayMSG ['" This depends on the following function ", + '"or rule:",:bright first dependees] + sayMSG + '" This depends on the following functions or rules:" + msg := ["%b",'" "] + for y in dependees repeat msg := ['" ",y,:msg] + sayMSG [:nreverse msg,"%d"] + prop = 'isInterpreterRule => + sayMSG '" This is an interpreter rule." + sayFunctionDeps v + prop = 'localModemap => + displayModemap(v,val,true) + prop = 'mode => + displayMode(prop,val,true) + prop = 'value => + val => displayValue(v,val,true) + sayMSG ['" ",prop,'": ",val] + propsSeen:= [prop,:propsSeen] + sayKeyedMsg("S2IZ0068",[option]) + terminateSystemCommand() + +displayModemap(v,val,giveVariableIfNil) == + for mm in val repeat g(v,mm,giveVariableIfNil) where + g(v,mm,giveVariableIfNil) == + [[local,:signature],fn,:.]:= mm + local='interpOnly => nil + varPart:= (giveVariableIfNil => nil; ['" of",:bright v]) + prefix:= [" Compiled function type",:varPart,": "] + sayBrightly concat(prefix,formatSignature signature) + +displayMode(v,mode,giveVariableIfNil) == + null mode => nil + varPart:= (giveVariableIfNil => nil; [" of",:bright fixObjectForPrinting v]) + sayBrightly concat(" Declared type or mode", + varPart,": ",prefix2String mode) + +displayCondition(v,condition,giveVariableIfNil) == + varPart:= (giveVariableIfNil => nil; [" of",:bright v]) + condPart:= condition or 'true + sayBrightly concat(" condition",varPart,": ",pred2English condPart) + +getAndSay(v,prop) == + val:= getI(v,prop) => sayMSG [" ",val,'%l] + sayMSG [" none",'%l] + +displayType($op,u,omitVariableNameIfTrue) == + null u => + sayMSG ['" Type of value of ", + fixObjectForPrinting PNAME $op,'": (none)"] + type := prefix2String objMode(u) + if ATOM type then type := [type] + sayMSG concat ['" Type of value of ",fixObjectForPrinting PNAME $op,'": ",:type] + NIL + +displayValue($op,u,omitVariableNameIfTrue) == + null u => sayMSG [" Value of ",fixObjectForPrinting PNAME $op,'": (none)"] + expr := objValUnwrap(u) + expr is [op,:.] and (op = 'MAP) or objMode(u) = $EmptyMode => + displayRule($op,expr) + label:= + omitVariableNameIfTrue => + rhs := '"): " + '"Value (has type " + rhs := '": " + STRCONC('"Value of ", PNAME $op,'": ") + labmode := prefix2String objMode(u) + if ATOM labmode then labmode := [labmode] + GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain => + sayMSG concat('" ",label,labmode,rhs,form2String expr) + mathprint ['CONCAT,label,:labmode,rhs, + outputFormat(expr,objMode(u))] + NIL + +--% )edit + +edit l == editSpad2Cmd l + +editSpad2Cmd l == + l:= + null l => _/EDITFILE + CAR l + l := pathname l + oldDir := pathnameDirectory l + fileTypes := + pathnameType l => [pathnameType l] + $UserLevel = 'interpreter => '("input" "INPUT" "spad" "SPAD") + $UserLevel = 'compiler => '("input" "INPUT" "spad" "SPAD") + '("input" "INPUT" "spad" "SPAD" "boot" "BOOT" "lisp" "LISP" "meta" "META") + ll := + oldDir = '"" => pathname $FINDFILE (pathnameName l, fileTypes) + l + l := pathname ll + SETQ(_/EDITFILE,l) + rc := editFile l + updateSourceFiles l + rc + +--% )help + +help l == helpSpad2Cmd l + +helpSpad2Cmd args == + -- try to use new stuff first + if newHelpSpad2Cmd(args) then return nil + + sayKeyedMsg("S2IZ0025",[args]) + nil + +newHelpSpad2Cmd args == + if null args then args := ["?"] + # args > 1 => + sayKeyedMsg("S2IZ0026",NIL) + true + sarg := PNAME first args + if sarg = '"?" then args := ['help] + else if sarg = '"%" then args := ['history] + else if sarg = '"%%" then args := ['history] + arg := selectOptionLC(first args,$SYSCOMMANDS,nil) + if null arg then arg := first args + if arg = 'compiler then arg := 'compile + + -- see if new help file exists + + narg := PNAME arg + null (helpFile := MAKE_-INPUT_-FILENAME [narg,'HELPSPAD,'_*]) => NIL + + $useFullScreenHelp => + OBEY STRCONC('"$AXIOM/lib/SPADEDIT ",namestring helpFile) + true + + filestream := MAKE_-INSTREAM(helpFile) + repeat + line := read_-line(filestream,false) + NULL line => + SHUT filestream + return true + SAY line + true + +--% +--% )frame +--% + +$frameRecord := nil --Initial setting for frame record +$previousBindings := nil + +frame l == frameSpad2Cmd l + +frameName(frame) == CAR frame + +frameNames() == [frameName f for f in $interpreterFrameRing] + +frameEnvironment fname == + -- extracts the environment portion of a frame + -- if fname is not a valid frame name then the empty environment + -- is returned + fname = frameName first $interpreterFrameRing => $InteractiveFrame + ifr := rest $interpreterFrameRing + e := LIST LIST NIL + while ifr repeat + [f,:ifr] := ifr + if fname = frameName f then + e := CADR f + ifr := NIL + e + +frameSpad2Cmd args == + frameArgs := '(drop import last names new next) + $options => throwKeyedMsg("S2IZ0016",['")frame"]) + null(args) => helpSpad2Cmd ['frame] + arg := selectOptionLC(first args,frameArgs,'optionError) + args := rest args + if args is [a] then args := a + if ATOM args then args := object2Identifier args + arg = 'drop => + args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args]) + closeInterpreterFrame(args) + arg = "import" => importFromFrame args + arg = "last" => previousInterpreterFrame() + arg = "names" => displayFrameNames() + arg = "new" => + args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args]) + addNewInterpreterFrame(args) + arg = "next" => nextInterpreterFrame() + + NIL + +addNewInterpreterFrame(name) == + null name => throwKeyedMsg("S2IZ0018",NIL) + updateCurrentInterpreterFrame() + -- see if we already have one by that name + for f in $interpreterFrameRing repeat + name = frameName(f) => throwKeyedMsg("S2IZ0019",[name]) + initHistList() + $interpreterFrameRing := CONS(emptyInterpreterFrame(name), + $interpreterFrameRing) + updateFromCurrentInterpreterFrame() + _$ERASE histFileName() + +emptyInterpreterFrame(name) == + LIST(name, -- frame name + LIST LIST NIL, -- environment + 1, -- $IOindex + $HiFiAccess, -- $HiFiAccess + $HistList, -- $HistList + $HistListLen, -- $HistListLen + $HistListAct, -- $HistListAct + $HistRecord, -- $HistRecord + NIL, -- $internalHistoryTable + COPY_-SEQ $localExposureDataDefault -- $localExposureData + ) + +closeInterpreterFrame(name) == + -- if name = NIL then it means the current frame + null rest $interpreterFrameRing => + name and (name ^= $interpreterFrameName) => + throwKeyedMsg("S2IZ0020",[$interpreterFrameName]) + throwKeyedMsg("S2IZ0021",NIL) + if null name then $interpreterFrameRing := rest $interpreterFrameRing + else -- find the frame + found := nil + ifr := NIL + for f in $interpreterFrameRing repeat + found or (name ^= frameName(f)) => ifr := CONS(f,ifr) + found := true + not found => throwKeyedMsg("S2IZ0022",[name]) + _$ERASE makeHistFileName(name) + $interpreterFrameRing := nreverse ifr + updateFromCurrentInterpreterFrame() + +previousInterpreterFrame() == + updateCurrentInterpreterFrame() + null rest $interpreterFrameRing => NIL -- nothing to do + [:b,l] := $interpreterFrameRing + $interpreterFrameRing := NCONC2([l],b) + updateFromCurrentInterpreterFrame() + +nextInterpreterFrame() == + updateCurrentInterpreterFrame() + null rest $interpreterFrameRing => NIL -- nothing to do + $interpreterFrameRing := + NCONC2(rest $interpreterFrameRing,[first $interpreterFrameRing]) + updateFromCurrentInterpreterFrame() + + +createCurrentInterpreterFrame() == + LIST($interpreterFrameName, -- frame name + $InteractiveFrame, -- environment + $IOindex, -- $IOindex + $HiFiAccess, -- $HiFiAccess + $HistList, -- $HistList + $HistListLen, -- $HistListLen + $HistListAct, -- $HistListAct + $HistRecord, -- $HistRecord + $internalHistoryTable, -- $internalHistoryTable + $localExposureData -- $localExposureData + ) + + +updateFromCurrentInterpreterFrame() == + [$interpreterFrameName, _ + $InteractiveFrame, _ + $IOindex, _ + $HiFiAccess, _ + $HistList, _ + $HistListLen, _ + $HistListAct, _ + $HistRecord, _ + $internalHistoryTable, _ + $localExposureData _ + ] := first $interpreterFrameRing + if $frameMessages then + sayMessage ['" Current interpreter frame is called",:bright + $interpreterFrameName] + NIL + + +updateCurrentInterpreterFrame() == + RPLACA($interpreterFrameRing,createCurrentInterpreterFrame()) + updateFromCurrentInterpreterFrame() + NIL + +initializeInterpreterFrameRing() == + $interpreterFrameName := 'initial + $interpreterFrameRing := [emptyInterpreterFrame($interpreterFrameName)] + updateFromCurrentInterpreterFrame() + NIL + + +changeToNamedInterpreterFrame(name) == + updateCurrentInterpreterFrame() + frame := findFrameInRing(name) + null frame => NIL + $interpreterFrameRing := [frame,:NREMOVE($interpreterFrameRing, frame)] + updateFromCurrentInterpreterFrame() + +makeInitialModemapFrame() == COPY $InitialModemapFrame + +findFrameInRing(name) == + val := NIL + for frame in $interpreterFrameRing repeat + CAR frame = name => + val := frame + return frame + val + +displayFrameNames() == + fs := "append"/[ ['%l,'" ",:bright frameName f] for f in + $interpreterFrameRing] + sayKeyedMsg("S2IZ0024",[fs]) + +importFromFrame args == + -- args should have the form [frameName,:varNames] + if args and atom args then args := [args] + null args => throwKeyedMsg("S2IZ0073",NIL) + [fname,:args] := args + not member(fname,frameNames()) => + throwKeyedMsg("S2IZ0074",[fname]) + fname = frameName first $interpreterFrameRing => + throwKeyedMsg("S2IZ0075",NIL) + fenv := frameEnvironment fname + null args => + x := UPCASE queryUserKeyedMsg("S2IZ0076",[fname]) + MEMQ(STRING2ID_-N(x,1),'(Y YES)) => + vars := NIL + for [v,:props] in CAAR fenv repeat + v = "--macros" => + for [m,:.] in props repeat vars := cons(m,vars) + vars := cons(v,vars) + importFromFrame [fname,:vars] + sayKeyedMsg("S2IZ0077",[fname]) + for v in args repeat + plist := GETALIST(CAAR fenv,v) + plist => + -- remove anything with the same name in the current frame + clearCmdParts ['propert,v] + for [prop,:val] in plist repeat + putHist(v,prop,val,$InteractiveFrame) + (m := get("--macros--",v,fenv)) => + putHist("--macros--",v,m,$InteractiveFrame) + sayKeyedMsg("S2IZ0079",[v,fname]) + sayKeyedMsg("S2IZ0078",[fname]) + + + +--% )history + +++ vm/370 filename type component +SETANDFILEQ($historyFileType,'axh) + +++ vm/370 filename name component +SETANDFILEQ($oldHistoryFileName,'last) +SETANDFILEQ($internalHistoryTable,NIL) + +++ t means keep history in core +SETANDFILEQ($useInternalHistoryTable, true) + +history l == + l or null $options => sayKeyedMsg("S2IH0006",NIL) + historySpad2Cmd() + + +makeHistFileName(fname) == + makePathname(fname,$historyFileType,$historyDirectory) + +oldHistFileName() == + makeHistFileName($oldHistoryFileName) + +histFileName() == + makeHistFileName($interpreterFrameName) + + +histInputFileName(fn) == + null fn => + makePathname($interpreterFrameName,'INPUT,$historyDirectory) + makePathname(fn,'INPUT,$historyDirectory) + + +initHist() == + $useInternalHistoryTable => initHistList() + oldFile := oldHistFileName() + newFile := histFileName() + -- see if history directory is writable + histFileErase oldFile + if MAKE_-INPUT_-FILENAME newFile then $REPLACE(oldFile,newFile) + $HiFiAccess:= 'T + initHistList() + +initHistList() == + -- creates $HistList as a circular list of length $HistListLen + -- and $HistRecord + $HistListLen:= 20 + $HistList:= LIST NIL + li:= $HistList + for i in 1..$HistListLen repeat li:= CONS(NIL,li) + RPLACD($HistList,li) + $HistListAct:= 0 + $HistRecord:= NIL + +historySpad2Cmd() == + -- history is a system command which can call resetInCoreHist + -- and changeHistListLen, and restore last session + histOptions:= + '(on off yes no change reset restore write save show file memory) + opts:= [ [selectOptionLC(opt,histOptions,'optionError),:optargs] + for [opt,:optargs] in $options] + for [opt,:optargs] in opts repeat + opt in '(on yes) => + $HiFiAccess => sayKeyedMsg("S2IH0007",NIL) + $IOindex = 1 => -- haven't done anything yet + $HiFiAccess:= 'T + initHistList() + sayKeyedMsg("S2IH0008",NIL) + x := UPCASE queryUserKeyedMsg("S2IH0009",NIL) + MEMQ(STRING2ID_-N(x,1),'(Y YES)) => + histFileErase histFileName() + $HiFiAccess:= 'T + $options := nil + clearSpad2Cmd '(all) + sayKeyedMsg("S2IH0008",NIL) + initHistList() + sayKeyedMsg("S2IH0010",NIL) + opt in '(off no) => + null $HiFiAccess => sayKeyedMsg("S2IH0011",NIL) + $HiFiAccess:= NIL + disableHist() + sayKeyedMsg("S2IH0012",NIL) + opt = 'file => setHistoryCore NIL + opt = 'memory => setHistoryCore true + opt = 'reset => resetInCoreHist() + opt = 'save => saveHistory optargs + opt = 'show => showHistory optargs + opt = 'change => changeHistListLen first optargs + opt = 'restore => restoreHistory optargs + opt = 'write => writeInputLines(optargs,1) + 'done + + +setHistoryCore inCore == + inCore = $useInternalHistoryTable => + sayKeyedMsg((inCore => "S2IH0030"; "S2IH0029"),NIL) + not $HiFiAccess => + $useInternalHistoryTable := inCore + inCore => sayKeyedMsg("S2IH0032",NIL) + sayKeyedMsg("S2IH0031",NIL) + inCore => + $internalHistoryTable := NIL + if $IOindex ^= 0 then + -- actually put something in there + l := LENGTH RKEYIDS histFileName() + for i in 1..l repeat + vec:= UNWIND_-PROTECT(readHiFi(i),disableHist()) + $internalHistoryTable := CONS([i,:vec],$internalHistoryTable) + histFileErase histFileName() + $useInternalHistoryTable := true + sayKeyedMsg("S2IH0032",NIL) + $HiFiAccess:= 'NIL + histFileErase histFileName() + str := RDEFIOSTREAM ['(MODE . OUTPUT),['FILE,:histFileName()]] + for [n,:rec] in reverse $internalHistoryTable repeat + SPADRWRITE(object2Identifier n,rec,str) + RSHUT str + $HiFiAccess:= 'T + $internalHistoryTable := NIL + $useInternalHistoryTable := NIL + sayKeyedMsg("S2IH0031",NIL) + + +writeInputLines(fn,initial) == + -- writes all input lines into file histInputFileName() + not $HiFiAccess => sayKeyedMsg("S2IH0013",NIL) -- history not on + null fn => + throwKeyedMsg("S2IH0038", nil) -- missing file name + maxn := 72 + breakChars := [" ","+"] + for i in initial..$IOindex - 1 repeat + vecl := CAR readHiFi i + if STRINGP vecl then vecl := [vecl] + for vec in vecl repeat + n := SIZE vec + while n > maxn repeat + -- search backwards for a blank + done := nil + for j in 1..maxn while ^done repeat + k := 1 + maxn - j + MEMQ(vec.k,breakChars) => + svec := STRCONC(SUBSTRING(vec,0,k+1),UNDERBAR) + lineList := [svec,:lineList] + done := true + vec := SUBSTRING(vec,k+1,NIL) + n := SIZE vec + -- in case we can't find a breaking point + if ^done then n := 0 + lineList := [vec,:lineList] + file := histInputFileName(fn) + histFileErase file + inp:= DEFIOSTREAM(['(MODE . OUTPUT),['FILE,:file]],255,0) + for x in removeUndoLines NREVERSE lineList repeat WRITE_-LINE(x,inp) + -- see file "undo" for definition of removeUndoLines + if fn ^= 'redo then sayKeyedMsg("S2IH0014",[namestring file]) + SHUT inp + NIL + + +resetInCoreHist() == + -- removes all pointers from $HistList + $HistListAct:= 0 + for i in 1..$HistListLen repeat + $HistList:= CDR $HistList + RPLACA($HistList,NIL) + +changeHistListLen(n) == + -- changes the length of $HistList. n must be nonnegative + NULL INTEGERP n => sayKeyedMsg("S2IH0015",[n]) + dif:= n-$HistListLen + $HistListLen:= n + l:= CDR $HistList + if dif > 0 then + for i in 1..dif repeat l:= CONS(NIL,l) + if dif < 0 then + for i in 1..-dif repeat l:= CDR l + if $HistListAct > n then $HistListAct:= n + RPLACD($HistList,l) + 'done + +updateHist() == + -- updates the history file and calls updateInCoreHist + null $IOindex => nil + startTimingProcess 'history + updateInCoreHist() + if $HiFiAccess then + UNWIND_-PROTECT(writeHiFi(),disableHist()) + $HistRecord:= NIL + $IOindex:= $IOindex+1 + updateCurrentInterpreterFrame() + $mkTestInputStack := nil + $currentLine := nil + stopTimingProcess 'history + +updateInCoreHist() == + -- updates $HistList and $IOindex + $HistList:= CDR($HistList) + RPLACA($HistList,NIL) + if $HistListAct < $HistListLen then $HistListAct:= $HistListAct+1 + +putHist(x,prop,val,e) == + -- records new value to $HistRecord and old value to $HistList + -- then put is called with e + if not (x='%) then recordOldValue(x,prop,get(x,prop,e)) + if $HiFiAccess then recordNewValue(x,prop,val) + putIntSymTab(x,prop,val,e) + +histFileErase file == + --OBEY STRCONC('"rm -rf ", file) + PROBE_-FILE(file) and DELETE_-FILE(file) + + + +recordNewValue(x,prop,val) == + startTimingProcess 'history + recordNewValue0(x,prop,val) + stopTimingProcess 'history + +recordNewValue0(x,prop,val) == + -- writes (prop . val) into $HistRecord + -- updateHist writes this stuff out into the history file + p1:= ASSQ(x,$HistRecord) => + p2:= ASSQ(prop,CDR p1) => + RPLACD(p2,val) + RPLACD(p1,CONS(CONS(prop,val),CDR p1)) + p:= CONS(x,list CONS(prop,val)) + $HistRecord:= CONS(p,$HistRecord) + +recordOldValue(x,prop,val) == + startTimingProcess 'history + recordOldValue0(x,prop,val) + stopTimingProcess 'history + +recordOldValue0(x,prop,val) == + -- writes (prop . val) into $HistList + p1:= ASSQ(x,CAR $HistList) => + not ASSQ(prop,CDR p1) => + RPLACD(p1,CONS(CONS(prop,val),CDR p1)) + p:= CONS(x,list CONS(prop,val)) + RPLACA($HistList,CONS(p,CAR $HistList)) + +undoInCore(n) == + -- undoes the last n>0 steps using $HistList + -- resets $InteractiveFrame + li:= $HistList + for i in n..$HistListLen repeat li:= CDR li + undoChanges(li) + n:= $IOindex-n-1 + n>0 and + $HiFiAccess => + vec:= CDR UNWIND_-PROTECT(readHiFi(n),disableHist()) + val:= ( p:= ASSQ('%,vec) ) and ( p1:= ASSQ('value,CDR p) ) and + CDR p1 + sayKeyedMsg("S2IH0019",[n]) + $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame) + updateHist() + +undoChanges(li) == + -- undoes all changes of list 'li' + if not CDR li = $HistList then undoChanges CDR li + for p1 in CAR li repeat + x:= CAR p1 + for p2 in CDR p1 repeat + putHist(x,CAR p2,CDR p2,$InteractiveFrame) + +undoFromFile(n) == + -- makes a clear and redoes all the assignments until step n + for [x,:varl] in CAAR $InteractiveFrame repeat + for p in varl repeat + [prop,:val]:= p + val => + if not (x='%) then recordOldValue(x,prop,val) + if $HiFiAccess then recordNewValue(x,prop,val) + RPLACD(p,NIL) + for i in 1..n repeat + vec:= UNWIND_-PROTECT(CDR readHiFi(i),disableHist()) + for p1 in vec repeat + x:= CAR p1 + for p2 in CDR p1 repeat + $InteractiveFrame:= putHist(x,CAR p2,CDR p2,$InteractiveFrame) + val:= ( p:= ASSQ('%,vec) ) and ( p1:= ASSQ('value,CDR p) ) and CDR p1 + $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame) + updateHist() + +saveHistory(fn) == + $seen: local := MAKE_-HASHTABLE 'EQ + not $HiFiAccess => sayKeyedMsg("S2IH0016",NIL) + not $useInternalHistoryTable and + null MAKE_-INPUT_-FILENAME histFileName() => sayKeyedMsg("S2IH0022",NIL) + null fn => + throwKeyedMsg("S2IH0037", nil) + savefile := makeHistFileName(fn) + inputfile := histInputFileName(fn) + writeInputLines(fn,1) + histFileErase savefile + + if $useInternalHistoryTable + then + saveStr := RDEFIOSTREAM ['(MODE . OUTPUT),['FILE,:savefile]] + for [n,:rec] in reverse $internalHistoryTable repeat + val := SPADRWRITE0(object2Identifier n,rec,saveStr) + val = 'writifyFailed => + sayKeyedMsg("S2IH0035", [n, inputfile]) -- unable to save step + RSHUT saveStr + sayKeyedMsg("S2IH0018",[namestring(savefile)]) -- saved hist file named + nil + +restoreHistory(fn) == + -- uses fn $historyFileType to recover an old session + -- if fn = NIL, then use $oldHistoryFileName + if null fn then fn' := $oldHistoryFileName + else if fn is [fn'] and IDENTP(fn') then fn' := fn' + else throwKeyedMsg("S2IH0023",[fn']) + restfile := makeHistFileName(fn') + null MAKE_-INPUT_-FILENAME restfile => + sayKeyedMsg("S2IH0024",[namestring(restfile)]) -- no history file + + -- if clear is changed to be undoable, this should be a reset-clear + $options: local := nil + clearSpad2Cmd '(all) + + curfile := histFileName() + histFileErase curfile + _$FCOPY(restfile,curfile) + + l:= LENGTH RKEYIDS curfile + $HiFiAccess:= 'T + oldInternal := $useInternalHistoryTable + $useInternalHistoryTable := NIL + if oldInternal then $internalHistoryTable := NIL + for i in 1..l repeat + vec:= UNWIND_-PROTECT(readHiFi(i),disableHist()) + if oldInternal then $internalHistoryTable := + CONS([i,:vec],$internalHistoryTable) + LINE:= CAR vec + for p1 in CDR vec repeat + x:= CAR p1 + for p2 in CDR p1 repeat + $InteractiveFrame:= putHist(x,CAR p2,CDR p2,$InteractiveFrame) + updateInCoreHist() + $e := $InteractiveFrame + for [a,:.] in CAAR $InteractiveFrame repeat + get(a,'localModemap,$InteractiveFrame) => + rempropI(a,'localModemap) + rempropI(a,'localVars) + rempropI(a,'mapBody) + $IOindex:= l+1 + $useInternalHistoryTable := oldInternal + sayKeyedMsg("S2IH0025",[namestring(restfile)]) + clearCmdSortedCaches() + nil + + +-- the following used to be the show command when that was used to +-- show history. +showHistory(arg) == + -- arg can be of form + -- NIL show at most last 20 input lines + -- (n) show at most last n input lines + -- (lit) where lit is an abbreviation for 'input or 'both + -- if 'input, same as NIL + -- if 'both, show last 5 input and outputs + -- (n lit) show last n input lines + last n output lines + -- if lit expands to 'both + $evalTimePrint: local:= 0 + $printTimeSum: local:= 0 + -- ugh!!! these are needed for timedEvaluateStream + -- displays the last n steps, default n=20 + not $HiFiAccess => sayKeyedMsg("S2IH0026",['show]) + showInputOrBoth := 'input + n := 20 + nset := nil + if arg then + arg1 := CAR arg + if INTEGERP arg1 then + n := arg1 + nset := true + KDR arg => arg1 := CADR arg + arg1 := NIL + arg1 => + arg2 := selectOptionLC(arg1,'(input both),nil) + if arg2 + then ((showInputOrBoth := arg2) = 'both) and (null nset) => n:= 5 + else sayMSG + concat('" ",bright arg1,'"is an invalid argument.") + if n >= $IOindex then n:= $IOindex-1 + mini:= $IOindex-n + maxi:= $IOindex-1 + showInputOrBoth = 'both => + UNWIND_-PROTECT(showInOut(mini,maxi),setIOindex(maxi+1)) + showInput(mini,maxi) + +setIOindex(n) == + -- set $IOindex to n + $IOindex:= n + +showInput(mini,maxi) == + -- displays all input lines from mini to maxi + for ind in mini..maxi repeat + vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist()) + if ind<10 then TAB 2 else if ind<100 then TAB 1 + l := CAR vec + STRINGP l => + sayMSG ['" [",ind,'"] ",CAR vec] + sayMSG ['" [",ind,'"] " ] + for ln in l repeat + sayMSG ['" ", ln] + +showInOut(mini,maxi) == + -- displays all steps from mini to maxi + for ind in mini..maxi repeat + vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist()) + sayMSG [CAR vec] + Alist:= ASSQ('%,CDR vec) => + triple:= CDR ASSQ('value,CDR Alist) + $IOindex:= ind + spadPrint(objValUnwrap triple,objMode triple) + +fetchOutput(n) == + -- result is the output of step n + (n = -1) and (val := getI("%",'value)) => val + $HiFiAccess => + n:= + n < 0 => $IOindex+n + n + n >= $IOindex => throwKeyedMsg("S2IH0001",[n]) + n < 1 => throwKeyedMsg("S2IH0002",[n]) + vec:= UNWIND_-PROTECT(readHiFi(n),disableHist()) + Alist:= ASSQ('%,CDR vec) => + val:= CDR ASSQ('value,CDR Alist) => val + throwKeyedMsg("S2IH0003",[n]) + throwKeyedMsg("S2IH0003",[n]) + throwKeyedMsg("S2IH0004",NIL) + +readHiFi(n) == + -- reads the file using index n + if $useInternalHistoryTable + then + pair := assoc(n,$internalHistoryTable) + ATOM pair => keyedSystemError("S2IH0034",NIL) + vec := QCDR pair + else + HiFi:= RDEFIOSTREAM ['(MODE . INPUT),['FILE,:histFileName()]] + vec:= SPADRREAD(object2Identifier n,HiFi) + RSHUT HiFi + vec + +writeHiFi() == + -- writes the information of the current step out to history file + if $useInternalHistoryTable + then + $internalHistoryTable := CONS([$IOindex,$currentLine,:$HistRecord], + $internalHistoryTable) + else + HiFi:= RDEFIOSTREAM ['(MODE . OUTPUT),['FILE,:histFileName()]] + SPADRWRITE(object2Identifier $IOindex, CONS($currentLine,$HistRecord),HiFi) + RSHUT HiFi + +disableHist() == + -- disables the history mechanism if an error occurred in the protected + -- piece of code + not $HiFiAccess => histFileErase histFileName() + NIL + +writeHistModesAndValues() == + for [a,:.] in CAAR $InteractiveFrame repeat + x := get(a,'value,$InteractiveFrame) => + putHist(a,'value,x,$InteractiveFrame) + x := get(a,'mode,$InteractiveFrame) => + putHist(a,'mode,x,$InteractiveFrame) + NIL + +SPADRREAD(vec, stream) == + dewritify rread(vec, stream, nil) + +--% Lisplib output transformations +-- Some types of objects cannot be saved by LISP/VM in lisplibs. +-- These functions transform an object to a writable form and back. +-- SMW +SPADRWRITE(vec, item, stream) == + val := SPADRWRITE0(vec, item, stream) + val = 'writifyFailed => + throwKeyedMsg("S2IH0036", nil) -- cannot save value to file + item + +SPADRWRITE0(vec, item, stream) == + val := safeWritify item + val = 'writifyFailed => val + rwrite(vec, val, stream) + item + +safeWritify ob == + CATCH('writifyTag, writify ob) + +writify ob == + not ScanOrPairVec(function(unwritable?), ob) => ob + $seen: local := MAKE_-HASHTABLE 'EQ + $writifyComplained: local := false + + writifyInner ob where + writifyInner ob == + null ob => nil + (e := HGET($seen, ob)) => e + + PAIRP ob => + qcar := QCAR ob + qcdr := QCDR ob + (name := spadClosure? ob) => + d := writifyInner QCDR ob + nob := ['WRITIFIED_!_!, 'SPADCLOSURE, d, name] + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + nob + (ob is ['LAMBDA_-CLOSURE, ., ., x, :.]) and x => + THROW('writifyTag, 'writifyFailed) + nob := CONS(qcar, qcdr) + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + qcar := writifyInner qcar + qcdr := writifyInner qcdr + QRPLACA(nob, qcar) + QRPLACD(nob, qcdr) + nob + VECP ob => + isDomainOrPackage ob => + d := mkEvalable devaluate ob + nob := ['WRITIFIED_!_!, 'DEVALUATED, writifyInner d] + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + nob + n := QVMAXINDEX ob + nob := MAKE_-VEC(n+1) + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + for i in 0..n repeat + QSETVELT(nob, i, writifyInner QVELT(ob,i)) + nob + ob = 'WRITIFIED_!_! => + ['WRITIFIED_!_!, 'SELF] + -- In CCL constructors are also compiled functions, so we + -- need this line: + constructor? ob => ob + COMPILED_-FUNCTION_-P ob => + THROW('writifyTag, 'writifyFailed) + HASHTABLEP ob => + nob := ['WRITIFIED_!_!] + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + keys := HKEYS ob + QRPLACD(nob, + ['HASHTABLE, + HASHTABLE_-CLASS ob, + writifyInner keys, + [writifyInner HGET(ob,k) for k in keys]]) + nob + PLACEP ob => + nob := ['WRITIFIED_!_!, 'PLACE] + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + nob + -- The next three types cause an error on de-writifying. + -- Create an object of the right shape, nonetheless. + READTABLEP ob => + THROW('writifyTag, 'writifyFailed) + -- Default case: return the object itself. + STRINGP ob => + EQ(ob, $NullStream) => ['WRITIFIED_!_!, 'NULLSTREAM] + EQ(ob, $NonNullStream) => ['WRITIFIED_!_!, 'NONNULLSTREAM] + ob + FLOATP ob => + ob = READ_-FROM_-STRING STRINGIMAGE ob => ob + ['WRITIFIED_!_!, 'FLOAT, ob,: + MULTIPLE_-VALUE_-LIST INTEGER_-DECODE_-FLOAT ob] + ob + + +unwritable? ob == + PAIRP ob or VECP ob => false -- first for speed + COMPILED_-FUNCTION_-P ob or HASHTABLEP ob => true + PLACEP ob or READTABLEP ob => true + FLOATP ob => true + false + +-- Create a full isomorphic object which can be saved in a lisplib. +-- Note that dewritify(writify(x)) preserves UEQUALity of hashtables. +-- HASHTABLEs go both ways. +-- READTABLEs cannot presently be transformed back. + +writifyComplain s == + $writifyComplained = true => nil + $writifyComplained := true + sayKeyedMsg("S2IH0027",[s]) + +spadClosure? ob == + fun := QCAR ob + not (name := BPINAME fun) => nil + vec := QCDR ob + not VECP vec => nil + name + +dewritify ob == + (not ScanOrPairVec(function is?, ob) + where is? a == a = 'WRITIFIED_!_!) => ob + + $seen: local := MAKE_-HASHTABLE 'EQ + + dewritifyInner ob where + dewritifyInner ob == + null ob => nil + e := HGET($seen, ob) => e + + PAIRP ob and CAR ob = 'WRITIFIED_!_! => + type := ob.1 + type = 'SELF => + 'WRITIFIED_!_! + type = 'BPI => + oname := ob.2 + f := + INTP oname => EVAL GENSYMMER oname + SYMBOL_-FUNCTION oname + not COMPILED_-FUNCTION_-P f => + error '"A required BPI does not exist." + #ob > 3 and HASHEQ f ^= ob.3 => + error '"A required BPI has been redefined." + HPUT($seen, ob, f) + f + type = 'HASHTABLE => + nob := MAKE_-HASHTABLE ob.2 + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + for k in ob.3 for e in ob.4 repeat + HPUT(nob, dewritifyInner k, dewritifyInner e) + nob + type = 'DEVALUATED => + nob := EVAL dewritifyInner ob.2 + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + nob + type = 'SPADCLOSURE => + vec := dewritifyInner ob.2 + name := ob.3 + not FBOUNDP name => + error STRCONC('"undefined function: ", SYMBOL_-NAME name) + nob := CONS(SYMBOL_-FUNCTION name, vec) + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + nob + type = 'PLACE => + nob := VMREAD MAKE_-INSTREAM NIL + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + nob + type = 'READTABLE => + error '"Cannot de-writify a read table." + type = 'NULLSTREAM => $NullStream + type = 'NONNULLSTREAM => $NonNullStream + type = 'FLOAT => + [fval, signif, expon, sign] := CDDR ob + fval := SCALE_-FLOAT( FLOAT(signif, fval), expon) + sign<0 => -fval + fval + error '"Unknown type to de-writify." + + PAIRP ob => + qcar := QCAR ob + qcdr := QCDR ob + nob := CONS(qcar, qcdr) + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + QRPLACA(nob, dewritifyInner qcar) + QRPLACD(nob, dewritifyInner qcdr) + nob + VECP ob => + n := QVMAXINDEX ob + nob := MAKE_-VEC(n+1) + HPUT($seen, ob, nob) + HPUT($seen, nob, nob) + for i in 0..n repeat + QSETVELT(nob, i, dewritifyInner QVELT(ob,i)) + nob + -- Default case: return the object itself. + ob + +ScanOrPairVec(f, ob) == + $seen: local := MAKE_-HASHTABLE 'EQ + + CATCH('ScanOrPairVecAnswer, ScanOrInner(f, ob)) where + ScanOrInner(f, ob) == + HGET($seen, ob) => nil + PAIRP ob => + HPUT($seen, ob, true) + ScanOrInner(f, QCAR ob) + ScanOrInner(f, QCDR ob) + nil + VECP ob => + HPUT($seen, ob, true) + for i in 0..#ob-1 repeat ScanOrInner(f, ob.i) + nil + FUNCALL(f, ob) => + THROW('ScanOrPairVecAnswer, true) + nil + + + + + +--% )load + +load args == loadSpad2Cmd args + +loadSpad2Cmd args == + sayKeyedMsg("S2IU0003", nil) + NIL +-- load1(args,$forceDatabaseUpdate) + +--load1(args,$forceDatabaseUpdate) == -- $ var is now local +-- null args => helpSpad2Cmd '(load) +-- loadfun := 'loadLib +-- justWondering := nil +-- compiler := 'old +-- doExpose := true +-- $forceDatabaseUpdate := true -- BMT request, 5/14/90 +-- for [opt,:.] in $options repeat +-- fullopt := selectOptionLC(opt, +-- '(cond update query new noexpose noupdate), +-- 'optionError) +-- fullopt = 'cond => loadfun := 'loadLibIfNotLoaded +-- fullopt = 'query => justWondering := true +-- fullopt = 'update => $forceDatabaseUpdate := true +-- fullopt = 'noexpose => doExpose := false +-- fullopt = 'noupdate => $forceDatabaseUpdate := false +-- if $forceDatabaseUpdate then clearClams() +-- for lib in args repeat +-- lib := object2Identifier lib +-- justWondering => +-- GETL(lib,'LOADED) => sayKeyedMsg("S2IZ0028",[lib]) +-- sayKeyedMsg("S2IZ0029",[lib]) +-- null GETDATABASE(lib,'OBJECT) and +-- null (lib := GETDATABASE(lib,'CONSTRUCTOR)) => +-- sayKeyedMsg("S2IL0020", [namestring [lib,$spadLibFT,"*"]]) +-- null FUNCALL(loadfun,lib) => +-- sayKeyedMsg("S2IZ0029",[lib]) +-- sayKeyedMsg("S2IZ0028",[lib]) +-- if doExpose and +-- not isExposedConstructor(lib) then +-- setExposeAddConstr([lib]) +-- 'EndOfLoad + +reportCount () == + centerAndHighlight(" Current Count Settings ",$LINELENGTH,specialChar 'hbar) + SAY " " + sayBrightly [:bright " cache",fillerSpaces(30,'".")," ",$cacheCount] + if $cacheAlist then + for [a,:b] in $cacheAlist repeat + aPart:= linearFormatName a + n:= sayBrightlyLength aPart + sayBrightly concat(" ",aPart," ",fillerSpaces(32-n,'".")," ",b) + SAY " " + sayBrightly [:bright " stream",fillerSpaces(29,'".")," ",$streamCount] + +--% )quit + +pquit() == pquitSpad2Cmd() + +pquitSpad2Cmd() == + $saturn => + sayErrorly('"Obsolete system command", _ + ['" The )pquit system command is obsolete in this version of AXIOM.", + '" Please select Exit from the File Menu instead."]) + $quitCommandType :local := 'protected + quitSpad2Cmd() + +quit() == quitSpad2Cmd() + +quitSpad2Cmd() == + $saturn => + sayErrorly('"Obsolete system command", _ + ['" The )quit system command is obsolete in this version of AXIOM.", + '" Please select Exit from the File Menu instead."]) + $quitCommandType ^= 'protected => leaveScratchpad() + x := UPCASE queryUserKeyedMsg("S2IZ0031",NIL) + MEMQ(STRING2ID_-N(x,1),'(Y YES)) => leaveScratchpad() + sayKeyedMsg("S2IZ0032",NIL) + TERSYSCOMMAND () + +leaveScratchpad () == BYE() + +--% )read + +read l == readSpad2Cmd l + +readSpad2Cmd l == + ---$saturn => + --- sayErrorly('"Obsolete system command", _ + --- ['" The )read system command is obsolete in this version of AXIOM.", + --- '" Please use Open from the File menu instead."]) + $InteractiveMode : local := true + quiet := nil + ifthere := nil + for [opt,:.] in $options repeat + fullopt := selectOptionLC(opt,'(quiet test ifthere),'optionError) + fullopt = 'ifthere => ifthere := true + fullopt = 'quiet => quiet := true + + ef := pathname _/EDITFILE + if pathnameTypeId(ef) = 'SPAD then + ef := makePathname(pathnameName ef,'"*",'"*") + if l then + l := mergePathnames(pathname l,ef) + else + l := ef + devFTs := '("input" "INPUT" "boot" "BOOT" "lisp" "LISP") + fileTypes := + $UserLevel = 'interpreter => '("input" "INPUT") + $UserLevel = 'compiler => '("input" "INPUT") + devFTs + ll := $FINDFILE (l, fileTypes) + if null ll then + ifthere => return nil -- be quiet about it + throwKeyedMsg("S2IL0003",[namestring l]) + ll := pathname ll + ft := pathnameType ll + upft := UPCASE ft + null member(upft,fileTypes) => + fs := namestring l + member(upft,devFTs) => throwKeyedMsg("S2IZ0033",[fs]) + throwKeyedMsg("S2IZ0034",[fs]) + SETQ(_/EDITFILE,ll) + if upft = '"BOOT" then $InteractiveMode := nil + _/READ(ll,quiet) + +--% )savesystem +savesystem l == + #l ^= 1 or not(SYMBOLP CAR l) => helpSpad2Cmd '(savesystem) + SPAD_-SAVE SYMBOL_-NAME CAR l + +--% )show + +show l == showSpad2Cmd l + +showSpad2Cmd l == + l = [NIL] => helpSpad2Cmd '(show) + $showOptions : local := '(attributes operations) + if null $options then $options := '((operations)) + $e : local := $InteractiveFrame + $env : local := $InteractiveFrame + l is [constr] => + constr in '(Union Record Mapping) => + constr = 'Record => + sayKeyedMsg("S2IZ0044R",[constr, '")show Record(a: Integer, b: String)"]) + constr = 'Mapping => + sayKeyedMsg("S2IZ0044M",NIL) + sayKeyedMsg("S2IZ0045T",[constr, '")show Union(a: Integer, b: String)"]) + sayKeyedMsg("S2IZ0045U",[constr, '")show Union(Integer, String)"]) + constr is ['Mapping, :.] => + sayKeyedMsg("S2IZ0044M",NIL) + reportOperations(constr,constr) + reportOperations(l,l) + +reportOperations(oldArg,u) == + -- u might be an uppercased version of oldArg + $env:local := [[NIL]] + $eval:local := true --generate code-- don't just type analyze + $genValue:local := true --evaluate all generated code + null u => nil + $doNotAddEmptyModeIfTrue: local:= true + u = $quadSymbol => + sayBrightly ['" mode denotes", :bright '"any", "type"] + u = "%" => + sayKeyedMsg("S2IZ0063",NIL) + sayKeyedMsg("S2IZ0064",NIL) + u isnt ['Record,:.] and u isnt ['Union,:.] and + null(isNameOfType u) and u isnt ['typeOf,.] => + if ATOM oldArg then oldArg := [oldArg] + sayKeyedMsg("S2IZ0063",NIL) + for op in oldArg repeat + sayKeyedMsg("S2IZ0062",[opOf op]) + (v := isDomainValuedVariable u) => reportOpsFromUnitDirectly0 v + unitForm:= + atom u => opOf unabbrev u + unabbrev u + atom unitForm => reportOpsFromLisplib0(unitForm,u) + unitForm' := evaluateType unitForm + tree := mkAtree removeZeroOneDestructively unitForm + (unitForm' := isType tree) => reportOpsFromUnitDirectly0 unitForm' + sayKeyedMsg("S2IZ0041",[unitForm]) + +reportOpsFromUnitDirectly0 D == + $useEditorForShowOutput => + reportOpsFromUnitDirectly1 D + reportOpsFromUnitDirectly D + +reportOpsFromUnitDirectly1 D == + showFile := pathname ['SHOW,'LISTING,$listingDirectory] + _$ERASE showFile + $sayBrightlyStream : fluid := + DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) + sayShowWarning() + reportOpsFromUnitDirectly D + SHUT $sayBrightlyStream + editFile showFile + +sayShowWarning() == + sayBrightly + '"Warning: this is a temporary file and will be deleted the next" + sayBrightly + '" time you use )show. Rename it and FILE if you wish to" + sayBrightly + '" save the contents." + sayBrightly '"" + +reportOpsFromLisplib0(unitForm,u) == + $useEditorForShowOutput => reportOpsFromLisplib1(unitForm,u) + reportOpsFromLisplib(unitForm,u) + +reportOpsFromLisplib1(unitForm,u) == + showFile := pathname ['SHOW,'LISTING,$listingDirectory] + _$ERASE showFile + $sayBrightlyStream : fluid := + DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) + sayShowWarning() + reportOpsFromLisplib(unitForm,u) + SHUT $sayBrightlyStream + editFile showFile + +reportOpsFromUnitDirectly unitForm == + isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union) + unit:= evalDomain unitForm + top:= CAR unitForm + kind:= GETDATABASE(top,'CONSTRUCTORKIND) + + sayBrightly concat('%b,formatOpType unitForm, + '%d,'"is a",'%b,kind,'%d, '"constructor.") + if not isRecordOrUnion then + abb := GETDATABASE(top,'ABBREVIATION) + sourceFile := GETDATABASE(top,'SOURCEFILE) + sayBrightly ['" Abbreviation for",:bright top,'"is",:bright abb] + verb := + isExposedConstructor top => '"is" + '"is not" + sayBrightly ['" This constructor",:bright verb, + '"exposed in this frame."] + sayBrightly ['" Issue",:bright STRCONC('")edit ", + namestring sourceFile),'"to see algebra source code for", + :bright abb,'%l] + + for [opt] in $options repeat + opt := selectOptionLC(opt,$showOptions,'optionError) + opt = 'attributes => + centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) + isRecordOrUnion => + sayBrightly '" Records and Unions have no attributes." + sayBrightly '"" + attList:= REMDUP MSORT [x for [x,:.] in unit.2] + say2PerLine [formatAttribute x for x in attList] + NIL + opt = 'operations => + $commentedOps: local := 0 + --new form is ( ) + centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) + sayBrightly '"" + if isRecordOrUnion + then + constructorFunction:= GETL(top,"makeFunctionList") or + systemErrorHere '"reportOpsFromUnitDirectly" + [funlist,.]:= FUNCALL(constructorFunction,"$",unitForm, + $CategoryFrame) + sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for + [a,b,c] in funlist] + else + sigList:= REMDUP MSORT getOplistForConstructorForm unitForm + say2PerLine [formatOperation(x,unit) for x in sigList] + if $commentedOps ^= 0 then + sayBrightly + ['"Functions that are not yet implemented are preceded by", + :bright '"--"] + sayBrightly '"" + NIL + +reportOpsFromLisplib(op,u) == + null(fn:= constructor? op) => sayKeyedMsg("S2IZ0054",[u]) + argml := + (s := getConstructorSignature op) => KDR s + NIL + typ:= GETDATABASE(op,'CONSTRUCTORKIND) + nArgs:= #argml + argList:= KDR GETDATABASE(op,'CONSTRUCTORFORM) + functorForm:= [op,:argList] + argml:= EQSUBSTLIST(argList,$FormalMapVariableList,argml) + functorFormWithDecl:= [op,:[[":",a,m] for a in argList for m in argml]] + sayBrightly concat(bright form2StringWithWhere functorFormWithDecl, + '" is a",bright typ,'"constructor") + sayBrightly ['" Abbreviation for",:bright op,'"is",:bright fn] + verb := + isExposedConstructor op => '"is" + '"is not" + sayBrightly ['" This constructor",:bright verb, + '"exposed in this frame."] + sourceFile := GETDATABASE(op,'SOURCEFILE) + sayBrightly ['" Issue",:bright STRCONC('")edit ", + namestring sourceFile), + '"to see algebra source code for",:bright fn,'%l] + + for [opt] in $options repeat + opt := selectOptionLC(opt,$showOptions,'optionError) + opt = 'layout => + dc1 fn + opt = 'views => sayBrightly ['"To get",:bright '"views", + '"you must give parameters of constructor"] + opt = 'attributes => + centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) + sayBrightly '"" + attList:= REMDUP MSORT [x for [x,:.] in + GETDATABASE(op,'ATTRIBUTES)] + null attList => sayBrightly + concat('%b,form2String functorForm,'%d,"has no attributes.",'%l) + say2PerLine [formatAttribute x for x in attList] + NIL + opt = 'operations => displayOperationsFromLisplib functorForm + nil + +displayOperationsFromLisplib form == + [name,:argl] := form + kind := GETDATABASE(name,'CONSTRUCTORKIND) + centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) + opList:= GETDATABASE(name,'OPERATIONALIST) + null opList => reportOpsFromUnitDirectly form + opl:=REMDUP MSORT EQSUBSTLIST(argl,$FormalMapVariableList,opList) + ops:= nil + for x in opl repeat + ops := [:ops,:formatOperationAlistEntry(x)] + say2PerLine ops + nil + +--% )spool + +clearHighlight() == + $saveHighlight := $highlightAllowed + $highlightAllowed := false + $saveSpecialchars := $specialCharacters + setOutputCharacters ["plain"] + +resetHighlight() == + $highlightAllowed := $saveHighlight + $specialCharacters := $saveSpecialchars + +spool filename == + null filename => + DRIBBLE() + TERPRI() + resetHighlight() + PROBE_-FILE car filename => + systemError CONCAT('"file ", STRING car filename, '" already exists") + DRIBBLE car filename + TERPRI() + clearHighlight() + +--% )synonym + +synonym(:l) == synonymSpad2Cmd() -- always passed a null list + +synonymSpad2Cmd() == + line := getSystemCommandLine() + if line = '"" then printSynonyms(NIL) + else + pair := processSynonymLine line + if $CommandSynonymAlist then + PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) + else $CommandSynonymAlist := [pair] + terminateSystemCommand() + +processSynonymLine line == + key := STRING2ID_-N (line, 1) + value := removeKeyFromLine line where + removeKeyFromLine line == + line := dropLeadingBlanks line + mx := MAXINDEX line + for i in 0..mx repeat + line.i = " " => + return (for j in (i+1)..mx repeat + line.j ^= " " => return (SUBSTRING (line, j, nil))) + [key, :value] + + +--% +--% )undo +--% + +$undoFlag := true --Default setting for undo is "on" + + +undo(l) == +--undo takes one option ")redo" which simply reads "redo.input", +-- a file created by every normal )undo command (see below) + undoWhen := 'after + if $options is [[key]] then + stringPrefix?(s := PNAME key,'"redo") => + $options := nil --clear $options so that "read" won't see them + read '(redo_.input) + not stringPrefix?(s,'"before") => + userError '"only option to undo is _")redo_"" + undoWhen := 'before + n := + null l => -1 + first l + if IDENTP n then + n := PARSE_-INTEGER PNAME n + if not FIXP n then userError '"undo argument must be an integer" + $InteractiveFrame := undoSteps(undoCount n,undoWhen) + nil + +recordFrame(systemNormal) == + null $undoFlag => nil --do nothing if facility is turned off + currentAlist := KAR $frameRecord + delta := diffAlist(CAAR $InteractiveFrame,$previousBindings) + if systemNormal = 'system then + null delta => return nil --do not record + delta := ['systemCommand,:delta] + $frameRecord := [delta,:$frameRecord] + $previousBindings := --copy all but the individual properties + [CONS(CAR x,[CONS(CAR y,CDR y) for y in CDR x]) for x in CAAR $InteractiveFrame] + first $frameRecord + +diffAlist(new,old) == +--record only those properties which are different + for (pair := [name,:proplist]) in new repeat + -- name has an entry both in new and old world + -- (1) if the old world had no proplist for that variable, then + -- record NIL as the value of each new property + -- (2) if the old world does have a proplist for that variable, then + -- a) for each property with a value: give the old value + -- b) for each property missing: give NIL as the old value + oldPair := ASSQ(name,old) => + null (oldProplist := CDR oldPair) => + --record old values of new properties as NIL + acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] + deltas := nil + for (propval := [prop,:val]) in proplist repeat + null (oldPropval := assoc(prop,oldProplist)) => --missing property + deltas := [[prop],:deltas] + EQ(CDR oldPropval,val) => 'skip + deltas := [oldPropval,:deltas] + deltas => acc := [[name,:NREVERSE deltas],:acc] + acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] +--record properties absent on new list (say, from a )cl all) + for (oldPair := [name,:r]) in old repeat + r and null LASSQ(name,new) => + acc := [oldPair,:acc] + -- name has an entry both in new and old world + -- (1) if the new world has no proplist for that variable + -- (a) if the old world does, record the old proplist + -- (b) if the old world does not, record nothing + -- (2) if the new world has a proplist for that variable, it has + -- been handled by the first loop. + res := NREVERSE acc + if BOUNDP '$reportUndo and $reportUndo then reportUndo res + res + +reportUndo acc == + for [name,:proplist] in acc repeat + sayBrightly STRCONC("Properties of ",PNAME name,'" ::") + curproplist := LASSOC(name,CAAR $InteractiveFrame) + for [prop,:value] in proplist repeat + sayBrightlyNT ['" ",prop,'" was: "] + pp value + sayBrightlyNT ['" ",prop,'" is: "] + pp LASSOC(prop,curproplist) + +clearFrame() == + clearCmdAll() + $frameRecord := nil + $previousBindings := nil + + +--======================================================================= +-- Undoing previous m commands +--======================================================================= +undoCount(n) == --computes the number of undo's, given $IOindex +--pp ["IOindex = ",$IOindex] + m := + n >= 0 => $IOindex - n - 1 + -n + m >= $IOindex => userError STRCONC('"Magnitude of undo argument must be less than step number (",STRINGIMAGE $IOindex,'").") + m + + +undoSteps(m,beforeOrAfter) == +-- undoes m previous commands; if )before option, then undo one extra at end +--Example: if $IOindex now is 6 and m = 2 then general layout of $frameRecord, +-- after the call to recordFrame below will be: +-- ( +-- ( +-- ( +-- ( +-- +-- ) where system +-- command entries are optional and identified by (systemCommand . change). +-- For a ")undo 3 )after", m = 2 and undoStep swill restore the environment +-- up to, but not including . +-- An "undo 3 )before" will additionally restore . +-- Thus, the later requires one extra undo at the end. + writeInputLines('redo,$IOindex - m) + recordFrame('normal) --do NOT mark this as a system command change + --do this undo FIRST (i=0 case) + env := COPY CAAR $InteractiveFrame + for i in 0..m for framelist in tails $frameRecord repeat + env := undoSingleStep(first framelist,env) + framelist is [.,['systemCommand,:systemDelta],:.] => +-- pp '"===============> AHA <=============" + framelist := rest framelist --undoing system commands given + env := undoSingleStep(systemDelta,env) -- before command line + lastTailSeen := framelist + if beforeOrAfter = 'before then --do one additional undo for )before + env := undoSingleStep(first rest lastTailSeen,env) + $frameRecord := rest $frameRecord --flush the effect of extra recordFrame + $InteractiveFrame := LIST LIST env + + +undoSingleStep(changes,env) == +--Each change is a name-proplist pair. For each change: +-- (1) if there exists a proplist in env, then for each prop-value change: +-- (a) if the prop exists in env, RPLAC in the change value +-- (b) otherwise, CONS it onto the front of prop-values for that name +-- (2) add change to the front of env +-- pp '"----Undoing 1 step--------" +-- pp changes + for (change := [name,:changeList]) in changes repeat + if LASSOC('localModemap,changeList) then + changeList := undoLocalModemapHack changeList + pairlist := ASSQ(name,env) => + proplist := CDR pairlist => + for (pair := [prop,:value]) in changeList repeat + node := ASSQ(prop,proplist) => RPLACD(node,value) + RPLACD(proplist,[CAR proplist,:CDR proplist]) + RPLACA(proplist,pair) + RPLACD(pairlist,changeList) + env := [change,:env] + env + +undoLocalModemapHack changeList == + [newPair for (pair := [name,:value]) in changeList | newPair] where newPair() == + name = 'localModemap => [name] + pair + +removeUndoLines u == --called by writeInputLines + xtra := + STRINGP $currentLine => [$currentLine] + REVERSE $currentLine + xtra := [x for x in xtra | not stringPrefix?('")history",x)] + u := [:u, :xtra] + not (or/[stringPrefix?('")undo",x) for x in u]) => u + --(1) reverse the list + --(2) walk down the (reversed) list: when >n appears remove: + -- (a) system commands + -- (b) if n > 0: (replace n by n-1; remove a command; repeat (a-b)) + savedIOindex := $IOindex --save value + $IOindex := 1 + for y in tails u repeat + (x := first y).0 = char '_) => + stringPrefix?('")undo",s := trimString x) => --parse "undo )option" + s1 := trimString SUBSTRING(s,5,nil) + if s1 ^= '")redo" then + m := charPosition(char '_),s1,0) + code := + m < MAXINDEX s1 => s1.(m + 1) + char 'a + s2 := trimString SUBSTRING(s1,0,m) + n := + s1 = '")redo" => 0 + s2 ^= '"" => undoCount PARSE_-INTEGER s2 + -1 + RPLACA(y,CONCAT('">",code,STRINGIMAGE n)) + nil + $IOindex := $IOindex + 1 --referenced by undoCount + acc := nil + for y in tails NREVERSE u repeat + (x := first y).0 = char '_> => + code := x . 1 --code = a,b, or r + n := PARSE_-INTEGER SUBSTRING(x,2,nil) --n = number of undo steps + y := rest y --kill >n line + while y repeat + c := first y + c.0 = char '_) or c.0 = char '_> => y := rest y --kill system commands + n = 0 => return nil --including undos + n := n - 1 + y := rest y --kill command + y and code^= char 'b => acc := [c,:acc] --add last unless )before + acc := [x,:acc] + $IOindex := savedIOindex + acc + + + + +--% )what + + +what l == whatSpad2Cmd l + +whatSpad2Cmd l == + $e:local := $EmptyEnvironment + null l => reportWhatOptions() + [key0,:args] := l + key := selectOptionLC(key0,$whatOptions,nil) + null key => sayKeyedMsg("S2IZ0043",NIL) + args := [fixpat p for p in args] where + fixpat x == + x is [x',:.] => DOWNCASE x' + DOWNCASE x + key = 'things => + for opt in $whatOptions repeat + not MEMQ(opt,'(things)) => whatSpad2Cmd [opt,:args] + key = 'categories => + filterAndFormatConstructors('category,'"Categories",args) + key = 'commands => + whatCommands(args) + key = 'domains => + filterAndFormatConstructors('domain,'"Domains",args) + key = 'operations => + apropos args + key = 'packages => + filterAndFormatConstructors('package,'"Packages",args) + key = 'synonyms => + printSynonyms(args) + +filterAndFormatConstructors(constrType,label,patterns) == + centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) + l := filterListOfStringsWithFn(patterns,whatConstructors constrType, + function CDR) + if patterns then + null l => + sayMessage ['" No ",label,'" with names matching patterns:", + '%l,'" ",'%b,:blankList patterns,'%d] + sayMessage [label,'" with names matching patterns:", + '%l,'" ",'%b,:blankList patterns,'%d] + l => pp2Cols l + +whatConstructors constrType == + -- here constrType should be one of 'category, 'domain, 'package + MSORT [CONS(GETDATABASE(con,'ABBREVIATION), STRING(con)) + for con in allConstructors() + | GETDATABASE(con,'CONSTRUCTORKIND) = constrType] + +apropos l == + -- l is a list of operation name fragments + -- this displays all operation names containing these fragments + ops := + null l => allOperations() + filterListOfStrings([(DOWNCASE STRINGIMAGE p) for p in l],allOperations()) + ops => + sayMessage '"Operations whose names satisfy the above pattern(s):" + sayAsManyPerLineAsPossible MSORT ops + sayKeyedMsg("S2IF0011",[first ops]) + sayMessage '" There are no operations containing those patterns" + NIL + + +printSynonyms(patterns) == + centerAndHighlight("System Command Synonyms",$LINELENGTH,specialChar 'hbar) + ls := filterListOfStringsWithFn(patterns, [[STRINGIMAGE a,:b] + for [a,:b] in synonymsForUserLevel $CommandSynonymAlist], + function CAR) + printLabelledList(ls,'"user",'"synonyms",'")",patterns) + nil + +printLabelledList(ls,label1,label2,prefix,patterns) == + -- prefix goes before each element on each side of the list, eg, + -- ")" + null ls => + null patterns => + sayMessage ['" No ",label1,'"-defined ",label2,'" in effect."] + sayMessage ['" No ",label1,'"-defined ",label2,'" satisfying patterns:", + '%l,'" ",'%b,:blankList patterns,'%d] + if patterns then + sayMessage [label1,'"-defined ",label2,'" satisfying patterns:", + '%l,'" ",'%b,:blankList patterns,'%d] + for [syn,:comm] in ls repeat + if SUBSTRING(syn,0,1) = '"|" then syn := SUBSTRING(syn,1,NIL) + if syn = '"%i" then syn := '"%i " + wid := MAX(30 - (entryWidth syn),1) + sayBrightly concat('%b,prefix,syn,'%d, + fillerSpaces(wid,'"."),'" ",prefix,comm) + sayBrightly '"" + +whatCommands(patterns) == + label := STRCONC("System Commands for User Level: ", + STRINGIMAGE $UserLevel) + centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) + l := filterListOfStrings(patterns, + [(STRINGIMAGE a) for a in commandsForUserLevel $systemCommands]) + if patterns then + null l => + sayMessage ['"No system commands at this level matching patterns:", + '%l,'" ",'%b,:blankList patterns,'%d] + sayMessage ['"System commands at this level matching patterns:", + '%l,'" ",'%b,:blankList patterns,'%d] + if l then + sayAsManyPerLineAsPossible l + SAY " " + patterns => nil -- don't be so verbose + sayKeyedMsg("S2IZ0046",NIL) + nil + +reportWhatOptions() == + optList1:= "append"/[['%l,'" ",x] for x in $whatOptions] + sayBrightly + ['%b,'" )what",'%d,'"argument keywords are",'%b,:optList1,'%d,'%l, + '" or abbreviations thereof.",'%l, + '%l,'" Issue",'%b,'")what ?",'%d,'"for more information."] + +filterListOfStrings(patterns,names) == + -- names and patterns are lists of strings + -- returns: list of strings in names that contains any of the strings + -- in patterns + (null patterns) or (null names) => names + names' := NIL + for name in reverse names repeat + satisfiesRegularExpressions(name,patterns) => + names' := [name,:names'] + names' + +filterListOfStringsWithFn(patterns,names,fn) == + -- names and patterns are lists of strings + -- fn is something like CAR or CADR + -- returns: list of strings in names that contains any of the strings + -- in patterns + (null patterns) or (null names) => names + names' := NIL + for name in reverse names repeat + satisfiesRegularExpressions(FUNCALL(fn,name),patterns) => + names' := [name,:names'] + names' + +satisfiesRegularExpressions(name,patterns) == + -- this is a first cut + nf := true + dname := DOWNCASE COPY name + for pattern in patterns while nf repeat + -- use @ as a wildcard + STRPOS(pattern,dname,0,'"@") => nf := nil + null nf + +--% )with ... defined in daase.lisp (boot won't parse it) + +--% )workfiles + +workfiles l == workfilesSpad2Cmd l + +workfilesSpad2Cmd args == + args => throwKeyedMsg("S2IZ0047",NIL) + deleteFlag := nil + for [type,:.] in $options repeat + type1 := selectOptionLC(type,'(boot lisp meta delete),nil) + null type1 => throwKeyedMsg("S2IZ0048",[type]) + type1 = 'delete => deleteFlag := true + for [type,:flist] in $options repeat + type1 := selectOptionLC(type,'(boot lisp meta delete),nil) + type1 = 'delete => nil + for file in flist repeat + fl := pathname [file,type1,'"*"] + deleteFlag => SETQ($sourceFiles,delete(fl,$sourceFiles)) + null (MAKE_-INPUT_-FILENAME fl) => sayKeyedMsg("S2IZ0035",[namestring fl]) + updateSourceFiles fl + SAY " " + centerAndHighlight(" User-specified work files ",$LINELENGTH,specialChar 'hbar) + SAY " " + null $sourceFiles => SAY '" no files specified" + SETQ($sourceFiles,SORTBY('pathnameType,$sourceFiles)) + for fl in $sourceFiles repeat sayBrightly [" " ,namestring fl] + +--% )zsystemdevelopment + +zsystemdevelopment l == zsystemDevelopmentSpad2Cmd l + +zsystemDevelopmentSpad2Cmd l == zsystemdevelopment1 (l,$InteractiveMode) + +zsystemdevelopment1(l,im) == + $InteractiveMode : local := im + fromopt := nil + -- cycle through once to see if )from is mentioned + for [opt,:optargs] in $options repeat + opt1 := selectOptionLC(opt,'(from),nil) + opt1 = 'from => fromopt := [['FROM,:optargs]] + for [opt,:optargs] in $options repeat + if null optargs then optargs := l + newopt := APPEND(optargs,fromopt) + opt1 := selectOptionLC(opt,'(from),nil) + opt1 = 'from => nil + opt = "c" => _/D_,1 (newopt ,_/COMP(),NIL,NIL) + opt = "d" => _/D_,1 (newopt ,'DEFINE,NIL,NIL) + opt = "dt" => _/D_,1 (newopt ,'DEFINE,NIL,true) + opt = "ct" => _/D_,1 (newopt ,_/COMP(),NIL,true) + opt = "ctl" => _/D_,1 (newopt ,_/COMP(),NIL,'TRACELET) + opt = "ec" => _/D_,1 (newopt ,_/COMP(),true,NIL) + opt = "ect" => _/D_,1 (newopt ,_/COMP(),true,true) + opt = "e" => _/D_,1 (newopt ,NIL,true,NIL) + opt = "version" => version() + opt = "pause" => + conStream := DEFIOSTREAM ('((DEVICE . CONSOLE) (QUAL . V)),120,0) + NEXT conStream + SHUT conStream + opt = "update" or opt = "patch" => + $InteractiveMode := nil + upf := [KAR optargs or _/VERSION, KADR optargs or _/WSNAME, + KADDR optargs or '_*] + fun := (opt = "patch" => '_/UPDATE_-LIB_-1; '_/UPDATE_-1) + CATCH('FILENAM, FUNCALL(fun, upf)) + sayMessage '" Update/patch is completed." + null optargs => + sayBrightly ['" An argument is required for",:bright opt] + sayMessage ['" Unknown option:",:bright opt," ",'%l, + '" Available options are", _ + :bright '"c ct e ec ect cls pause update patch compare record"] + +--% Synonym File Reader + +--------------------> NEW DEFINITION (override in util.lisp.pamphlet) +processSynonyms() == + p := STRPOS('")",LINE,0,NIL) + fill := '"" + if p + then + line := SUBSTRING(LINE,p,NIL) + if p > 0 then fill := SUBSTRING(LINE,0,p) + else + p := 0 + line := LINE + to := STRPOS ('" ", line, 1, nil) + if to then to := to - 1 + synstr := SUBSTRING (line, 1, to) + syn := STRING2ID_-N (synstr, 1) + null (fun := LASSOC (syn, $CommandSynonymAlist)) => NIL + to := STRPOS('")",fun,1,NIL) + if to and to ^= SIZE(fun)-1 then + opt := STRCONC('" ",SUBSTRING(fun,to,NIL)) + fun := SUBSTRING(fun,0,to-1) + else opt := '" " + if (SIZE synstr) > (SIZE fun) then + for i in (SIZE fun)..(SIZE synstr) repeat + fun := CONCAT (fun, '" ") +-- $currentLine := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) + cl := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) + SETQ(LINE,cl) + SETQ(CHR,LINE.(p+1)) + processSynonyms () + +-- functions for interfacing to system commands from algebra code +-- common lisp dependent + +tabsToBlanks s == + k := charPosition($charTab,s,0) + n := #s + k < n => + k = 0 => tabsToBlanks SUBSTRING(s,1,nil) + STRCONC(SUBSTRING(s,0,k),$charBlank, tabsToBlanks SUBSTRING(s,k + 1,nil)) + s + +doSystemCommand string == + string := CONCAT('")", EXPAND_-TABS string) + LINE: fluid := string + processSynonyms() + string := LINE + string:=SUBSTRING(string,1,nil) + string = '"" => nil + tok:=getFirstWord(string) + tok => + unab := unAbbreviateKeyword tok + member(unab, $noParseCommands) => + handleNoParseCommands(unab, string) + optionList := splitIntoOptionBlocks string + member(unab, $tokenCommands) => + handleTokensizeSystemCommands(unab, optionList) + handleParsedSystemCommands(unab, optionList) + nil + nil + +handleNoParseCommands(unab, string) == + string := stripSpaces string + spaceIndex := SEARCH('" ", string) + unab = "lisp" => + if (null spaceIndex) then + sayKeyedMsg("S2IV0005", NIL) + nil + else nplisp(stripLisp string) + unab = "boot" => + if (null spaceIndex) then + sayKeyedMsg("S2IV0005", NIL) + nil + else npboot(SUBSEQ(string, spaceIndex+1)) + unab = "system" => + if (null spaceIndex) then + sayKeyedMsg("S2IV0005", NIL) + nil + else npsystem(unab, string) + unab = "synonym" => + npsynonym(unab, (null spaceIndex => '""; SUBSEQ(string, spaceIndex+1))) + null spaceIndex => + FUNCALL unab + member(unab, '( quit _ + fin _ + pquit _ + credits _ + copyright )) => + sayKeyedMsg("S2IV0005", NIL) + nil + funName := INTERN CONCAT('"np",STRING unab) + FUNCALL(funName, SUBSEQ(string, spaceIndex+1)) + + +npboot str == + sex := string2BootTree str + FORMAT(true, '"~&~S~%", sex) + $ans := EVAL sex + FORMAT(true, '"~&Value = ~S~%", $ans) + +stripLisp str == + found := false + strIndex := 0 + lispStr := '"lisp" + for c0 in 0..#str-1 for c1 in 0..#lispStr-1 repeat + (char str.c0) ^= (char lispStr.c1) => + return nil + strIndex := c0+1 + SUBSEQ(str, strIndex) + + +nplisp str == + $ans := EVAL READ_-FROM_-STRING str + FORMAT(true, '"~&Value = ~S~%", $ans) + +npsystem(unab, str) == + spaceIndex := SEARCH('" ", str) + null spaceIndex => + sayKeyedMsg('"S2IZ0080", [str]) + sysPart := SUBSEQ(str, 0, spaceIndex) + -- The following is a hack required by the fact that unAbbreviateKeyword + -- returns the word "system" for unknown words + null SEARCH(sysPart, STRING unab) => + sayKeyedMsg('"S2IZ0080", [sysPart]) + command := SUBSEQ(str, spaceIndex+1) + OBEY command + +npsynonym(unab, str) == + npProcessSynonym(str) + +tokenSystemCommand(unabr, tokList) == + systemCommand tokList + +tokTran tok == + STRINGP tok => + #tok = 0 => nil + isIntegerString tok => READ_-FROM_-STRING tok + STRING tok.0 = '"_"" => + SUBSEQ(tok, 1, #tok-1) + INTERN tok + tok + +isIntegerString tok == + for i in 0..#tok-1 repeat + val := DIGIT_-CHAR_-P tok.i + not val => return nil + val + +splitIntoOptionBlocks str == + inString := false + optionBlocks := nil + blockStart := 0 + parenCount := 0 + for i in 0..#str-1 repeat + STRING str.i = '"_"" => + inString := not inString + if STRING str.i = '"(" and not inString + then parenCount := parenCount + 1 + if STRING str.i = '")" and not inString + then parenCount := parenCount - 1 + STRING str.i = '")" and not inString and parenCount = -1 => + block := stripSpaces SUBSEQ(str, blockStart, i) + blockList := [block, :blockList] + blockStart := i+1 + parenCount := 0 + blockList := [stripSpaces SUBSEQ(str, blockStart), :blockList] + nreverse blockList + +dumbTokenize str == + -- split into tokens delimted by spaces, taking quoted strings into account + inString := false + tokenList := nil + tokenStart := 0 + previousSpace := false + for i in 0..#str-1 repeat + STRING str.i = '"_"" => + inString := not inString + previousSpace := false + STRING str.i = '" " and not inString => + previousSpace => nil + token := stripSpaces SUBSEQ(str, tokenStart, i) + tokenList := [token, :tokenList] + tokenStart := i+1 + previousSpace := true + previousSpace := false + tokenList := [stripSpaces SUBSEQ(str, tokenStart), :tokenList] + nreverse tokenList + +handleParsedSystemCommands(unabr, optionList) == + restOptionList := [dumbTokenize opt for opt in CDR optionList] + parcmd := [parseSystemCmd CAR optionList, + :[[tokTran tok for tok in opt] for opt in restOptionList]] + systemCommand parcmd + +parseSystemCmd opt == + spaceIndex := SEARCH('" ", opt) + spaceIndex => + commandString := stripSpaces SUBSEQ(opt, 0, spaceIndex) + argString := stripSpaces SUBSEQ(opt, spaceIndex) + command := tokTran commandString + pform := parseFromString argString + [command, pform] + [tokTran tok for tok in dumbTokenize opt] + +--------------------> NEW DEFINITION (override in osyscmd.boot.pamphlet) +parseFromString(s) == + $useNewParser => + ncParseFromString s + $InteractiveMode :local := true + $BOOT: local := NIL + $SPAD: local := true + $e:local := $InteractiveFrame + string2SpadTree s + +handleTokensizeSystemCommands(unabr, optionList) == + optionList := [dumbTokenize opt for opt in optionList] + parcmd := [[tokTran tok for tok in opt] for opt in optionList] + parcmd => tokenSystemCommand(unabr, parcmd) + +getFirstWord string == + spaceIndex := SEARCH('" ", string) + null spaceIndex => string + stripSpaces SUBSEQ(string, 0, spaceIndex) + +ltrace l == trace l + +--------------------> NEW DEFINITION (see intint.lisp.pamphlet) +stripSpaces str == + STRING_-TRIM([char '" "], str) + +npProcessSynonym(str) == + if str = '"" then printSynonyms(NIL) + else + pair := processSynonymLine str + if $CommandSynonymAlist then + PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) + else $CommandSynonymAlist := [pair] + terminateSystemCommand() + + + + diff --git a/src/interp/i-syscmd.boot.pamphlet b/src/interp/i-syscmd.boot.pamphlet deleted file mode 100644 index 37eb1209..00000000 --- a/src/interp/i-syscmd.boot.pamphlet +++ /dev/null @@ -1,3203 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-syscmd.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -This file contains the BOOT code for the Axiom system command -and synonym processing facility. The code for )trace is in the file -TRACE BOOT. The list of system commands is $SYSCOMMANDS which is -initialized in SETQ LISP. - -\end{verbatim} - -\section{Filenames change} - -It appears that probe-file is now case-sensitive. In order to get around -this we include the file extensions in both upper and lower case in the -search lists. Lower case names are preferred. - -\section{handleNoParseCommands} - -The system commands given by the global variable -[[|$noParseCommands|]]\cite{1} require essentially no -preprocessing/parsing of their arguments. Here we dispatch the -functions which implement these commands. - -There are four standard commands which receive arguments -- [[lisp]], -[[synonym]], [[system]] and [[boot]]. There are five standard commands -which do not receive arguments -- [[quit]], [[fin]], [[pquit]], -[[credits]] and [[copyright]]. As these commands do not necessarily -exhaust those mentioned in [[|$noParseCommands|]], we provide a -generic dispatch based on two conventions: commands which do not -require an argument name themselves, those which do have their names -prefixed by [[np]]. - -<>= -handleNoParseCommands(unab, string) == - string := stripSpaces string - spaceIndex := SEARCH('" ", string) - unab = "lisp" => - if (null spaceIndex) then - sayKeyedMsg("S2IV0005", NIL) - nil - else nplisp(stripLisp string) - unab = "boot" => - if (null spaceIndex) then - sayKeyedMsg("S2IV0005", NIL) - nil - else npboot(SUBSEQ(string, spaceIndex+1)) - unab = "system" => - if (null spaceIndex) then - sayKeyedMsg("S2IV0005", NIL) - nil - else npsystem(unab, string) - unab = "synonym" => - npsynonym(unab, (null spaceIndex => '""; SUBSEQ(string, spaceIndex+1))) - null spaceIndex => - FUNCALL unab - member(unab, '( quit _ - fin _ - pquit _ - credits _ - copyright )) => - sayKeyedMsg("S2IV0005", NIL) - nil - funName := INTERN CONCAT('"np",STRING unab) - FUNCALL(funName, SUBSEQ(string, spaceIndex+1)) - -@ -\section{TRUENAME change} -This change was made to make the open source Axiom work with the -new aldor compiler.z -This used to read: -\begin{verbatim} - STRCONC(TRUENAME(STRCONC(GETENV('"AXIOM"),'"/compiler/bin/")),"axiomxl ", asharpArgs, '" ", namestring args) -\end{verbatim} -but now reads: -<>= - STRCONC(STRCONC(GETENV('"ALDORROOT"),'"/bin/"),_ - "aldor ", asharpArgs, '" ", namestring args) -@ -Notice that we've introduced the [[ALDORROOT]] shell variable. -This will have to be pushed down from the top level Makefile. - -\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. - -@ -<<*>>= -<> - -import '"i-object" -)package "BOOT" - ---% Utility Variable Initializations - -$cacheAlist := nil -$compileRecurrence := true -$errorReportLevel := 'warning -$sourceFileTypes := '(INPUT SPAD BOOT LISP LISP370 META) - -$SYSCOMMANDS := [CAR x for x in $systemCommands] - -UNDERBAR == '"__" - - -$whatOptions := '( _ - operations _ - categories _ - domains _ - packages _ - commands _ - synonyms _ - things _ - ) - -$clearOptions := '( _ - modes _ - operations _ - properties _ - types _ - values _ - ) - -$displayOptions := '( _ - abbreviations _ - all _ - macros _ - modes _ - names _ - operations _ - properties _ - types _ - values _ - ) - -$countAssoc := '( (cache countCache) ) - ---% Top level system command - -initializeSystemCommands() == - l := $systemCommands - $SYSCOMMANDS := NIL - while l repeat - $SYSCOMMANDS := CONS(CAAR l, $SYSCOMMANDS) - l := CDR l - $SYSCOMMANDS := NREVERSE $SYSCOMMANDS - -systemCommand [[op,:argl],:options] == - $options: local:= options - $e:local := $CategoryFrame - fun := selectOptionLC(op,$SYSCOMMANDS,'commandError) - argl and (argl.0 = '_?) and fun ^= 'synonym => - helpSpad2Cmd [fun] - fun := selectOption(fun,commandsForUserLevel $systemCommands, - 'commandUserLevelError) - FUNCALL(fun, argl) - -commandsForUserLevel l == --[a for [a,:b] in l | satisfiesUserLevel(a)] - c := nil - for [a,:b] in l repeat - satisfiesUserLevel b => c := [a,:c] - reverse c - -synonymsForUserLevel l == - -- l is a list of synonyms, and this returns a sublist of applicable - -- synonyms at the current user level. - $UserLevel = 'development => l - nl := NIL - for syn in reverse l repeat - cmd := STRING2ID_-N(CDR syn,1) - null selectOptionLC(cmd,commandsForUserLevel - $systemCommands,NIL) => nil - nl := [syn,:nl] - nl - -satisfiesUserLevel x == - x = 'interpreter => true - $UserLevel = 'interpreter => false - x = 'compiler => true - $UserLevel = 'compiler => false - true - -unAbbreviateKeyword x == - x' :=selectOptionLC(x,$SYSCOMMANDS,'commandErrorIfAmbiguous) - if not x' then - x' := 'system - SETQ(LINE, CONCAT('")system ", SUBSTRING(LINE, 1, #LINE-1))) - $currentLine := LINE - selectOption(x',commandsForUserLevel $systemCommands, - 'commandUserLevelError) - -hasOption(al,opt) == - optPname:= PNAME opt - found := NIL - for pair in al while not found repeat - stringPrefix?(PNAME CAR pair,optPname) => found := pair - found - -selectOptionLC(x,l,errorFunction) == - selectOption(DOWNCASE object2Identifier x,l,errorFunction) - -selectOption(x,l,errorFunction) == - member(x,l) => x --exact spellings are always OK - null IDENTP x => - errorFunction => FUNCALL(errorFunction,x,u) - nil - u := [y for y in l | stringPrefix?(PNAME x,PNAME y)] - u is [y] => y - errorFunction => FUNCALL(errorFunction,x,u) - nil - -terminateSystemCommand() == TERSYSCOMMAND() - -commandUserLevelError(x,u) == userLevelErrorMessage("command",x,u) - -optionUserLevelError(x,u) == userLevelErrorMessage("option",x,u) - -userLevelErrorMessage(kind,x,u) == - null u => - sayKeyedMsg("S2IZ0007",[$UserLevel,kind]) - terminateSystemCommand() - commandAmbiguityError(kind,x,u) - -commandError(x,u) == commandErrorMessage("command",x,u) - -optionError(x,u) == commandErrorMessage("option",x,u) - -commandErrorIfAmbiguous(x, u) == - null u => nil - SETQ($OLDLINE, LINE) - commandAmbiguityError("command", x, u) - -commandErrorMessage(kind,x,u) == - SETQ ($OLDLINE,LINE) - null u => - sayKeyedMsg("S2IZ0008",[kind,x]) - terminateSystemCommand() - commandAmbiguityError(kind,x,u) - -commandAmbiguityError(kind,x,u) == - sayKeyedMsg("S2IZ0009",[kind,x]) - for a in u repeat sayMSG ['" ",:bright a] - terminateSystemCommand() - ---% Utility for access to original command line - -getSystemCommandLine() == - p := STRPOS('")",$currentLine,0,NIL) - line := if p then SUBSTRING($currentLine,p,NIL) else $currentLine - maxIndex:= MAXINDEX line - for i in 0..maxIndex while (line.i^=" ") repeat index:= i - if index=maxIndex then line := '"" - else line := SUBSTRING(line,index+2,nil) - line - ------------- start of commands ------------------------------------------ - ---% )abbreviations - -abbreviations l == abbreviationsSpad2Cmd l - -abbreviationsSpad2Cmd l == - null l => helpSpad2Cmd '(abbreviations) - abopts := '(query domain category package remove) - - quiet := nil - for [opt] in $options repeat - opt := selectOptionLC(opt,'(quiet),'optionError) - opt = 'quiet => quiet := true - - l is [opt,:al] => - key := opOf CAR al - type := selectOptionLC(opt,abopts,'optionError) - type is 'query => - null al => listConstructorAbbreviations() - constructor := abbreviation?(key) => abbQuery(constructor) - abbQuery(key) - type is 'remove => - DELDATABASE(key,'ABBREVIATION) - ODDP SIZE al => sayKeyedMsg("S2IZ0002",[type]) - repeat - null al => return 'fromLoop - [a,b,:al] := al - mkUserConstructorAbbreviation(b,a,type) - SETDATABASE(b,'ABBREVIATION,a) - SETDATABASE(b,'CONSTRUCTORKIND,type) - null quiet => - sayKeyedMsg("S2IZ0001",[a,type,opOf b]) - nil - nil - -listConstructorAbbreviations() == - x := UPCASE queryUserKeyedMsg("S2IZ0056",NIL) - MEMQ(STRING2ID_-N(x,1),'(Y YES)) => - whatSpad2Cmd '(categories) - whatSpad2Cmd '(domains) - whatSpad2Cmd '(packages) - sayKeyedMsg("S2IZ0057",NIL) - ---% )clear - -clear l == clearSpad2Cmd l - -clearSpad2Cmd l == - -- new version which changes the environment and updates history - $clearExcept: local := nil - if $options then $clearExcept := - "and"/[selectOptionLC(opt,'(except),'optionError) = - 'except for [opt,:.] in $options] - null l => - optList:= "append"/[['%l,'" ",x] for x in $clearOptions] - sayKeyedMsg("S2IZ0010",[optList]) - arg := selectOptionLC(first l,'(all completely scaches),NIL) - arg = 'all => clearCmdAll() - arg = 'completely => clearCmdCompletely() - arg = 'scaches => clearCmdSortedCaches() - $clearExcept => clearCmdExcept(l) - clearCmdParts(l) - updateCurrentInterpreterFrame() - -clearCmdSortedCaches() == - $lookupDefaults: local := false - for [.,.,:domain] in HGET($ConstructorCache,'SortedCache) repeat - pair := compiledLookupCheck('clearCache,[$Void],domain) - SPADCALL pair - -clearCmdCompletely() == - clearCmdAll() - $localExposureData := COPY_-SEQ $localExposureDataDefault - $xdatabase := NIL - $CatOfCatDatabase := NIL - $DomOfCatDatabase := NIL - $JoinOfCatDatabase := NIL - $JoinOfDomDatabase := NIL - $attributeDb := NIL - $functionTable := NIL - sayKeyedMsg("S2IZ0013",NIL) - clearClams() - clearConstructorCaches() - $existingFiles := MAKE_-HASHTABLE 'UEQUAL - sayKeyedMsg("S2IZ0014",NIL) - RECLAIM() - sayKeyedMsg("S2IZ0015",NIL) - NIL - -clearCmdAll() == - clearCmdSortedCaches() - ------undo special variables------ - $frameRecord := nil - $previousBindings := nil - $variableNumberAlist := nil - untraceMapSubNames _/TRACENAMES - $InteractiveFrame := LIST LIST NIL - resetInCoreHist() - if $useInternalHistoryTable - then $internalHistoryTable := NIL - else deleteFile histFileName() - $IOindex := 1 - updateCurrentInterpreterFrame() - $currentLine := '")clear all" --restored 3/94; needed for undo (RDJ) - clearMacroTable() - if $frameMessages then sayKeyedMsg("S2IZ0011",[$interpreterFrameName]) - else sayKeyedMsg("S2IZ0012",NIL) - -clearCmdExcept(l is [opt,:vl]) == - --clears elements of vl of all options EXCEPT opt - for option in $clearOptions | - ^stringPrefix?(object2String opt,object2String option) - repeat clearCmdParts [option,:vl] - -clearCmdParts(l is [opt,:vl]) == - -- clears the bindings indicated by opt of all variables in vl - - option:= selectOptionLC(opt,$clearOptions,'optionError) - option:= INTERN PNAME option - - -- the option can be plural but the key in the alist is sometimes - -- singular - - option := - option = 'types => 'mode - option = 'modes => 'mode - option = 'values => 'value - option - - null vl => sayKeyedMsg("S2IZ0055",NIL) - pmacs := getParserMacroNames() - imacs := getInterpMacroNames() - if vl='(all) then - vl := ASSOCLEFT CAAR $InteractiveFrame - vl := REMDUP(append(vl, pmacs)) - $e : local := $InteractiveFrame - for x in vl repeat - clearDependencies(x,true) - if option='properties and x in pmacs then clearParserMacro(x) - if option='properties and x in imacs and ^(x in pmacs) then - sayMessage ['" You cannot clear the definition of the system-defined macro ", - fixObjectForPrinting x,"."] - p1 := assoc(x,CAAR $InteractiveFrame) => - option='properties => - if isMap x then - (lm := get(x,'localModemap,$InteractiveFrame)) => - PAIRP lm => untraceMapSubNames [CADAR lm] - NIL - for p2 in CDR p1 repeat - prop:= CAR p2 - recordOldValue(x,prop,CDR p2) - recordNewValue(x,prop,NIL) - SETF(CAAR $InteractiveFrame,deleteAssoc(x,CAAR $InteractiveFrame)) - p2:= assoc(option,CDR p1) => - recordOldValue(x,option,CDR p2) - recordNewValue(x,option,NIL) - RPLACD(p2,NIL) - nil - ---% )close - -queryClients () == - -- Returns the number of active scratchpad clients - sockSendInt($SessionManager, $QueryClients) - sockGetInt $SessionManager - - -close args == - $saturn => - sayErrorly('"Obsolete system command", _ - ['" The )close system command is obsolete in this version of AXIOM.", - '" Please use Close from the File menu instead."]) - quiet:local:= false - null $SpadServer => - throwKeyedMsg('"S2IZ0071", []) - numClients := queryClients() - numClients > 1 => - sockSendInt($SessionManager, $CloseClient) - sockSendInt($SessionManager, $currentFrameNum) - closeInterpreterFrame(NIL) - for [opt,:.] in $options repeat - fullopt := selectOptionLC(opt, '(quiet), 'optionError) - fullopt = 'quiet => - quiet:=true - quiet => - sockSendInt($SessionManager, $CloseClient) - sockSendInt($SessionManager, $currentFrameNum) - closeInterpreterFrame(NIL) - x := UPCASE queryUserKeyedMsg('"S2IZ0072", nil) - MEMQ(STRING2ID_-N(x,1), '(YES Y)) => - BYE() - nil - ---% )constructor - -constructor args == - sayMessage '" Not implemented yet." - NIL - ---% )compiler - -compiler args == - $newConlist: local := nil --reset by compDefineLisplib and astran - null args and null $options and null _/EDITFILE => helpSpad2Cmd '(compiler) - if null args then args := [_/EDITFILE] - - -- first see if the user has explicitly specified the compiler - -- to use. - - optlist := '(new old translate constructor) - haveNew := nil - haveOld := nil - for opt in $options while ^(haveNew and haveOld) repeat - [optname,:optargs] := opt - fullopt := selectOptionLC(optname,optlist,nil) - fullopt = 'new => haveNew := true - fullopt = 'translate => haveOld := true - fullopt = 'constructor => haveOld := true - fullopt = 'old => haveOld := true - - haveNew and haveOld => throwKeyedMsg("S2IZ0081", nil) - - af := pathname args - aft := pathnameType af --- Whats this for? MCD/PAB 21-9-95 --- if haveNew and (null(aft) or (aft = '"")) then --- af := pathname [af, '"as"] --- aft = '"as" --- if haveOld and (null(aft) or (aft = '"")) then --- af := pathname [af, '"spad"] --- aft = '"spad" - - haveNew or (aft = '"as") => - not (af1 := $FINDFILE (af, '(as))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpCmd [af1] - haveOld or (aft = '"spad") => - not (af1 := $FINDFILE (af, '(spad))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileSpad2Cmd [af1] - aft = '"lsp" => - not (af1 := $FINDFILE (af, '(lsp))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpLispCmd [af1] - aft = '"NRLIB" => - not (af1 := $FINDFILE (af, '(NRLIB))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileSpadLispCmd [af1] - aft = '"ao" => - not (af1 := $FINDFILE (af, '(ao))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpCmd [af1] - aft = '"al" => -- archive library of .ao files - not (af1 := $FINDFILE (af, '(al))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpArchiveCmd [af1] - - -- see if we something with the appropriate file extension - -- lying around - - af1 := $FINDFILE (af, '(as spad ao asy)) - - af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] - af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] - af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] - af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] - - -- maybe /EDITFILE has some stuff that can help us - ef := pathname _/EDITFILE - ef := mergePathnames(af,ef) - - ef = af => throwKeyedMsg("S2IZ0039", nil) - af := ef - - pathnameType(af) = '"as" => compileAsharpCmd args - pathnameType(af) = '"ao" => compileAsharpCmd args - pathnameType(af) = '"spad" => compileSpad2Cmd args - - -- see if we something with the appropriate file extension - -- lying around - af1 := $FINDFILE (af, '(as spad ao asy)) - - af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] - af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] - af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] - af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] - - throwKeyedMsg("S2IZ0039", nil) - -compileAsharpCmd args == - compileAsharpCmd1 args - terminateSystemCommand() - spadPrompt() - -compileAsharpCmd1 args == - -- Assume we entered from the "compiler" function, so args ^= nil - -- and is a file with file extension .as or .ao - - path := pathname args - pathType := pathnameType path - (pathType ^= '"as") and (pathType ^= '"ao") => throwKeyedMsg("S2IZ0083", nil) - ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - SETQ(_/EDITFILE, path) - updateSourceFiles path - - optList := '( _ - new _ - old _ - translate _ - onlyargs _ - moreargs _ - quiet _ - nolispcompile _ - noquiet _ - library _ - nolibrary _ - ) - - beQuiet := false -- be verbose here - doLibrary := true -- so a )library after compilation - doCompileLisp := true -- do compile generated lisp code - - moreArgs := NIL - onlyArgs := NIL - - for opt in $options repeat - [optname,:optargs] := opt - fullopt := selectOptionLC(optname,optList,nil) - - fullopt = 'new => nil - fullopt = 'old => error "Internal error: compileAsharpCmd got )old" - fullopt = 'translate => error "Internal error: compileAsharpCmd got )translate" - - fullopt = 'quiet => beQuiet := true - fullopt = 'noquiet => beQuiet := false - - fullopt = 'nolispcompile => doCompileLisp := false - - fullopt = 'moreargs => moreArgs := optargs - fullopt = 'onlyargs => onlyArgs := optargs - - fullopt = 'library => doLibrary := true - fullopt = 'nolibrary => doLibrary := false - - throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) - - tempArgs := - pathType = '"ao" => - -- want to strip out -Fao - (p := STRPOS('"-Fao", $asharpCmdlineFlags, 0, NIL)) => - p = 0 => SUBSTRING($asharpCmdlineFlags, 5, NIL) - STRCONC(SUBSTRING($asharpCmdlineFlags, 0, p), '" ", - SUBSTRING($asharpCmdlineFlags, p+5, NIL)) - $asharpCmdlineFlags - $asharpCmdlineFlags - - asharpArgs := - onlyArgs => - s := "" - for a in onlyArgs repeat - s := STRCONC(s, '" ", object2String a) - s - moreArgs => - s := tempArgs - for a in moreArgs repeat - s := STRCONC(s, '" ", object2String a) - s - tempArgs - - if ^beQuiet then sayKeyedMsg("S2IZ0038A",[namestring args, asharpArgs]) - - command := -<> - rc := OBEY command - - if (rc = 0) and doCompileLisp then - lsp := fnameMake('".", pathnameName args, '"lsp") - if fnameReadable?(lsp) then - if ^beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) - compileFileQuietly(lsp) - else - sayKeyedMsg("S2IL0003", [namestring lsp]) - - if rc = 0 and doLibrary then - -- do we need to worry about where the compilation output went? - if ^beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) - withAsharpCmd [ pathnameName path ] - else if ^beQuiet then - sayKeyedMsg("S2IZ0084", nil) - - extendLocalLibdb $newConlist - -compileAsharpArchiveCmd args == - -- Assume we entered from the "compiler" function, so args ^= nil - -- and is a file with file extension .al. We also assume that - -- the name is fully qualified. - - path := pathname args - ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - -- here is the plan: - -- 1. extract the file name and try to make a directory based - -- on that name. - -- 2. cd to that directory and ar x the .al file - -- 3. for each .ao file that shows up, compile it - -- 4. delete the generated .ao files - - -- First try to make the directory in the current directory - - dir := fnameMake('".", pathnameName path, '"axldir") - exists := PROBE_-FILE dir - isDir := directoryp namestring dir - exists and isDir ^= 1=> - throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) - - if isDir ^= 1 then - cmd := STRCONC('"mkdir ", namestring dir) - rc := OBEY cmd - rc ^= 0 => throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) - - curDir := $CURRENT_-DIRECTORY - - -- cd to that directory and try to unarchive the .al file - - cd [ object2Identifier namestring dir ] - - cmd := STRCONC( '"ar x ", namestring path ) - rc := OBEY cmd - rc ^= 0 => - cd [ object2Identifier namestring curDir ] - throwKeyedMsg("S2IL0028",[namestring dir, namestring args]) - - -- Look for .ao files - - asos := DIRECTORY '"*.ao" - null asos => - cd [ object2Identifier namestring curDir ] - throwKeyedMsg("S2IL0029",[namestring dir, namestring args]) - - -- Compile the .ao files - - for aso in asos repeat - compileAsharpCmd1 [ namestring aso ] - - -- Reset the current directory - - cd [ object2Identifier namestring curDir ] - - terminateSystemCommand() - spadPrompt() - -compileAsharpLispCmd args == - -- Assume we entered from the "compiler" function, so args ^= nil - -- and is a file with file extension .lsp - - path := pathname args - ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - optList := '( _ - quiet _ - noquiet _ - library _ - nolibrary _ - ) - - beQuiet := false -- be verbose here - doLibrary := true -- so a )library after compilation - - for opt in $options repeat - [optname,:optargs] := opt - fullopt := selectOptionLC(optname,optList,nil) - - fullopt = 'quiet => beQuiet := true - fullopt = 'noquiet => beQuiet := false - - fullopt = 'library => doLibrary := true - fullopt = 'nolibrary => doLibrary := false - - throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) - - lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) - if fnameReadable?(lsp) then - if ^beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) - compileFileQuietly(lsp) - else - sayKeyedMsg("S2IL0003", [namestring lsp]) - - if doLibrary then - -- do we need to worry about where the compilation output went? - if ^beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) - withAsharpCmd [ pathnameName path ] - else if ^beQuiet then - sayKeyedMsg("S2IZ0084", nil) - terminateSystemCommand() - spadPrompt() - -compileSpadLispCmd args == - -- Assume we entered from the "compiler" function, so args ^= nil - -- and is a file with file extension .NRLIB - - path := pathname fnameMake(first args, '"code", '"lsp") - ^PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - optList := '( _ - quiet _ - noquiet _ - library _ - nolibrary _ - ) - - beQuiet := false -- be verbose here - doLibrary := true -- so a )library after compilation - - for opt in $options repeat - [optname,:optargs] := opt - fullopt := selectOptionLC(optname,optList,nil) - - fullopt = 'quiet => beQuiet := true - fullopt = 'noquiet => beQuiet := false - - fullopt = 'library => doLibrary := true - fullopt = 'nolibrary => doLibrary := false - - throwKeyedMsg("S2IZ0036",[STRCONC('")",object2String optname)]) - - lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) - if fnameReadable?(lsp) then - if ^beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) - --compileFileQuietly(lsp) - RECOMPILE_-LIB_-FILE_-IF_-NECESSARY lsp - else - sayKeyedMsg("S2IL0003", [namestring lsp]) - - if doLibrary then - -- do we need to worry about where the compilation output went? - if ^beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) - LOCALDATABASE([ pathnameName first args ],[]) - else if ^beQuiet then - sayKeyedMsg("S2IZ0084", nil) - terminateSystemCommand() - spadPrompt() - -withAsharpCmd args == - $options: local := nil - LOCALDATABASE(args, $options) - ---% )copyright -- display copyright notice - -summary l == - OBEY STRCONC ('"cat ", systemRootDirectory(),'"/lib/summary") - -copyright () == - OBEY STRCONC ('"cat ", systemRootDirectory(),'"/lib/copyright") - ---% )credits -- display credit list - -CREDITS := '( - "An alphabetical listing of contributors to AXIOM (to October, 2006):" - "Cyril Alberga Roy Adler Christian Aistleitner" - "Richard Anderson George Andrews" - "Henry Baker Stephen Balzac Yurij Baransky" - "David R. Barton Gerald Baumgartner Gilbert Baumslag" - "Fred Blair Vladimir Bondarenko Mark Botch" - "Alexandre Bouyer Peter A. Broadbery Martin Brock" - "Manuel Bronstein Florian Bundschuh Luanne Burns" - "William Burge" - "Quentin Carpent Robert Caviness Bruce Char" - "Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" - "Josh Cohen Christophe Conil Don Coppersmith" - "George Corliss Robert Corless Gary Cornell" - "Meino Cramer Claire Di Crescenzo" - "Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" - "Jean Della Dora Gabriel Dos Reis Michael Dewar" - "Claire DiCrescendo Sam Dooley Lionel Ducos" - "Martin Dunstan Brian Dupee Dominique Duval" - "Robert Edwards Heow Eide-Goodman Lars Erickson" - "Richard Fateman Bertfried Fauser Stuart Feldman" - "Brian Ford Albrecht Fortenbacher George Frances" - "Constantine Frangos Timothy Freeman Korrinn Fu" - "Marc Gaetano Rudiger Gebauer Kathy Gerber" - "Patricia Gianni Holger Gollan Teresa Gomez-Diaz" - "Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" - "Matt Grayson James Griesmer Vladimir Grinberg" - "Oswald Gschnitzer Jocelyn Guidry" - "Steve Hague Vilya Harvey Satoshi Hamaguchi" - "Martin Hassner Waldek Hebisch Ralf Hemmecke" - "Henderson Antoine Hersen" - "Pietro Iglio" - "Richard Jenks" - "Kai Kaminski Grant Keady Tony Kennedy" - "Paul Kosinski Klaus Kusche Bernhard Kutzler" - "Larry Lambe Frederic Lehobey Michel Levaud" - "Howard Levy Rudiger Loos Michael Lucks" - "Richard Luczak" - "Camm Maguire Bob McElrath Michael McGettrick" - "Ian Meikle David Mentre Victor S. Miller" - "Gerard Milmeister Mohammed Mobarak H. Michael Moeller" - "Michael Monagan Marc Moreno-Maza Scott Morrison" - "Mark Murray" - "William Naylor C. Andrew Neff John Nelder" - "Godfrey Nolan Arthur Norman Jinzhong Niu" - "Michael O'Connor Kostas Oikonomou" - "Julian A. Padget Bill Page Susan Pelzel" - "Michel Petitot Didier Pinchon Jose Alfredo Portes" - "Claude Quitte" - "Norman Ramsey Michael Richardson Renaud Rioboo" - "Jean Rivlin Nicolas Robidoux Simon Robinson" - "Michael Rothstein Martin Rubey" - "Philip Santas Alfred Scheerhorn William Schelter" - "Gerhard Schneider Martin Schoenert Marshall Schor" - "Frithjof Schulze Fritz Schwarz Nick Simicich" - "William Sit Elena Smirnova Jonathan Steinbach" - "Christine Sundaresan Robert Sutor Moss E. Sweedler" - "Eugene Surowitz" - "James Thatcher Balbir Thomas Mike Thomas" - "Dylan Thurston Barry Trager Themos T. Tsikas" - "Gregory Vanuxem" - "Bernhard Wall Stephen Watt Jaap Weel" - "Juergen Weiss M. Weller Mark Wegman" - "James Wen Thorsten Werther Michael Wester" - "John M. Wiley Berhard Will Clifton J. Williamson" - "Stephen Wilson Shmuel Winograd Robert Wisbauer" - "Sandra Wityak Waldemar Wiwianka Knut Wolf" - "Clifford Yapp David Yun" - "Richard Zippel Evelyn Zoernack Bruno Zuercher" - "Dan Zwillinger" - ) - -credits() == - for i in CREDITS repeat - PRINC(i) - TERPRI() - ---% )display - -display l == displaySpad2Cmd l - -displaySpad2Cmd l == - $e: local := $EmptyEnvironment - l is [opt,:vl] and opt ^= "?" => - option := selectOptionLC(opt,$displayOptions,'optionError) => - - -- the option may be given in the plural but the property in - -- the alist is sometimes singular - - option := - option = 'all => - l := ['properties] - 'properties - (option = 'modes) or (option = 'types) => - l := ['type, :vl] - 'type - option = 'values => - l := ['value, :vl] - 'value - option - - option = 'abbreviations => - null vl => listConstructorAbbreviations() - for v in vl repeat abbQuery(opOf v) - - option = 'operations => displayOperations vl - option = 'macros => displayMacros vl - option = 'names => displayWorkspaceNames() - displayProperties(option,l) - optList:= [:['%l,'" ",x] for x in $displayOptions] - msg := [:bright '" )display",'"keyword arguments are", - :bright optList,'%l,'" or abbreviations thereof."] - sayMessage msg - -displayMacros names == - imacs := getInterpMacroNames() - pmacs := getParserMacroNames() - macros := - null names => APPEND (imacs, pmacs) - names - macros := REMDUP macros - - null macros => sayBrightly '" There are no Axiom macros." - - -- first do user defined ones - - first := true - for macro in macros repeat - macro in pmacs => - if first then - sayBrightly ['%l,'"User-defined macros:"] - first := NIL - displayParserMacro macro - macro in imacs => 'iterate - sayBrightly ([" ",'%b, macro, '%d, " is not a known Axiom macro."]) - - -- now system ones - - first := true - for macro in macros repeat - macro in imacs => - macro in pmacs => 'iterate - if first then - sayBrightly ['%l,'"System-defined macros:"] - first := NIL - displayMacro macro - macro in pmacs => 'iterate - NIL - -getParserMacroNames() == - REMDUP [CAR mac for mac in getParserMacros()] - ---------------------> NEW DEFINITION (override in patches.lisp.pamphlet) -clearParserMacro(macro) == - -- first see if it is one - not IFCDR assoc(macro, ($pfMacros)) => NIL - $pfMacros := REMALIST($pfMacros, macro) - -displayMacro name == - m := isInterpMacro name - null m => - sayBrightly ['" ",:bright name,'"is not an interpreter macro."] - -- $op is needed in the output routines. - $op : local := STRCONC('"macro ",object2String name) - [args,:body] := m - args := - null args => nil - null rest args => first args - ['Tuple,:args] - mathprint ['MAP,[args,:body]] - -displayWorkspaceNames() == - imacs := getInterpMacroNames() - pmacs := getParserMacroNames() - sayMessage '"Names of User-Defined Objects in the Workspace:" - names := MSORT append(getWorkspaceNames(),pmacs) - if null names - then sayBrightly " * None *" - else sayAsManyPerLineAsPossible [object2String x for x in names] - imacs := SETDIFFERENCE(imacs,pmacs) - if imacs then - sayMessage '"Names of System-Defined Objects in the Workspace:" - sayAsManyPerLineAsPossible [object2String x for x in imacs] - - -getWorkspaceNames() == - NMSORT [n for [n,:.] in CAAR $InteractiveFrame | - (n ^= "--macros--" and n^= "--flags--")] - -displayOperations l == - null l => - x := UPCASE queryUserKeyedMsg("S2IZ0058",NIL) - if MEMQ(STRING2ID_-N(x,1),'(Y YES)) - then for op in allOperations() repeat reportOpSymbol op - else sayKeyedMsg("S2IZ0059",NIL) - nil - for op in l repeat reportOpSymbol op - -interpFunctionDepAlists() == - $e : local := $InteractiveFrame - deps := getFlag "$dependencies" - $dependentAlist := [[NIL,:NIL]] - $dependeeAlist := [[NIL,:NIL]] - for [dependee,dependent] in deps repeat - $dependentAlist := PUTALIST($dependentAlist,dependee, - CONS(dependent,GETALIST($dependentAlist,dependee))) - $dependeeAlist := PUTALIST($dependeeAlist,dependent, - CONS(dependee,GETALIST($dependeeAlist,dependent))) - -fixObjectForPrinting(v) == - v' := object2Identifier v - EQ(v',"%") => '"\%" - v' in $msgdbPrims => STRCONC('"\",PNAME v') - v - -displayProperties(option,l) == - $dependentAlist : local - $dependeeAlist : local - [opt,:vl]:= (l or ['properties]) - imacs := getInterpMacroNames() - pmacs := getParserMacroNames() - macros := REMDUP append(imacs, pmacs) - if vl is ['all] or null vl then - vl := MSORT append(getWorkspaceNames(),macros) - if $frameMessages then sayKeyedMsg("S2IZ0065",[$interpreterFrameName]) - null vl => - null $frameMessages => sayKeyedMsg("S2IZ0066",NIL) - sayKeyedMsg("S2IZ0067",[$interpreterFrameName]) - interpFunctionDepAlists() - for v in vl repeat - isInternalMapName(v) => 'iterate - pl := getIProplist(v) - option = 'flags => getAndSay(v,"flags") - option = 'value => displayValue(v,getI(v,'value),nil) - option = 'condition => displayCondition(v,getI(v,"condition"),nil) - option = 'mode => displayMode(v,getI(v,'mode),nil) - option = 'type => displayType(v,getI(v,'value),nil) - option = 'properties => - v = "--flags--" => nil - pl is [['cacheInfo,:.],:.] => nil - v1 := fixObjectForPrinting(v) - sayMSG ['"Properties of",:bright prefix2String v1,'":"] - null pl => - v in pmacs => - sayMSG '" This is a user-defined macro." - displayParserMacro v - isInterpMacro v => - sayMSG '" This is a system-defined macro." - displayMacro v - sayMSG '" none" - propsSeen:= nil - for [prop,:val] in pl | ^MEMQ(prop,propsSeen) and val repeat - prop in '(alias generatedCode IS_-GENSYM mapBody localVars) => - nil - prop = 'condition => - displayCondition(prop,val,true) - prop = 'recursive => - sayMSG '" This is recursive." - prop = 'isInterpreterFunction => - sayMSG '" This is an interpreter function." - sayFunctionDeps v where - sayFunctionDeps x == - if dependents := GETALIST($dependentAlist,x) then - null rest dependents => - sayMSG ['" The following function or rule ", - '"depends on this:",:bright first dependents] - sayMSG - '" The following functions or rules depend on this:" - msg := ["%b",'" "] - for y in dependents repeat msg := ['" ",y,:msg] - sayMSG [:nreverse msg,"%d"] - if dependees := GETALIST($dependeeAlist,x) then - null rest dependees => - sayMSG ['" This depends on the following function ", - '"or rule:",:bright first dependees] - sayMSG - '" This depends on the following functions or rules:" - msg := ["%b",'" "] - for y in dependees repeat msg := ['" ",y,:msg] - sayMSG [:nreverse msg,"%d"] - prop = 'isInterpreterRule => - sayMSG '" This is an interpreter rule." - sayFunctionDeps v - prop = 'localModemap => - displayModemap(v,val,true) - prop = 'mode => - displayMode(prop,val,true) - prop = 'value => - val => displayValue(v,val,true) - sayMSG ['" ",prop,'": ",val] - propsSeen:= [prop,:propsSeen] - sayKeyedMsg("S2IZ0068",[option]) - terminateSystemCommand() - -displayModemap(v,val,giveVariableIfNil) == - for mm in val repeat g(v,mm,giveVariableIfNil) where - g(v,mm,giveVariableIfNil) == - [[local,:signature],fn,:.]:= mm - local='interpOnly => nil - varPart:= (giveVariableIfNil => nil; ['" of",:bright v]) - prefix:= [" Compiled function type",:varPart,": "] - sayBrightly concat(prefix,formatSignature signature) - -displayMode(v,mode,giveVariableIfNil) == - null mode => nil - varPart:= (giveVariableIfNil => nil; [" of",:bright fixObjectForPrinting v]) - sayBrightly concat(" Declared type or mode", - varPart,": ",prefix2String mode) - -displayCondition(v,condition,giveVariableIfNil) == - varPart:= (giveVariableIfNil => nil; [" of",:bright v]) - condPart:= condition or 'true - sayBrightly concat(" condition",varPart,": ",pred2English condPart) - -getAndSay(v,prop) == - val:= getI(v,prop) => sayMSG [" ",val,'%l] - sayMSG [" none",'%l] - -displayType($op,u,omitVariableNameIfTrue) == - null u => - sayMSG ['" Type of value of ", - fixObjectForPrinting PNAME $op,'": (none)"] - type := prefix2String objMode(u) - if ATOM type then type := [type] - sayMSG concat ['" Type of value of ",fixObjectForPrinting PNAME $op,'": ",:type] - NIL - -displayValue($op,u,omitVariableNameIfTrue) == - null u => sayMSG [" Value of ",fixObjectForPrinting PNAME $op,'": (none)"] - expr := objValUnwrap(u) - expr is [op,:.] and (op = 'MAP) or objMode(u) = $EmptyMode => - displayRule($op,expr) - label:= - omitVariableNameIfTrue => - rhs := '"): " - '"Value (has type " - rhs := '": " - STRCONC('"Value of ", PNAME $op,'": ") - labmode := prefix2String objMode(u) - if ATOM labmode then labmode := [labmode] - GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain => - sayMSG concat('" ",label,labmode,rhs,form2String expr) - mathprint ['CONCAT,label,:labmode,rhs, - outputFormat(expr,objMode(u))] - NIL - ---% )edit - -edit l == editSpad2Cmd l - -editSpad2Cmd l == - l:= - null l => _/EDITFILE - CAR l - l := pathname l - oldDir := pathnameDirectory l - fileTypes := - pathnameType l => [pathnameType l] - $UserLevel = 'interpreter => '("input" "INPUT" "spad" "SPAD") - $UserLevel = 'compiler => '("input" "INPUT" "spad" "SPAD") - '("input" "INPUT" "spad" "SPAD" "boot" "BOOT" "lisp" "LISP" "meta" "META") - ll := - oldDir = '"" => pathname $FINDFILE (pathnameName l, fileTypes) - l - l := pathname ll - SETQ(_/EDITFILE,l) - rc := editFile l - updateSourceFiles l - rc - ---% )help - -help l == helpSpad2Cmd l - -helpSpad2Cmd args == - -- try to use new stuff first - if newHelpSpad2Cmd(args) then return nil - - sayKeyedMsg("S2IZ0025",[args]) - nil - -newHelpSpad2Cmd args == - if null args then args := ["?"] - # args > 1 => - sayKeyedMsg("S2IZ0026",NIL) - true - sarg := PNAME first args - if sarg = '"?" then args := ['help] - else if sarg = '"%" then args := ['history] - else if sarg = '"%%" then args := ['history] - arg := selectOptionLC(first args,$SYSCOMMANDS,nil) - if null arg then arg := first args - if arg = 'compiler then arg := 'compile - - -- see if new help file exists - - narg := PNAME arg - null (helpFile := MAKE_-INPUT_-FILENAME [narg,'HELPSPAD,'_*]) => NIL - - $useFullScreenHelp => - OBEY STRCONC('"$AXIOM/lib/SPADEDIT ",namestring helpFile) - true - - filestream := MAKE_-INSTREAM(helpFile) - repeat - line := read_-line(filestream,false) - NULL line => - SHUT filestream - return true - SAY line - true - ---% ---% )frame ---% - -$frameRecord := nil --Initial setting for frame record -$previousBindings := nil - -frame l == frameSpad2Cmd l - -frameName(frame) == CAR frame - -frameNames() == [frameName f for f in $interpreterFrameRing] - -frameEnvironment fname == - -- extracts the environment portion of a frame - -- if fname is not a valid frame name then the empty environment - -- is returned - fname = frameName first $interpreterFrameRing => $InteractiveFrame - ifr := rest $interpreterFrameRing - e := LIST LIST NIL - while ifr repeat - [f,:ifr] := ifr - if fname = frameName f then - e := CADR f - ifr := NIL - e - -frameSpad2Cmd args == - frameArgs := '(drop import last names new next) - $options => throwKeyedMsg("S2IZ0016",['")frame"]) - null(args) => helpSpad2Cmd ['frame] - arg := selectOptionLC(first args,frameArgs,'optionError) - args := rest args - if args is [a] then args := a - if ATOM args then args := object2Identifier args - arg = 'drop => - args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args]) - closeInterpreterFrame(args) - arg = "import" => importFromFrame args - arg = "last" => previousInterpreterFrame() - arg = "names" => displayFrameNames() - arg = "new" => - args and PAIRP(args) => throwKeyedMsg("S2IZ0017",[args]) - addNewInterpreterFrame(args) - arg = "next" => nextInterpreterFrame() - - NIL - -addNewInterpreterFrame(name) == - null name => throwKeyedMsg("S2IZ0018",NIL) - updateCurrentInterpreterFrame() - -- see if we already have one by that name - for f in $interpreterFrameRing repeat - name = frameName(f) => throwKeyedMsg("S2IZ0019",[name]) - initHistList() - $interpreterFrameRing := CONS(emptyInterpreterFrame(name), - $interpreterFrameRing) - updateFromCurrentInterpreterFrame() - _$ERASE histFileName() - -emptyInterpreterFrame(name) == - LIST(name, -- frame name - LIST LIST NIL, -- environment - 1, -- $IOindex - $HiFiAccess, -- $HiFiAccess - $HistList, -- $HistList - $HistListLen, -- $HistListLen - $HistListAct, -- $HistListAct - $HistRecord, -- $HistRecord - NIL, -- $internalHistoryTable - COPY_-SEQ $localExposureDataDefault -- $localExposureData - ) - -closeInterpreterFrame(name) == - -- if name = NIL then it means the current frame - null rest $interpreterFrameRing => - name and (name ^= $interpreterFrameName) => - throwKeyedMsg("S2IZ0020",[$interpreterFrameName]) - throwKeyedMsg("S2IZ0021",NIL) - if null name then $interpreterFrameRing := rest $interpreterFrameRing - else -- find the frame - found := nil - ifr := NIL - for f in $interpreterFrameRing repeat - found or (name ^= frameName(f)) => ifr := CONS(f,ifr) - found := true - not found => throwKeyedMsg("S2IZ0022",[name]) - _$ERASE makeHistFileName(name) - $interpreterFrameRing := nreverse ifr - updateFromCurrentInterpreterFrame() - -previousInterpreterFrame() == - updateCurrentInterpreterFrame() - null rest $interpreterFrameRing => NIL -- nothing to do - [:b,l] := $interpreterFrameRing - $interpreterFrameRing := NCONC2([l],b) - updateFromCurrentInterpreterFrame() - -nextInterpreterFrame() == - updateCurrentInterpreterFrame() - null rest $interpreterFrameRing => NIL -- nothing to do - $interpreterFrameRing := - NCONC2(rest $interpreterFrameRing,[first $interpreterFrameRing]) - updateFromCurrentInterpreterFrame() - - -createCurrentInterpreterFrame() == - LIST($interpreterFrameName, -- frame name - $InteractiveFrame, -- environment - $IOindex, -- $IOindex - $HiFiAccess, -- $HiFiAccess - $HistList, -- $HistList - $HistListLen, -- $HistListLen - $HistListAct, -- $HistListAct - $HistRecord, -- $HistRecord - $internalHistoryTable, -- $internalHistoryTable - $localExposureData -- $localExposureData - ) - - -updateFromCurrentInterpreterFrame() == - [$interpreterFrameName, _ - $InteractiveFrame, _ - $IOindex, _ - $HiFiAccess, _ - $HistList, _ - $HistListLen, _ - $HistListAct, _ - $HistRecord, _ - $internalHistoryTable, _ - $localExposureData _ - ] := first $interpreterFrameRing - if $frameMessages then - sayMessage ['" Current interpreter frame is called",:bright - $interpreterFrameName] - NIL - - -updateCurrentInterpreterFrame() == - RPLACA($interpreterFrameRing,createCurrentInterpreterFrame()) - updateFromCurrentInterpreterFrame() - NIL - -initializeInterpreterFrameRing() == - $interpreterFrameName := 'initial - $interpreterFrameRing := [emptyInterpreterFrame($interpreterFrameName)] - updateFromCurrentInterpreterFrame() - NIL - - -changeToNamedInterpreterFrame(name) == - updateCurrentInterpreterFrame() - frame := findFrameInRing(name) - null frame => NIL - $interpreterFrameRing := [frame,:NREMOVE($interpreterFrameRing, frame)] - updateFromCurrentInterpreterFrame() - -makeInitialModemapFrame() == COPY $InitialModemapFrame - -findFrameInRing(name) == - val := NIL - for frame in $interpreterFrameRing repeat - CAR frame = name => - val := frame - return frame - val - -displayFrameNames() == - fs := "append"/[ ['%l,'" ",:bright frameName f] for f in - $interpreterFrameRing] - sayKeyedMsg("S2IZ0024",[fs]) - -importFromFrame args == - -- args should have the form [frameName,:varNames] - if args and atom args then args := [args] - null args => throwKeyedMsg("S2IZ0073",NIL) - [fname,:args] := args - not member(fname,frameNames()) => - throwKeyedMsg("S2IZ0074",[fname]) - fname = frameName first $interpreterFrameRing => - throwKeyedMsg("S2IZ0075",NIL) - fenv := frameEnvironment fname - null args => - x := UPCASE queryUserKeyedMsg("S2IZ0076",[fname]) - MEMQ(STRING2ID_-N(x,1),'(Y YES)) => - vars := NIL - for [v,:props] in CAAR fenv repeat - v = "--macros" => - for [m,:.] in props repeat vars := cons(m,vars) - vars := cons(v,vars) - importFromFrame [fname,:vars] - sayKeyedMsg("S2IZ0077",[fname]) - for v in args repeat - plist := GETALIST(CAAR fenv,v) - plist => - -- remove anything with the same name in the current frame - clearCmdParts ['propert,v] - for [prop,:val] in plist repeat - putHist(v,prop,val,$InteractiveFrame) - (m := get("--macros--",v,fenv)) => - putHist("--macros--",v,m,$InteractiveFrame) - sayKeyedMsg("S2IZ0079",[v,fname]) - sayKeyedMsg("S2IZ0078",[fname]) - - - ---% )history - -++ vm/370 filename type component -SETANDFILEQ($historyFileType,'axh) - -++ vm/370 filename name component -SETANDFILEQ($oldHistoryFileName,'last) -SETANDFILEQ($internalHistoryTable,NIL) - -++ t means keep history in core -SETANDFILEQ($useInternalHistoryTable, true) - -history l == - l or null $options => sayKeyedMsg("S2IH0006",NIL) - historySpad2Cmd() - - -makeHistFileName(fname) == - makePathname(fname,$historyFileType,$historyDirectory) - -oldHistFileName() == - makeHistFileName($oldHistoryFileName) - -histFileName() == - makeHistFileName($interpreterFrameName) - - -histInputFileName(fn) == - null fn => - makePathname($interpreterFrameName,'INPUT,$historyDirectory) - makePathname(fn,'INPUT,$historyDirectory) - - -initHist() == - $useInternalHistoryTable => initHistList() - oldFile := oldHistFileName() - newFile := histFileName() - -- see if history directory is writable - histFileErase oldFile - if MAKE_-INPUT_-FILENAME newFile then $REPLACE(oldFile,newFile) - $HiFiAccess:= 'T - initHistList() - -initHistList() == - -- creates $HistList as a circular list of length $HistListLen - -- and $HistRecord - $HistListLen:= 20 - $HistList:= LIST NIL - li:= $HistList - for i in 1..$HistListLen repeat li:= CONS(NIL,li) - RPLACD($HistList,li) - $HistListAct:= 0 - $HistRecord:= NIL - -historySpad2Cmd() == - -- history is a system command which can call resetInCoreHist - -- and changeHistListLen, and restore last session - histOptions:= - '(on off yes no change reset restore write save show file memory) - opts:= [ [selectOptionLC(opt,histOptions,'optionError),:optargs] - for [opt,:optargs] in $options] - for [opt,:optargs] in opts repeat - opt in '(on yes) => - $HiFiAccess => sayKeyedMsg("S2IH0007",NIL) - $IOindex = 1 => -- haven't done anything yet - $HiFiAccess:= 'T - initHistList() - sayKeyedMsg("S2IH0008",NIL) - x := UPCASE queryUserKeyedMsg("S2IH0009",NIL) - MEMQ(STRING2ID_-N(x,1),'(Y YES)) => - histFileErase histFileName() - $HiFiAccess:= 'T - $options := nil - clearSpad2Cmd '(all) - sayKeyedMsg("S2IH0008",NIL) - initHistList() - sayKeyedMsg("S2IH0010",NIL) - opt in '(off no) => - null $HiFiAccess => sayKeyedMsg("S2IH0011",NIL) - $HiFiAccess:= NIL - disableHist() - sayKeyedMsg("S2IH0012",NIL) - opt = 'file => setHistoryCore NIL - opt = 'memory => setHistoryCore true - opt = 'reset => resetInCoreHist() - opt = 'save => saveHistory optargs - opt = 'show => showHistory optargs - opt = 'change => changeHistListLen first optargs - opt = 'restore => restoreHistory optargs - opt = 'write => writeInputLines(optargs,1) - 'done - - -setHistoryCore inCore == - inCore = $useInternalHistoryTable => - sayKeyedMsg((inCore => "S2IH0030"; "S2IH0029"),NIL) - not $HiFiAccess => - $useInternalHistoryTable := inCore - inCore => sayKeyedMsg("S2IH0032",NIL) - sayKeyedMsg("S2IH0031",NIL) - inCore => - $internalHistoryTable := NIL - if $IOindex ^= 0 then - -- actually put something in there - l := LENGTH RKEYIDS histFileName() - for i in 1..l repeat - vec:= UNWIND_-PROTECT(readHiFi(i),disableHist()) - $internalHistoryTable := CONS([i,:vec],$internalHistoryTable) - histFileErase histFileName() - $useInternalHistoryTable := true - sayKeyedMsg("S2IH0032",NIL) - $HiFiAccess:= 'NIL - histFileErase histFileName() - str := RDEFIOSTREAM ['(MODE . OUTPUT),['FILE,:histFileName()]] - for [n,:rec] in reverse $internalHistoryTable repeat - SPADRWRITE(object2Identifier n,rec,str) - RSHUT str - $HiFiAccess:= 'T - $internalHistoryTable := NIL - $useInternalHistoryTable := NIL - sayKeyedMsg("S2IH0031",NIL) - - -writeInputLines(fn,initial) == - -- writes all input lines into file histInputFileName() - not $HiFiAccess => sayKeyedMsg("S2IH0013",NIL) -- history not on - null fn => - throwKeyedMsg("S2IH0038", nil) -- missing file name - maxn := 72 - breakChars := [" ","+"] - for i in initial..$IOindex - 1 repeat - vecl := CAR readHiFi i - if STRINGP vecl then vecl := [vecl] - for vec in vecl repeat - n := SIZE vec - while n > maxn repeat - -- search backwards for a blank - done := nil - for j in 1..maxn while ^done repeat - k := 1 + maxn - j - MEMQ(vec.k,breakChars) => - svec := STRCONC(SUBSTRING(vec,0,k+1),UNDERBAR) - lineList := [svec,:lineList] - done := true - vec := SUBSTRING(vec,k+1,NIL) - n := SIZE vec - -- in case we can't find a breaking point - if ^done then n := 0 - lineList := [vec,:lineList] - file := histInputFileName(fn) - histFileErase file - inp:= DEFIOSTREAM(['(MODE . OUTPUT),['FILE,:file]],255,0) - for x in removeUndoLines NREVERSE lineList repeat WRITE_-LINE(x,inp) - -- see file "undo" for definition of removeUndoLines - if fn ^= 'redo then sayKeyedMsg("S2IH0014",[namestring file]) - SHUT inp - NIL - - -resetInCoreHist() == - -- removes all pointers from $HistList - $HistListAct:= 0 - for i in 1..$HistListLen repeat - $HistList:= CDR $HistList - RPLACA($HistList,NIL) - -changeHistListLen(n) == - -- changes the length of $HistList. n must be nonnegative - NULL INTEGERP n => sayKeyedMsg("S2IH0015",[n]) - dif:= n-$HistListLen - $HistListLen:= n - l:= CDR $HistList - if dif > 0 then - for i in 1..dif repeat l:= CONS(NIL,l) - if dif < 0 then - for i in 1..-dif repeat l:= CDR l - if $HistListAct > n then $HistListAct:= n - RPLACD($HistList,l) - 'done - -updateHist() == - -- updates the history file and calls updateInCoreHist - null $IOindex => nil - startTimingProcess 'history - updateInCoreHist() - if $HiFiAccess then - UNWIND_-PROTECT(writeHiFi(),disableHist()) - $HistRecord:= NIL - $IOindex:= $IOindex+1 - updateCurrentInterpreterFrame() - $mkTestInputStack := nil - $currentLine := nil - stopTimingProcess 'history - -updateInCoreHist() == - -- updates $HistList and $IOindex - $HistList:= CDR($HistList) - RPLACA($HistList,NIL) - if $HistListAct < $HistListLen then $HistListAct:= $HistListAct+1 - -putHist(x,prop,val,e) == - -- records new value to $HistRecord and old value to $HistList - -- then put is called with e - if not (x='%) then recordOldValue(x,prop,get(x,prop,e)) - if $HiFiAccess then recordNewValue(x,prop,val) - putIntSymTab(x,prop,val,e) - -histFileErase file == - --OBEY STRCONC('"rm -rf ", file) - PROBE_-FILE(file) and DELETE_-FILE(file) - - - -recordNewValue(x,prop,val) == - startTimingProcess 'history - recordNewValue0(x,prop,val) - stopTimingProcess 'history - -recordNewValue0(x,prop,val) == - -- writes (prop . val) into $HistRecord - -- updateHist writes this stuff out into the history file - p1:= ASSQ(x,$HistRecord) => - p2:= ASSQ(prop,CDR p1) => - RPLACD(p2,val) - RPLACD(p1,CONS(CONS(prop,val),CDR p1)) - p:= CONS(x,list CONS(prop,val)) - $HistRecord:= CONS(p,$HistRecord) - -recordOldValue(x,prop,val) == - startTimingProcess 'history - recordOldValue0(x,prop,val) - stopTimingProcess 'history - -recordOldValue0(x,prop,val) == - -- writes (prop . val) into $HistList - p1:= ASSQ(x,CAR $HistList) => - not ASSQ(prop,CDR p1) => - RPLACD(p1,CONS(CONS(prop,val),CDR p1)) - p:= CONS(x,list CONS(prop,val)) - RPLACA($HistList,CONS(p,CAR $HistList)) - -undoInCore(n) == - -- undoes the last n>0 steps using $HistList - -- resets $InteractiveFrame - li:= $HistList - for i in n..$HistListLen repeat li:= CDR li - undoChanges(li) - n:= $IOindex-n-1 - n>0 and - $HiFiAccess => - vec:= CDR UNWIND_-PROTECT(readHiFi(n),disableHist()) - val:= ( p:= ASSQ('%,vec) ) and ( p1:= ASSQ('value,CDR p) ) and - CDR p1 - sayKeyedMsg("S2IH0019",[n]) - $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame) - updateHist() - -undoChanges(li) == - -- undoes all changes of list 'li' - if not CDR li = $HistList then undoChanges CDR li - for p1 in CAR li repeat - x:= CAR p1 - for p2 in CDR p1 repeat - putHist(x,CAR p2,CDR p2,$InteractiveFrame) - -undoFromFile(n) == - -- makes a clear and redoes all the assignments until step n - for [x,:varl] in CAAR $InteractiveFrame repeat - for p in varl repeat - [prop,:val]:= p - val => - if not (x='%) then recordOldValue(x,prop,val) - if $HiFiAccess then recordNewValue(x,prop,val) - RPLACD(p,NIL) - for i in 1..n repeat - vec:= UNWIND_-PROTECT(CDR readHiFi(i),disableHist()) - for p1 in vec repeat - x:= CAR p1 - for p2 in CDR p1 repeat - $InteractiveFrame:= putHist(x,CAR p2,CDR p2,$InteractiveFrame) - val:= ( p:= ASSQ('%,vec) ) and ( p1:= ASSQ('value,CDR p) ) and CDR p1 - $InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame) - updateHist() - -saveHistory(fn) == - $seen: local := MAKE_-HASHTABLE 'EQ - not $HiFiAccess => sayKeyedMsg("S2IH0016",NIL) - not $useInternalHistoryTable and - null MAKE_-INPUT_-FILENAME histFileName() => sayKeyedMsg("S2IH0022",NIL) - null fn => - throwKeyedMsg("S2IH0037", nil) - savefile := makeHistFileName(fn) - inputfile := histInputFileName(fn) - writeInputLines(fn,1) - histFileErase savefile - - if $useInternalHistoryTable - then - saveStr := RDEFIOSTREAM ['(MODE . OUTPUT),['FILE,:savefile]] - for [n,:rec] in reverse $internalHistoryTable repeat - val := SPADRWRITE0(object2Identifier n,rec,saveStr) - val = 'writifyFailed => - sayKeyedMsg("S2IH0035", [n, inputfile]) -- unable to save step - RSHUT saveStr - sayKeyedMsg("S2IH0018",[namestring(savefile)]) -- saved hist file named - nil - -restoreHistory(fn) == - -- uses fn $historyFileType to recover an old session - -- if fn = NIL, then use $oldHistoryFileName - if null fn then fn' := $oldHistoryFileName - else if fn is [fn'] and IDENTP(fn') then fn' := fn' - else throwKeyedMsg("S2IH0023",[fn']) - restfile := makeHistFileName(fn') - null MAKE_-INPUT_-FILENAME restfile => - sayKeyedMsg("S2IH0024",[namestring(restfile)]) -- no history file - - -- if clear is changed to be undoable, this should be a reset-clear - $options: local := nil - clearSpad2Cmd '(all) - - curfile := histFileName() - histFileErase curfile - _$FCOPY(restfile,curfile) - - l:= LENGTH RKEYIDS curfile - $HiFiAccess:= 'T - oldInternal := $useInternalHistoryTable - $useInternalHistoryTable := NIL - if oldInternal then $internalHistoryTable := NIL - for i in 1..l repeat - vec:= UNWIND_-PROTECT(readHiFi(i),disableHist()) - if oldInternal then $internalHistoryTable := - CONS([i,:vec],$internalHistoryTable) - LINE:= CAR vec - for p1 in CDR vec repeat - x:= CAR p1 - for p2 in CDR p1 repeat - $InteractiveFrame:= putHist(x,CAR p2,CDR p2,$InteractiveFrame) - updateInCoreHist() - $e := $InteractiveFrame - for [a,:.] in CAAR $InteractiveFrame repeat - get(a,'localModemap,$InteractiveFrame) => - rempropI(a,'localModemap) - rempropI(a,'localVars) - rempropI(a,'mapBody) - $IOindex:= l+1 - $useInternalHistoryTable := oldInternal - sayKeyedMsg("S2IH0025",[namestring(restfile)]) - clearCmdSortedCaches() - nil - - --- the following used to be the show command when that was used to --- show history. -showHistory(arg) == - -- arg can be of form - -- NIL show at most last 20 input lines - -- (n) show at most last n input lines - -- (lit) where lit is an abbreviation for 'input or 'both - -- if 'input, same as NIL - -- if 'both, show last 5 input and outputs - -- (n lit) show last n input lines + last n output lines - -- if lit expands to 'both - $evalTimePrint: local:= 0 - $printTimeSum: local:= 0 - -- ugh!!! these are needed for timedEvaluateStream - -- displays the last n steps, default n=20 - not $HiFiAccess => sayKeyedMsg("S2IH0026",['show]) - showInputOrBoth := 'input - n := 20 - nset := nil - if arg then - arg1 := CAR arg - if INTEGERP arg1 then - n := arg1 - nset := true - KDR arg => arg1 := CADR arg - arg1 := NIL - arg1 => - arg2 := selectOptionLC(arg1,'(input both),nil) - if arg2 - then ((showInputOrBoth := arg2) = 'both) and (null nset) => n:= 5 - else sayMSG - concat('" ",bright arg1,'"is an invalid argument.") - if n >= $IOindex then n:= $IOindex-1 - mini:= $IOindex-n - maxi:= $IOindex-1 - showInputOrBoth = 'both => - UNWIND_-PROTECT(showInOut(mini,maxi),setIOindex(maxi+1)) - showInput(mini,maxi) - -setIOindex(n) == - -- set $IOindex to n - $IOindex:= n - -showInput(mini,maxi) == - -- displays all input lines from mini to maxi - for ind in mini..maxi repeat - vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist()) - if ind<10 then TAB 2 else if ind<100 then TAB 1 - l := CAR vec - STRINGP l => - sayMSG ['" [",ind,'"] ",CAR vec] - sayMSG ['" [",ind,'"] " ] - for ln in l repeat - sayMSG ['" ", ln] - -showInOut(mini,maxi) == - -- displays all steps from mini to maxi - for ind in mini..maxi repeat - vec:= UNWIND_-PROTECT(readHiFi(ind),disableHist()) - sayMSG [CAR vec] - Alist:= ASSQ('%,CDR vec) => - triple:= CDR ASSQ('value,CDR Alist) - $IOindex:= ind - spadPrint(objValUnwrap triple,objMode triple) - -fetchOutput(n) == - -- result is the output of step n - (n = -1) and (val := getI("%",'value)) => val - $HiFiAccess => - n:= - n < 0 => $IOindex+n - n - n >= $IOindex => throwKeyedMsg("S2IH0001",[n]) - n < 1 => throwKeyedMsg("S2IH0002",[n]) - vec:= UNWIND_-PROTECT(readHiFi(n),disableHist()) - Alist:= ASSQ('%,CDR vec) => - val:= CDR ASSQ('value,CDR Alist) => val - throwKeyedMsg("S2IH0003",[n]) - throwKeyedMsg("S2IH0003",[n]) - throwKeyedMsg("S2IH0004",NIL) - -readHiFi(n) == - -- reads the file using index n - if $useInternalHistoryTable - then - pair := assoc(n,$internalHistoryTable) - ATOM pair => keyedSystemError("S2IH0034",NIL) - vec := QCDR pair - else - HiFi:= RDEFIOSTREAM ['(MODE . INPUT),['FILE,:histFileName()]] - vec:= SPADRREAD(object2Identifier n,HiFi) - RSHUT HiFi - vec - -writeHiFi() == - -- writes the information of the current step out to history file - if $useInternalHistoryTable - then - $internalHistoryTable := CONS([$IOindex,$currentLine,:$HistRecord], - $internalHistoryTable) - else - HiFi:= RDEFIOSTREAM ['(MODE . OUTPUT),['FILE,:histFileName()]] - SPADRWRITE(object2Identifier $IOindex, CONS($currentLine,$HistRecord),HiFi) - RSHUT HiFi - -disableHist() == - -- disables the history mechanism if an error occurred in the protected - -- piece of code - not $HiFiAccess => histFileErase histFileName() - NIL - -writeHistModesAndValues() == - for [a,:.] in CAAR $InteractiveFrame repeat - x := get(a,'value,$InteractiveFrame) => - putHist(a,'value,x,$InteractiveFrame) - x := get(a,'mode,$InteractiveFrame) => - putHist(a,'mode,x,$InteractiveFrame) - NIL - -SPADRREAD(vec, stream) == - dewritify rread(vec, stream, nil) - ---% Lisplib output transformations --- Some types of objects cannot be saved by LISP/VM in lisplibs. --- These functions transform an object to a writable form and back. --- SMW -SPADRWRITE(vec, item, stream) == - val := SPADRWRITE0(vec, item, stream) - val = 'writifyFailed => - throwKeyedMsg("S2IH0036", nil) -- cannot save value to file - item - -SPADRWRITE0(vec, item, stream) == - val := safeWritify item - val = 'writifyFailed => val - rwrite(vec, val, stream) - item - -safeWritify ob == - CATCH('writifyTag, writify ob) - -writify ob == - not ScanOrPairVec(function(unwritable?), ob) => ob - $seen: local := MAKE_-HASHTABLE 'EQ - $writifyComplained: local := false - - writifyInner ob where - writifyInner ob == - null ob => nil - (e := HGET($seen, ob)) => e - - PAIRP ob => - qcar := QCAR ob - qcdr := QCDR ob - (name := spadClosure? ob) => - d := writifyInner QCDR ob - nob := ['WRITIFIED_!_!, 'SPADCLOSURE, d, name] - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - nob - (ob is ['LAMBDA_-CLOSURE, ., ., x, :.]) and x => - THROW('writifyTag, 'writifyFailed) - nob := CONS(qcar, qcdr) - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - qcar := writifyInner qcar - qcdr := writifyInner qcdr - QRPLACA(nob, qcar) - QRPLACD(nob, qcdr) - nob - VECP ob => - isDomainOrPackage ob => - d := mkEvalable devaluate ob - nob := ['WRITIFIED_!_!, 'DEVALUATED, writifyInner d] - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - nob - n := QVMAXINDEX ob - nob := MAKE_-VEC(n+1) - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - for i in 0..n repeat - QSETVELT(nob, i, writifyInner QVELT(ob,i)) - nob - ob = 'WRITIFIED_!_! => - ['WRITIFIED_!_!, 'SELF] - -- In CCL constructors are also compiled functions, so we - -- need this line: - constructor? ob => ob - COMPILED_-FUNCTION_-P ob => - THROW('writifyTag, 'writifyFailed) - HASHTABLEP ob => - nob := ['WRITIFIED_!_!] - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - keys := HKEYS ob - QRPLACD(nob, - ['HASHTABLE, - HASHTABLE_-CLASS ob, - writifyInner keys, - [writifyInner HGET(ob,k) for k in keys]]) - nob - PLACEP ob => - nob := ['WRITIFIED_!_!, 'PLACE] - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - nob - -- The next three types cause an error on de-writifying. - -- Create an object of the right shape, nonetheless. - READTABLEP ob => - THROW('writifyTag, 'writifyFailed) - -- Default case: return the object itself. - STRINGP ob => - EQ(ob, $NullStream) => ['WRITIFIED_!_!, 'NULLSTREAM] - EQ(ob, $NonNullStream) => ['WRITIFIED_!_!, 'NONNULLSTREAM] - ob - FLOATP ob => - ob = READ_-FROM_-STRING STRINGIMAGE ob => ob - ['WRITIFIED_!_!, 'FLOAT, ob,: - MULTIPLE_-VALUE_-LIST INTEGER_-DECODE_-FLOAT ob] - ob - - -unwritable? ob == - PAIRP ob or VECP ob => false -- first for speed - COMPILED_-FUNCTION_-P ob or HASHTABLEP ob => true - PLACEP ob or READTABLEP ob => true - FLOATP ob => true - false - --- Create a full isomorphic object which can be saved in a lisplib. --- Note that dewritify(writify(x)) preserves UEQUALity of hashtables. --- HASHTABLEs go both ways. --- READTABLEs cannot presently be transformed back. - -writifyComplain s == - $writifyComplained = true => nil - $writifyComplained := true - sayKeyedMsg("S2IH0027",[s]) - -spadClosure? ob == - fun := QCAR ob - not (name := BPINAME fun) => nil - vec := QCDR ob - not VECP vec => nil - name - -dewritify ob == - (not ScanOrPairVec(function is?, ob) - where is? a == a = 'WRITIFIED_!_!) => ob - - $seen: local := MAKE_-HASHTABLE 'EQ - - dewritifyInner ob where - dewritifyInner ob == - null ob => nil - e := HGET($seen, ob) => e - - PAIRP ob and CAR ob = 'WRITIFIED_!_! => - type := ob.1 - type = 'SELF => - 'WRITIFIED_!_! - type = 'BPI => - oname := ob.2 - f := - INTP oname => EVAL GENSYMMER oname - SYMBOL_-FUNCTION oname - not COMPILED_-FUNCTION_-P f => - error '"A required BPI does not exist." - #ob > 3 and HASHEQ f ^= ob.3 => - error '"A required BPI has been redefined." - HPUT($seen, ob, f) - f - type = 'HASHTABLE => - nob := MAKE_-HASHTABLE ob.2 - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - for k in ob.3 for e in ob.4 repeat - HPUT(nob, dewritifyInner k, dewritifyInner e) - nob - type = 'DEVALUATED => - nob := EVAL dewritifyInner ob.2 - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - nob - type = 'SPADCLOSURE => - vec := dewritifyInner ob.2 - name := ob.3 - not FBOUNDP name => - error STRCONC('"undefined function: ", SYMBOL_-NAME name) - nob := CONS(SYMBOL_-FUNCTION name, vec) - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - nob - type = 'PLACE => - nob := VMREAD MAKE_-INSTREAM NIL - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - nob - type = 'READTABLE => - error '"Cannot de-writify a read table." - type = 'NULLSTREAM => $NullStream - type = 'NONNULLSTREAM => $NonNullStream - type = 'FLOAT => - [fval, signif, expon, sign] := CDDR ob - fval := SCALE_-FLOAT( FLOAT(signif, fval), expon) - sign<0 => -fval - fval - error '"Unknown type to de-writify." - - PAIRP ob => - qcar := QCAR ob - qcdr := QCDR ob - nob := CONS(qcar, qcdr) - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - QRPLACA(nob, dewritifyInner qcar) - QRPLACD(nob, dewritifyInner qcdr) - nob - VECP ob => - n := QVMAXINDEX ob - nob := MAKE_-VEC(n+1) - HPUT($seen, ob, nob) - HPUT($seen, nob, nob) - for i in 0..n repeat - QSETVELT(nob, i, dewritifyInner QVELT(ob,i)) - nob - -- Default case: return the object itself. - ob - -ScanOrPairVec(f, ob) == - $seen: local := MAKE_-HASHTABLE 'EQ - - CATCH('ScanOrPairVecAnswer, ScanOrInner(f, ob)) where - ScanOrInner(f, ob) == - HGET($seen, ob) => nil - PAIRP ob => - HPUT($seen, ob, true) - ScanOrInner(f, QCAR ob) - ScanOrInner(f, QCDR ob) - nil - VECP ob => - HPUT($seen, ob, true) - for i in 0..#ob-1 repeat ScanOrInner(f, ob.i) - nil - FUNCALL(f, ob) => - THROW('ScanOrPairVecAnswer, true) - nil - - - - - ---% )load - -load args == loadSpad2Cmd args - -loadSpad2Cmd args == - sayKeyedMsg("S2IU0003", nil) - NIL --- load1(args,$forceDatabaseUpdate) - ---load1(args,$forceDatabaseUpdate) == -- $ var is now local --- null args => helpSpad2Cmd '(load) --- loadfun := 'loadLib --- justWondering := nil --- compiler := 'old --- doExpose := true --- $forceDatabaseUpdate := true -- BMT request, 5/14/90 --- for [opt,:.] in $options repeat --- fullopt := selectOptionLC(opt, --- '(cond update query new noexpose noupdate), --- 'optionError) --- fullopt = 'cond => loadfun := 'loadLibIfNotLoaded --- fullopt = 'query => justWondering := true --- fullopt = 'update => $forceDatabaseUpdate := true --- fullopt = 'noexpose => doExpose := false --- fullopt = 'noupdate => $forceDatabaseUpdate := false --- if $forceDatabaseUpdate then clearClams() --- for lib in args repeat --- lib := object2Identifier lib --- justWondering => --- GETL(lib,'LOADED) => sayKeyedMsg("S2IZ0028",[lib]) --- sayKeyedMsg("S2IZ0029",[lib]) --- null GETDATABASE(lib,'OBJECT) and --- null (lib := GETDATABASE(lib,'CONSTRUCTOR)) => --- sayKeyedMsg("S2IL0020", [namestring [lib,$spadLibFT,"*"]]) --- null FUNCALL(loadfun,lib) => --- sayKeyedMsg("S2IZ0029",[lib]) --- sayKeyedMsg("S2IZ0028",[lib]) --- if doExpose and --- not isExposedConstructor(lib) then --- setExposeAddConstr([lib]) --- 'EndOfLoad - -reportCount () == - centerAndHighlight(" Current Count Settings ",$LINELENGTH,specialChar 'hbar) - SAY " " - sayBrightly [:bright " cache",fillerSpaces(30,'".")," ",$cacheCount] - if $cacheAlist then - for [a,:b] in $cacheAlist repeat - aPart:= linearFormatName a - n:= sayBrightlyLength aPart - sayBrightly concat(" ",aPart," ",fillerSpaces(32-n,'".")," ",b) - SAY " " - sayBrightly [:bright " stream",fillerSpaces(29,'".")," ",$streamCount] - ---% )quit - -pquit() == pquitSpad2Cmd() - -pquitSpad2Cmd() == - $saturn => - sayErrorly('"Obsolete system command", _ - ['" The )pquit system command is obsolete in this version of AXIOM.", - '" Please select Exit from the File Menu instead."]) - $quitCommandType :local := 'protected - quitSpad2Cmd() - -quit() == quitSpad2Cmd() - -quitSpad2Cmd() == - $saturn => - sayErrorly('"Obsolete system command", _ - ['" The )quit system command is obsolete in this version of AXIOM.", - '" Please select Exit from the File Menu instead."]) - $quitCommandType ^= 'protected => leaveScratchpad() - x := UPCASE queryUserKeyedMsg("S2IZ0031",NIL) - MEMQ(STRING2ID_-N(x,1),'(Y YES)) => leaveScratchpad() - sayKeyedMsg("S2IZ0032",NIL) - TERSYSCOMMAND () - -leaveScratchpad () == BYE() - ---% )read - -read l == readSpad2Cmd l - -readSpad2Cmd l == - ---$saturn => - --- sayErrorly('"Obsolete system command", _ - --- ['" The )read system command is obsolete in this version of AXIOM.", - --- '" Please use Open from the File menu instead."]) - $InteractiveMode : local := true - quiet := nil - ifthere := nil - for [opt,:.] in $options repeat - fullopt := selectOptionLC(opt,'(quiet test ifthere),'optionError) - fullopt = 'ifthere => ifthere := true - fullopt = 'quiet => quiet := true - - ef := pathname _/EDITFILE - if pathnameTypeId(ef) = 'SPAD then - ef := makePathname(pathnameName ef,'"*",'"*") - if l then - l := mergePathnames(pathname l,ef) - else - l := ef - devFTs := '("input" "INPUT" "boot" "BOOT" "lisp" "LISP") - fileTypes := - $UserLevel = 'interpreter => '("input" "INPUT") - $UserLevel = 'compiler => '("input" "INPUT") - devFTs - ll := $FINDFILE (l, fileTypes) - if null ll then - ifthere => return nil -- be quiet about it - throwKeyedMsg("S2IL0003",[namestring l]) - ll := pathname ll - ft := pathnameType ll - upft := UPCASE ft - null member(upft,fileTypes) => - fs := namestring l - member(upft,devFTs) => throwKeyedMsg("S2IZ0033",[fs]) - throwKeyedMsg("S2IZ0034",[fs]) - SETQ(_/EDITFILE,ll) - if upft = '"BOOT" then $InteractiveMode := nil - _/READ(ll,quiet) - ---% )savesystem -savesystem l == - #l ^= 1 or not(SYMBOLP CAR l) => helpSpad2Cmd '(savesystem) - SPAD_-SAVE SYMBOL_-NAME CAR l - ---% )show - -show l == showSpad2Cmd l - -showSpad2Cmd l == - l = [NIL] => helpSpad2Cmd '(show) - $showOptions : local := '(attributes operations) - if null $options then $options := '((operations)) - $e : local := $InteractiveFrame - $env : local := $InteractiveFrame - l is [constr] => - constr in '(Union Record Mapping) => - constr = 'Record => - sayKeyedMsg("S2IZ0044R",[constr, '")show Record(a: Integer, b: String)"]) - constr = 'Mapping => - sayKeyedMsg("S2IZ0044M",NIL) - sayKeyedMsg("S2IZ0045T",[constr, '")show Union(a: Integer, b: String)"]) - sayKeyedMsg("S2IZ0045U",[constr, '")show Union(Integer, String)"]) - constr is ['Mapping, :.] => - sayKeyedMsg("S2IZ0044M",NIL) - reportOperations(constr,constr) - reportOperations(l,l) - -reportOperations(oldArg,u) == - -- u might be an uppercased version of oldArg - $env:local := [[NIL]] - $eval:local := true --generate code-- don't just type analyze - $genValue:local := true --evaluate all generated code - null u => nil - $doNotAddEmptyModeIfTrue: local:= true - u = $quadSymbol => - sayBrightly ['" mode denotes", :bright '"any", "type"] - u = "%" => - sayKeyedMsg("S2IZ0063",NIL) - sayKeyedMsg("S2IZ0064",NIL) - u isnt ['Record,:.] and u isnt ['Union,:.] and - null(isNameOfType u) and u isnt ['typeOf,.] => - if ATOM oldArg then oldArg := [oldArg] - sayKeyedMsg("S2IZ0063",NIL) - for op in oldArg repeat - sayKeyedMsg("S2IZ0062",[opOf op]) - (v := isDomainValuedVariable u) => reportOpsFromUnitDirectly0 v - unitForm:= - atom u => opOf unabbrev u - unabbrev u - atom unitForm => reportOpsFromLisplib0(unitForm,u) - unitForm' := evaluateType unitForm - tree := mkAtree removeZeroOneDestructively unitForm - (unitForm' := isType tree) => reportOpsFromUnitDirectly0 unitForm' - sayKeyedMsg("S2IZ0041",[unitForm]) - -reportOpsFromUnitDirectly0 D == - $useEditorForShowOutput => - reportOpsFromUnitDirectly1 D - reportOpsFromUnitDirectly D - -reportOpsFromUnitDirectly1 D == - showFile := pathname ['SHOW,'LISTING,$listingDirectory] - _$ERASE showFile - $sayBrightlyStream : fluid := - DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) - sayShowWarning() - reportOpsFromUnitDirectly D - SHUT $sayBrightlyStream - editFile showFile - -sayShowWarning() == - sayBrightly - '"Warning: this is a temporary file and will be deleted the next" - sayBrightly - '" time you use )show. Rename it and FILE if you wish to" - sayBrightly - '" save the contents." - sayBrightly '"" - -reportOpsFromLisplib0(unitForm,u) == - $useEditorForShowOutput => reportOpsFromLisplib1(unitForm,u) - reportOpsFromLisplib(unitForm,u) - -reportOpsFromLisplib1(unitForm,u) == - showFile := pathname ['SHOW,'LISTING,$listingDirectory] - _$ERASE showFile - $sayBrightlyStream : fluid := - DEFIOSTREAM([['FILE,:showFile], '(MODE . OUTPUT)],255,0) - sayShowWarning() - reportOpsFromLisplib(unitForm,u) - SHUT $sayBrightlyStream - editFile showFile - -reportOpsFromUnitDirectly unitForm == - isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union) - unit:= evalDomain unitForm - top:= CAR unitForm - kind:= GETDATABASE(top,'CONSTRUCTORKIND) - - sayBrightly concat('%b,formatOpType unitForm, - '%d,'"is a",'%b,kind,'%d, '"constructor.") - if not isRecordOrUnion then - abb := GETDATABASE(top,'ABBREVIATION) - sourceFile := GETDATABASE(top,'SOURCEFILE) - sayBrightly ['" Abbreviation for",:bright top,'"is",:bright abb] - verb := - isExposedConstructor top => '"is" - '"is not" - sayBrightly ['" This constructor",:bright verb, - '"exposed in this frame."] - sayBrightly ['" Issue",:bright STRCONC('")edit ", - namestring sourceFile),'"to see algebra source code for", - :bright abb,'%l] - - for [opt] in $options repeat - opt := selectOptionLC(opt,$showOptions,'optionError) - opt = 'attributes => - centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) - isRecordOrUnion => - sayBrightly '" Records and Unions have no attributes." - sayBrightly '"" - attList:= REMDUP MSORT [x for [x,:.] in unit.2] - say2PerLine [formatAttribute x for x in attList] - NIL - opt = 'operations => - $commentedOps: local := 0 - --new form is ( ) - centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) - sayBrightly '"" - if isRecordOrUnion - then - constructorFunction:= GETL(top,"makeFunctionList") or - systemErrorHere '"reportOpsFromUnitDirectly" - [funlist,.]:= FUNCALL(constructorFunction,"$",unitForm, - $CategoryFrame) - sigList := REMDUP MSORT [[[a,b],true,[c,0,1]] for - [a,b,c] in funlist] - else - sigList:= REMDUP MSORT getOplistForConstructorForm unitForm - say2PerLine [formatOperation(x,unit) for x in sigList] - if $commentedOps ^= 0 then - sayBrightly - ['"Functions that are not yet implemented are preceded by", - :bright '"--"] - sayBrightly '"" - NIL - -reportOpsFromLisplib(op,u) == - null(fn:= constructor? op) => sayKeyedMsg("S2IZ0054",[u]) - argml := - (s := getConstructorSignature op) => KDR s - NIL - typ:= GETDATABASE(op,'CONSTRUCTORKIND) - nArgs:= #argml - argList:= KDR GETDATABASE(op,'CONSTRUCTORFORM) - functorForm:= [op,:argList] - argml:= EQSUBSTLIST(argList,$FormalMapVariableList,argml) - functorFormWithDecl:= [op,:[[":",a,m] for a in argList for m in argml]] - sayBrightly concat(bright form2StringWithWhere functorFormWithDecl, - '" is a",bright typ,'"constructor") - sayBrightly ['" Abbreviation for",:bright op,'"is",:bright fn] - verb := - isExposedConstructor op => '"is" - '"is not" - sayBrightly ['" This constructor",:bright verb, - '"exposed in this frame."] - sourceFile := GETDATABASE(op,'SOURCEFILE) - sayBrightly ['" Issue",:bright STRCONC('")edit ", - namestring sourceFile), - '"to see algebra source code for",:bright fn,'%l] - - for [opt] in $options repeat - opt := selectOptionLC(opt,$showOptions,'optionError) - opt = 'layout => - dc1 fn - opt = 'views => sayBrightly ['"To get",:bright '"views", - '"you must give parameters of constructor"] - opt = 'attributes => - centerAndHighlight('"Attributes",$LINELENGTH,specialChar 'hbar) - sayBrightly '"" - attList:= REMDUP MSORT [x for [x,:.] in - GETDATABASE(op,'ATTRIBUTES)] - null attList => sayBrightly - concat('%b,form2String functorForm,'%d,"has no attributes.",'%l) - say2PerLine [formatAttribute x for x in attList] - NIL - opt = 'operations => displayOperationsFromLisplib functorForm - nil - -displayOperationsFromLisplib form == - [name,:argl] := form - kind := GETDATABASE(name,'CONSTRUCTORKIND) - centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) - opList:= GETDATABASE(name,'OPERATIONALIST) - null opList => reportOpsFromUnitDirectly form - opl:=REMDUP MSORT EQSUBSTLIST(argl,$FormalMapVariableList,opList) - ops:= nil - for x in opl repeat - ops := [:ops,:formatOperationAlistEntry(x)] - say2PerLine ops - nil - ---% )spool - -clearHighlight() == - $saveHighlight := $highlightAllowed - $highlightAllowed := false - $saveSpecialchars := $specialCharacters - setOutputCharacters ["plain"] - -resetHighlight() == - $highlightAllowed := $saveHighlight - $specialCharacters := $saveSpecialchars - -spool filename == - null filename => - DRIBBLE() - TERPRI() - resetHighlight() - PROBE_-FILE car filename => - systemError CONCAT('"file ", STRING car filename, '" already exists") - DRIBBLE car filename - TERPRI() - clearHighlight() - ---% )synonym - -synonym(:l) == synonymSpad2Cmd() -- always passed a null list - -synonymSpad2Cmd() == - line := getSystemCommandLine() - if line = '"" then printSynonyms(NIL) - else - pair := processSynonymLine line - if $CommandSynonymAlist then - PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) - else $CommandSynonymAlist := [pair] - terminateSystemCommand() - -processSynonymLine line == - key := STRING2ID_-N (line, 1) - value := removeKeyFromLine line where - removeKeyFromLine line == - line := dropLeadingBlanks line - mx := MAXINDEX line - for i in 0..mx repeat - line.i = " " => - return (for j in (i+1)..mx repeat - line.j ^= " " => return (SUBSTRING (line, j, nil))) - [key, :value] - - ---% ---% )undo ---% - -$undoFlag := true --Default setting for undo is "on" - - -undo(l) == ---undo takes one option ")redo" which simply reads "redo.input", --- a file created by every normal )undo command (see below) - undoWhen := 'after - if $options is [[key]] then - stringPrefix?(s := PNAME key,'"redo") => - $options := nil --clear $options so that "read" won't see them - read '(redo_.input) - not stringPrefix?(s,'"before") => - userError '"only option to undo is _")redo_"" - undoWhen := 'before - n := - null l => -1 - first l - if IDENTP n then - n := PARSE_-INTEGER PNAME n - if not FIXP n then userError '"undo argument must be an integer" - $InteractiveFrame := undoSteps(undoCount n,undoWhen) - nil - -recordFrame(systemNormal) == - null $undoFlag => nil --do nothing if facility is turned off - currentAlist := KAR $frameRecord - delta := diffAlist(CAAR $InteractiveFrame,$previousBindings) - if systemNormal = 'system then - null delta => return nil --do not record - delta := ['systemCommand,:delta] - $frameRecord := [delta,:$frameRecord] - $previousBindings := --copy all but the individual properties - [CONS(CAR x,[CONS(CAR y,CDR y) for y in CDR x]) for x in CAAR $InteractiveFrame] - first $frameRecord - -diffAlist(new,old) == ---record only those properties which are different - for (pair := [name,:proplist]) in new repeat - -- name has an entry both in new and old world - -- (1) if the old world had no proplist for that variable, then - -- record NIL as the value of each new property - -- (2) if the old world does have a proplist for that variable, then - -- a) for each property with a value: give the old value - -- b) for each property missing: give NIL as the old value - oldPair := ASSQ(name,old) => - null (oldProplist := CDR oldPair) => - --record old values of new properties as NIL - acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] - deltas := nil - for (propval := [prop,:val]) in proplist repeat - null (oldPropval := assoc(prop,oldProplist)) => --missing property - deltas := [[prop],:deltas] - EQ(CDR oldPropval,val) => 'skip - deltas := [oldPropval,:deltas] - deltas => acc := [[name,:NREVERSE deltas],:acc] - acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc] ---record properties absent on new list (say, from a )cl all) - for (oldPair := [name,:r]) in old repeat - r and null LASSQ(name,new) => - acc := [oldPair,:acc] - -- name has an entry both in new and old world - -- (1) if the new world has no proplist for that variable - -- (a) if the old world does, record the old proplist - -- (b) if the old world does not, record nothing - -- (2) if the new world has a proplist for that variable, it has - -- been handled by the first loop. - res := NREVERSE acc - if BOUNDP '$reportUndo and $reportUndo then reportUndo res - res - -reportUndo acc == - for [name,:proplist] in acc repeat - sayBrightly STRCONC("Properties of ",PNAME name,'" ::") - curproplist := LASSOC(name,CAAR $InteractiveFrame) - for [prop,:value] in proplist repeat - sayBrightlyNT ['" ",prop,'" was: "] - pp value - sayBrightlyNT ['" ",prop,'" is: "] - pp LASSOC(prop,curproplist) - -clearFrame() == - clearCmdAll() - $frameRecord := nil - $previousBindings := nil - - ---======================================================================= --- Undoing previous m commands ---======================================================================= -undoCount(n) == --computes the number of undo's, given $IOindex ---pp ["IOindex = ",$IOindex] - m := - n >= 0 => $IOindex - n - 1 - -n - m >= $IOindex => userError STRCONC('"Magnitude of undo argument must be less than step number (",STRINGIMAGE $IOindex,'").") - m - - -undoSteps(m,beforeOrAfter) == --- undoes m previous commands; if )before option, then undo one extra at end ---Example: if $IOindex now is 6 and m = 2 then general layout of $frameRecord, --- after the call to recordFrame below will be: --- ( --- ( --- ( --- ( --- --- ) where system --- command entries are optional and identified by (systemCommand . change). --- For a ")undo 3 )after", m = 2 and undoStep swill restore the environment --- up to, but not including . --- An "undo 3 )before" will additionally restore . --- Thus, the later requires one extra undo at the end. - writeInputLines('redo,$IOindex - m) - recordFrame('normal) --do NOT mark this as a system command change - --do this undo FIRST (i=0 case) - env := COPY CAAR $InteractiveFrame - for i in 0..m for framelist in tails $frameRecord repeat - env := undoSingleStep(first framelist,env) - framelist is [.,['systemCommand,:systemDelta],:.] => --- pp '"===============> AHA <=============" - framelist := rest framelist --undoing system commands given - env := undoSingleStep(systemDelta,env) -- before command line - lastTailSeen := framelist - if beforeOrAfter = 'before then --do one additional undo for )before - env := undoSingleStep(first rest lastTailSeen,env) - $frameRecord := rest $frameRecord --flush the effect of extra recordFrame - $InteractiveFrame := LIST LIST env - - -undoSingleStep(changes,env) == ---Each change is a name-proplist pair. For each change: --- (1) if there exists a proplist in env, then for each prop-value change: --- (a) if the prop exists in env, RPLAC in the change value --- (b) otherwise, CONS it onto the front of prop-values for that name --- (2) add change to the front of env --- pp '"----Undoing 1 step--------" --- pp changes - for (change := [name,:changeList]) in changes repeat - if LASSOC('localModemap,changeList) then - changeList := undoLocalModemapHack changeList - pairlist := ASSQ(name,env) => - proplist := CDR pairlist => - for (pair := [prop,:value]) in changeList repeat - node := ASSQ(prop,proplist) => RPLACD(node,value) - RPLACD(proplist,[CAR proplist,:CDR proplist]) - RPLACA(proplist,pair) - RPLACD(pairlist,changeList) - env := [change,:env] - env - -undoLocalModemapHack changeList == - [newPair for (pair := [name,:value]) in changeList | newPair] where newPair() == - name = 'localModemap => [name] - pair - -removeUndoLines u == --called by writeInputLines - xtra := - STRINGP $currentLine => [$currentLine] - REVERSE $currentLine - xtra := [x for x in xtra | not stringPrefix?('")history",x)] - u := [:u, :xtra] - not (or/[stringPrefix?('")undo",x) for x in u]) => u - --(1) reverse the list - --(2) walk down the (reversed) list: when >n appears remove: - -- (a) system commands - -- (b) if n > 0: (replace n by n-1; remove a command; repeat (a-b)) - savedIOindex := $IOindex --save value - $IOindex := 1 - for y in tails u repeat - (x := first y).0 = char '_) => - stringPrefix?('")undo",s := trimString x) => --parse "undo )option" - s1 := trimString SUBSTRING(s,5,nil) - if s1 ^= '")redo" then - m := charPosition(char '_),s1,0) - code := - m < MAXINDEX s1 => s1.(m + 1) - char 'a - s2 := trimString SUBSTRING(s1,0,m) - n := - s1 = '")redo" => 0 - s2 ^= '"" => undoCount PARSE_-INTEGER s2 - -1 - RPLACA(y,CONCAT('">",code,STRINGIMAGE n)) - nil - $IOindex := $IOindex + 1 --referenced by undoCount - acc := nil - for y in tails NREVERSE u repeat - (x := first y).0 = char '_> => - code := x . 1 --code = a,b, or r - n := PARSE_-INTEGER SUBSTRING(x,2,nil) --n = number of undo steps - y := rest y --kill >n line - while y repeat - c := first y - c.0 = char '_) or c.0 = char '_> => y := rest y --kill system commands - n = 0 => return nil --including undos - n := n - 1 - y := rest y --kill command - y and code^= char 'b => acc := [c,:acc] --add last unless )before - acc := [x,:acc] - $IOindex := savedIOindex - acc - - - - ---% )what - - -what l == whatSpad2Cmd l - -whatSpad2Cmd l == - $e:local := $EmptyEnvironment - null l => reportWhatOptions() - [key0,:args] := l - key := selectOptionLC(key0,$whatOptions,nil) - null key => sayKeyedMsg("S2IZ0043",NIL) - args := [fixpat p for p in args] where - fixpat x == - x is [x',:.] => DOWNCASE x' - DOWNCASE x - key = 'things => - for opt in $whatOptions repeat - not MEMQ(opt,'(things)) => whatSpad2Cmd [opt,:args] - key = 'categories => - filterAndFormatConstructors('category,'"Categories",args) - key = 'commands => - whatCommands(args) - key = 'domains => - filterAndFormatConstructors('domain,'"Domains",args) - key = 'operations => - apropos args - key = 'packages => - filterAndFormatConstructors('package,'"Packages",args) - key = 'synonyms => - printSynonyms(args) - -filterAndFormatConstructors(constrType,label,patterns) == - centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) - l := filterListOfStringsWithFn(patterns,whatConstructors constrType, - function CDR) - if patterns then - null l => - sayMessage ['" No ",label,'" with names matching patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - sayMessage [label,'" with names matching patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - l => pp2Cols l - -whatConstructors constrType == - -- here constrType should be one of 'category, 'domain, 'package - MSORT [CONS(GETDATABASE(con,'ABBREVIATION), STRING(con)) - for con in allConstructors() - | GETDATABASE(con,'CONSTRUCTORKIND) = constrType] - -apropos l == - -- l is a list of operation name fragments - -- this displays all operation names containing these fragments - ops := - null l => allOperations() - filterListOfStrings([(DOWNCASE STRINGIMAGE p) for p in l],allOperations()) - ops => - sayMessage '"Operations whose names satisfy the above pattern(s):" - sayAsManyPerLineAsPossible MSORT ops - sayKeyedMsg("S2IF0011",[first ops]) - sayMessage '" There are no operations containing those patterns" - NIL - - -printSynonyms(patterns) == - centerAndHighlight("System Command Synonyms",$LINELENGTH,specialChar 'hbar) - ls := filterListOfStringsWithFn(patterns, [[STRINGIMAGE a,:b] - for [a,:b] in synonymsForUserLevel $CommandSynonymAlist], - function CAR) - printLabelledList(ls,'"user",'"synonyms",'")",patterns) - nil - -printLabelledList(ls,label1,label2,prefix,patterns) == - -- prefix goes before each element on each side of the list, eg, - -- ")" - null ls => - null patterns => - sayMessage ['" No ",label1,'"-defined ",label2,'" in effect."] - sayMessage ['" No ",label1,'"-defined ",label2,'" satisfying patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - if patterns then - sayMessage [label1,'"-defined ",label2,'" satisfying patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - for [syn,:comm] in ls repeat - if SUBSTRING(syn,0,1) = '"|" then syn := SUBSTRING(syn,1,NIL) - if syn = '"%i" then syn := '"%i " - wid := MAX(30 - (entryWidth syn),1) - sayBrightly concat('%b,prefix,syn,'%d, - fillerSpaces(wid,'"."),'" ",prefix,comm) - sayBrightly '"" - -whatCommands(patterns) == - label := STRCONC("System Commands for User Level: ", - STRINGIMAGE $UserLevel) - centerAndHighlight(label,$LINELENGTH,specialChar 'hbar) - l := filterListOfStrings(patterns, - [(STRINGIMAGE a) for a in commandsForUserLevel $systemCommands]) - if patterns then - null l => - sayMessage ['"No system commands at this level matching patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - sayMessage ['"System commands at this level matching patterns:", - '%l,'" ",'%b,:blankList patterns,'%d] - if l then - sayAsManyPerLineAsPossible l - SAY " " - patterns => nil -- don't be so verbose - sayKeyedMsg("S2IZ0046",NIL) - nil - -reportWhatOptions() == - optList1:= "append"/[['%l,'" ",x] for x in $whatOptions] - sayBrightly - ['%b,'" )what",'%d,'"argument keywords are",'%b,:optList1,'%d,'%l, - '" or abbreviations thereof.",'%l, - '%l,'" Issue",'%b,'")what ?",'%d,'"for more information."] - -filterListOfStrings(patterns,names) == - -- names and patterns are lists of strings - -- returns: list of strings in names that contains any of the strings - -- in patterns - (null patterns) or (null names) => names - names' := NIL - for name in reverse names repeat - satisfiesRegularExpressions(name,patterns) => - names' := [name,:names'] - names' - -filterListOfStringsWithFn(patterns,names,fn) == - -- names and patterns are lists of strings - -- fn is something like CAR or CADR - -- returns: list of strings in names that contains any of the strings - -- in patterns - (null patterns) or (null names) => names - names' := NIL - for name in reverse names repeat - satisfiesRegularExpressions(FUNCALL(fn,name),patterns) => - names' := [name,:names'] - names' - -satisfiesRegularExpressions(name,patterns) == - -- this is a first cut - nf := true - dname := DOWNCASE COPY name - for pattern in patterns while nf repeat - -- use @ as a wildcard - STRPOS(pattern,dname,0,'"@") => nf := nil - null nf - ---% )with ... defined in daase.lisp (boot won't parse it) - ---% )workfiles - -workfiles l == workfilesSpad2Cmd l - -workfilesSpad2Cmd args == - args => throwKeyedMsg("S2IZ0047",NIL) - deleteFlag := nil - for [type,:.] in $options repeat - type1 := selectOptionLC(type,'(boot lisp meta delete),nil) - null type1 => throwKeyedMsg("S2IZ0048",[type]) - type1 = 'delete => deleteFlag := true - for [type,:flist] in $options repeat - type1 := selectOptionLC(type,'(boot lisp meta delete),nil) - type1 = 'delete => nil - for file in flist repeat - fl := pathname [file,type1,'"*"] - deleteFlag => SETQ($sourceFiles,delete(fl,$sourceFiles)) - null (MAKE_-INPUT_-FILENAME fl) => sayKeyedMsg("S2IZ0035",[namestring fl]) - updateSourceFiles fl - SAY " " - centerAndHighlight(" User-specified work files ",$LINELENGTH,specialChar 'hbar) - SAY " " - null $sourceFiles => SAY '" no files specified" - SETQ($sourceFiles,SORTBY('pathnameType,$sourceFiles)) - for fl in $sourceFiles repeat sayBrightly [" " ,namestring fl] - ---% )zsystemdevelopment - -zsystemdevelopment l == zsystemDevelopmentSpad2Cmd l - -zsystemDevelopmentSpad2Cmd l == zsystemdevelopment1 (l,$InteractiveMode) - -zsystemdevelopment1(l,im) == - $InteractiveMode : local := im - fromopt := nil - -- cycle through once to see if )from is mentioned - for [opt,:optargs] in $options repeat - opt1 := selectOptionLC(opt,'(from),nil) - opt1 = 'from => fromopt := [['FROM,:optargs]] - for [opt,:optargs] in $options repeat - if null optargs then optargs := l - newopt := APPEND(optargs,fromopt) - opt1 := selectOptionLC(opt,'(from),nil) - opt1 = 'from => nil - opt = "c" => _/D_,1 (newopt ,_/COMP(),NIL,NIL) - opt = "d" => _/D_,1 (newopt ,'DEFINE,NIL,NIL) - opt = "dt" => _/D_,1 (newopt ,'DEFINE,NIL,true) - opt = "ct" => _/D_,1 (newopt ,_/COMP(),NIL,true) - opt = "ctl" => _/D_,1 (newopt ,_/COMP(),NIL,'TRACELET) - opt = "ec" => _/D_,1 (newopt ,_/COMP(),true,NIL) - opt = "ect" => _/D_,1 (newopt ,_/COMP(),true,true) - opt = "e" => _/D_,1 (newopt ,NIL,true,NIL) - opt = "version" => version() - opt = "pause" => - conStream := DEFIOSTREAM ('((DEVICE . CONSOLE) (QUAL . V)),120,0) - NEXT conStream - SHUT conStream - opt = "update" or opt = "patch" => - $InteractiveMode := nil - upf := [KAR optargs or _/VERSION, KADR optargs or _/WSNAME, - KADDR optargs or '_*] - fun := (opt = "patch" => '_/UPDATE_-LIB_-1; '_/UPDATE_-1) - CATCH('FILENAM, FUNCALL(fun, upf)) - sayMessage '" Update/patch is completed." - null optargs => - sayBrightly ['" An argument is required for",:bright opt] - sayMessage ['" Unknown option:",:bright opt," ",'%l, - '" Available options are", _ - :bright '"c ct e ec ect cls pause update patch compare record"] - ---% Synonym File Reader - ---------------------> NEW DEFINITION (override in util.lisp.pamphlet) -processSynonyms() == - p := STRPOS('")",LINE,0,NIL) - fill := '"" - if p - then - line := SUBSTRING(LINE,p,NIL) - if p > 0 then fill := SUBSTRING(LINE,0,p) - else - p := 0 - line := LINE - to := STRPOS ('" ", line, 1, nil) - if to then to := to - 1 - synstr := SUBSTRING (line, 1, to) - syn := STRING2ID_-N (synstr, 1) - null (fun := LASSOC (syn, $CommandSynonymAlist)) => NIL - to := STRPOS('")",fun,1,NIL) - if to and to ^= SIZE(fun)-1 then - opt := STRCONC('" ",SUBSTRING(fun,to,NIL)) - fun := SUBSTRING(fun,0,to-1) - else opt := '" " - if (SIZE synstr) > (SIZE fun) then - for i in (SIZE fun)..(SIZE synstr) repeat - fun := CONCAT (fun, '" ") --- $currentLine := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) - cl := STRCONC(fill,RPLACSTR(line, 1, SIZE synstr, fun),opt) - SETQ(LINE,cl) - SETQ(CHR,LINE.(p+1)) - processSynonyms () - --- functions for interfacing to system commands from algebra code --- common lisp dependent - -tabsToBlanks s == - k := charPosition($charTab,s,0) - n := #s - k < n => - k = 0 => tabsToBlanks SUBSTRING(s,1,nil) - STRCONC(SUBSTRING(s,0,k),$charBlank, tabsToBlanks SUBSTRING(s,k + 1,nil)) - s - -doSystemCommand string == - string := CONCAT('")", EXPAND_-TABS string) - LINE: fluid := string - processSynonyms() - string := LINE - string:=SUBSTRING(string,1,nil) - string = '"" => nil - tok:=getFirstWord(string) - tok => - unab := unAbbreviateKeyword tok - member(unab, $noParseCommands) => - handleNoParseCommands(unab, string) - optionList := splitIntoOptionBlocks string - member(unab, $tokenCommands) => - handleTokensizeSystemCommands(unab, optionList) - handleParsedSystemCommands(unab, optionList) - nil - nil - -<> - -npboot str == - sex := string2BootTree str - FORMAT(true, '"~&~S~%", sex) - $ans := EVAL sex - FORMAT(true, '"~&Value = ~S~%", $ans) - -stripLisp str == - found := false - strIndex := 0 - lispStr := '"lisp" - for c0 in 0..#str-1 for c1 in 0..#lispStr-1 repeat - (char str.c0) ^= (char lispStr.c1) => - return nil - strIndex := c0+1 - SUBSEQ(str, strIndex) - - -nplisp str == - $ans := EVAL READ_-FROM_-STRING str - FORMAT(true, '"~&Value = ~S~%", $ans) - -npsystem(unab, str) == - spaceIndex := SEARCH('" ", str) - null spaceIndex => - sayKeyedMsg('"S2IZ0080", [str]) - sysPart := SUBSEQ(str, 0, spaceIndex) - -- The following is a hack required by the fact that unAbbreviateKeyword - -- returns the word "system" for unknown words - null SEARCH(sysPart, STRING unab) => - sayKeyedMsg('"S2IZ0080", [sysPart]) - command := SUBSEQ(str, spaceIndex+1) - OBEY command - -npsynonym(unab, str) == - npProcessSynonym(str) - -tokenSystemCommand(unabr, tokList) == - systemCommand tokList - -tokTran tok == - STRINGP tok => - #tok = 0 => nil - isIntegerString tok => READ_-FROM_-STRING tok - STRING tok.0 = '"_"" => - SUBSEQ(tok, 1, #tok-1) - INTERN tok - tok - -isIntegerString tok == - for i in 0..#tok-1 repeat - val := DIGIT_-CHAR_-P tok.i - not val => return nil - val - -splitIntoOptionBlocks str == - inString := false - optionBlocks := nil - blockStart := 0 - parenCount := 0 - for i in 0..#str-1 repeat - STRING str.i = '"_"" => - inString := not inString - if STRING str.i = '"(" and not inString - then parenCount := parenCount + 1 - if STRING str.i = '")" and not inString - then parenCount := parenCount - 1 - STRING str.i = '")" and not inString and parenCount = -1 => - block := stripSpaces SUBSEQ(str, blockStart, i) - blockList := [block, :blockList] - blockStart := i+1 - parenCount := 0 - blockList := [stripSpaces SUBSEQ(str, blockStart), :blockList] - nreverse blockList - -dumbTokenize str == - -- split into tokens delimted by spaces, taking quoted strings into account - inString := false - tokenList := nil - tokenStart := 0 - previousSpace := false - for i in 0..#str-1 repeat - STRING str.i = '"_"" => - inString := not inString - previousSpace := false - STRING str.i = '" " and not inString => - previousSpace => nil - token := stripSpaces SUBSEQ(str, tokenStart, i) - tokenList := [token, :tokenList] - tokenStart := i+1 - previousSpace := true - previousSpace := false - tokenList := [stripSpaces SUBSEQ(str, tokenStart), :tokenList] - nreverse tokenList - -handleParsedSystemCommands(unabr, optionList) == - restOptionList := [dumbTokenize opt for opt in CDR optionList] - parcmd := [parseSystemCmd CAR optionList, - :[[tokTran tok for tok in opt] for opt in restOptionList]] - systemCommand parcmd - -parseSystemCmd opt == - spaceIndex := SEARCH('" ", opt) - spaceIndex => - commandString := stripSpaces SUBSEQ(opt, 0, spaceIndex) - argString := stripSpaces SUBSEQ(opt, spaceIndex) - command := tokTran commandString - pform := parseFromString argString - [command, pform] - [tokTran tok for tok in dumbTokenize opt] - ---------------------> NEW DEFINITION (override in osyscmd.boot.pamphlet) -parseFromString(s) == - $useNewParser => - ncParseFromString s - $InteractiveMode :local := true - $BOOT: local := NIL - $SPAD: local := true - $e:local := $InteractiveFrame - string2SpadTree s - -handleTokensizeSystemCommands(unabr, optionList) == - optionList := [dumbTokenize opt for opt in optionList] - parcmd := [[tokTran tok for tok in opt] for opt in optionList] - parcmd => tokenSystemCommand(unabr, parcmd) - -getFirstWord string == - spaceIndex := SEARCH('" ", string) - null spaceIndex => string - stripSpaces SUBSEQ(string, 0, spaceIndex) - -ltrace l == trace l - ---------------------> NEW DEFINITION (see intint.lisp.pamphlet) -stripSpaces str == - STRING_-TRIM([char '" "], str) - -npProcessSynonym(str) == - if str = '"" then printSynonyms(NIL) - else - pair := processSynonymLine str - if $CommandSynonymAlist then - PUTALIST($CommandSynonymAlist,CAR pair, CDR pair) - else $CommandSynonymAlist := [pair] - terminateSystemCommand() - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} [[src/interp/setq.lisp.pamphlet]] -\end{thebibliography} -\end{document} diff --git a/src/interp/i-toplev.boot b/src/interp/i-toplev.boot new file mode 100644 index 00000000..b94a5ca8 --- /dev/null +++ b/src/interp/i-toplev.boot @@ -0,0 +1,335 @@ +-- 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. + + +import '"i-analy" +)package "BOOT" + +--% Top Level Interpreter Code + +-- When $QuiteCommand is true Spad will not produce any output from +-- a top level command +$QuietCommand := NIL +-- When $ProcessInteractiveValue is true, we don't want the value printed +-- or recorded. +$ProcessInteractiveValue := NIL +$HTCompanionWindowID := NIL + +--% Starting the interpreter from LISP + +spadpo() == + -- starts the interpreter but only displays parsed input + $PrintOnly: local:= true + spad() + +start(:l) == + -- The function start begins the interpreter process, reading in + -- the profile and printing start-up messages. + $PrintCompilerMessageIfTrue: local + $inLispVM : local := nil + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"interpreter"]) + initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses) + statisticsInitialization() + $InteractiveFrame := makeInitialModemapFrame() + initializeSystemCommands() + initializeInterpreterFrameRing() + SETQ(ERROROUTSTREAM, + DEFIOSTREAM('((DEVICE . CONSOLE)(MODE . OUTPUT)),80,0)) + setOutputAlgebra "%initialize%" + loadExposureGroupData() + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"database"]) + mkLowerCaseConTable() + if not $ruleSetsInitialized then initializeRuleSets() + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"constructors"]) + makeConstructorsAutoLoad() + GCMSG(NIL) + SETQ($IOindex,1) + if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"history"]) + initHist() + if functionp 'addtopath then addtopath CONCAT(systemRootDirectory(),'"bin") + SETQ($CURRENT_-DIRECTORY,_*DEFAULT_-PATHNAME_-DEFAULTS_*) + if null(l) then + if $displayStartMsgs then + sayKeyedMsg("S2IZ0053",[namestring ['_.axiom,'input]]) + readSpadProfileIfThere() + if $displayStartMsgs then spadStartUpMsgs() + if $OLDLINE then + SAY fillerSpaces($LINELENGTH,'"=") + sayKeyedMsg("S2IZ0050",[namestring ['axiom,'input]]) + if $OLDLINE ^= 'END__UNIT + then + centerAndHighlight($OLDLINE,$LINELENGTH,'" ") + sayKeyedMsg("S2IZ0051",NIL) + else sayKeyedMsg("S2IZ0052",NIL) + SAY fillerSpaces($LINELENGTH,'"=") + TERPRI() + $OLDLINE := NIL + $superHash := MAKE_-HASHTABLE('UEQUAL) + if null l then runspad() + 'EndOfSpad + +readSpadProfileIfThere() == + -- reads SPADPROF INPUT if it exists + file := ['_.axiom,'input] + MAKE_-INPUT_-FILENAME file => + SETQ(_/EDITFILE,file) + _/RQ () + NIL + +--% Parser Output --> Interpreter + +processInteractive(form, posnForm) == + -- Top-level dispatcher for the interpreter. It sets local variables + -- and then calls processInteractive1 to do most of the work. + -- This function receives the output from the parser. + + initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses) + + $op: local:= (form is [op,:.] => op; form) --name of operator + $Coerce: local := NIL + $compErrorMessageStack:local + $freeVars : local := NIL + $mapList:local := NIL --list of maps being type analyzed + $compilingMap:local:= NIL --true when compiling a map + $compilingLoop:local:= NIL --true when compiling a loop body + $interpOnly: local := NIL --true when in interpret only mode + $whereCacheList: local := NIL --maps compiled because of where + $timeGlobalName: local := '$compTimeSum --see incrementTimeSum + $StreamFrame: local := nil --used in printing streams + $declaredMode: local := NIL --Weak type propagation for symbols + $localVars:local := NIL --list of local variables in function + $analyzingMapList:local := NIL --names of maps currently being + --analyzed + $lastLineInSEQ: local := true --see evalIF and friends + $instantCoerceCount: local := 0 + $instantCanCoerceCount: local := 0 + $instantMmCondCount: local := 0 + $defaultFortVar:= 'X --default FORTRAN variable name + $fortVar : local := --variable name for FORTRAN output + $defaultFortVar + $minivector: local := NIL + $minivectorCode: local := NIL + $minivectorNames: local := NIL + $domPvar: local := NIL + $inRetract: local := NIL + object := processInteractive1(form, posnForm) + --object := ERRORSET(LIST('processInteractive1,LIST('QUOTE,form),LIST('QUOTE,posnForm)),'t,'t) + if not($ProcessInteractiveValue) then + if $reportInstantiations = true then + reportInstantiations() + CLRHASH $instantRecord + writeHistModesAndValues() + updateHist() + object + +processInteractive1(form, posnForm) == + -- calls the analysis and output printing routines + $e : local := $InteractiveFrame + recordFrame 'system + + startTimingProcess 'analysis + object := interpretTopLevel(form, posnForm) + stopTimingProcess 'analysis + + startTimingProcess 'print + if not($ProcessInteractiveValue) then + recordAndPrint(objValUnwrap object,objMode object) + recordFrame 'normal + stopTimingProcess 'print + +--spadtestValueHook(objValUnwrap object, objMode object) + + object + +--% Result Output Printing + +recordAndPrint(x,md) == + -- Prints out the value x which is of type m, and records the changes + -- in environment $e into $InteractiveFrame + -- $printAnyIfTrue is documented in setvart.boot. controlled with )se me any + if md = '(Any) and $printAnyIfTrue then + md' := first x + x' := rest x + else + x' := x + md' := md + $outputMode: local := md --used by DEMO BOOT + mode:= (md=$EmptyMode => quadSch(); md) + if (md ^= $Void) or $printVoidIfTrue then + if null $collectOutput then TERPRI $algebraOutputStream + if $QuietCommand = false then + output(x',md') + putHist('%,'value,objNewWrap(x,md),$e) + if $printTimeIfTrue or $printTypeIfTrue then printTypeAndTime(x',md') + if $printStorageIfTrue then printStorage() + if $printStatisticsSummaryIfTrue then printStatisticsSummary() + if FIXP $HTCompanionWindowID then mkCompanionPage md + $mkTestFlag = true => recordAndPrintTest md + $runTestFlag => + $mkTestOutputType := md + 'done + 'done + +printTypeAndTime(x,m) == --m is the mode/type of the result + $saturn => printTypeAndTimeSaturn(x, m) + printTypeAndTimeNormal(x, m) + +printTypeAndTimeNormal(x,m) == + -- called only if either type or time is to be displayed + if m is ['Union, :argl] then + x' := retract(objNewWrap(x,m)) + m' := objMode x' + m := ['Union, :[arg for arg in argl | sameUnionBranch(arg, m')], '"..."] + if $printTimeIfTrue then + timeString := makeLongTimeString($interpreterTimedNames, + $interpreterTimedClasses) + $printTimeIfTrue and $printTypeIfTrue => + $collectOutput => + $outputLines := [msgText("S2GL0012", [m]), :$outputLines] + sayKeyedMsg("S2GL0014",[m,timeString]) + $printTimeIfTrue => + $collectOutput => nil + sayKeyedMsg("S2GL0013",[timeString]) + $printTypeIfTrue => + $collectOutput => + $outputLines := [justifyMyType msgText("S2GL0012", [m]), :$outputLines] + sayKeyedMsg("S2GL0012",[m]) + +printTypeAndTimeSaturn(x, m) == + -- header + if $printTimeIfTrue then + timeString := makeLongTimeString($interpreterTimedNames, + $interpreterTimedClasses) + else + timeString := '"" + if $printTypeIfTrue then + typeString := form2StringAsTeX devaluate m + else + typeString := '"" + if $printTypeIfTrue then + printAsTeX('"\axPrintType{") + if CONSP typeString then + MAPC(FUNCTION printAsTeX, typeString) + else + printAsTeX(typeString) + printAsTeX('"}") + if $printTimeIfTrue then + printAsTeX('"\axPrintTime{") + printAsTeX(timeString) + printAsTeX('"}") + +printAsTeX(x) == PRINC(x, $texOutputStream) + +sameUnionBranch(uArg, m) == + uArg is [":", ., t] => t = m + uArg = m + +msgText(key, args) == + msg := segmentKeyedMsg getKeyedMsg key + msg := substituteSegmentedMsg(msg,args) + msg := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN) + APPLY(function CONCAT, [STRINGIMAGE x for x in CDAR msg]) + +justifyMyType(t) == + len := #t + len > $LINELENGTH => t + CONCAT(fillerSpaces($LINELENGTH-len), t) + +typeTimePrin x == + $highlightDelta: local:= 0 + maprinSpecial(x,0,79) + +printStorage() == + $collectOutput => nil + storeString := + makeLongSpaceString($interpreterTimedNames, $interpreterTimedClasses) + sayKeyedMsg("S2GL0016",[storeString]) + +printStatisticsSummary() == + $collectOutput => nil + summary := statisticsSummary() + sayKeyedMsg("S2GL0017",[summary]) + +--% Interpreter Middle-Level Driver + Utilities + +interpretTopLevel(x, posnForm) == + -- Top level entry point from processInteractive1. Sets up catch + -- for a thrown result + savedTimerStack := COPY $timedNameStack + c := CATCH('interpreter,interpret(x, posnForm)) + while savedTimerStack ^= $timedNameStack repeat + stopTimingProcess peekTimedName() + c = 'tryAgain => interpretTopLevel(x, posnForm) + c + +interpret(x, :restargs) == + posnForm := if PAIRP restargs then CAR restargs else restargs + --type analyzes and evaluates expression x, returns object + $env:local := [[NIL]] + $eval:local := true --generate code-- don't just type analyze + $genValue:local := true --evaluate all generated code + interpret1(x,nil,posnForm) + +interpret1(x,rootMode,posnForm) == + -- dispatcher for the type analysis routines. type analyzes and + -- evaluates the expression x in the rootMode (if non-nil) + -- which may be $EmptyMode. returns an object if evaluating, and a + -- modeset otherwise + + -- create the attributed tree + + node := mkAtreeWithSrcPos(x, posnForm) + if rootMode then putTarget(node,rootMode) + + -- do type analysis and evaluation of expression. The real guts + + modeSet:= bottomUp node + not $eval => modeSet + newRootMode := (null rootMode => first modeSet ; rootMode) + argVal := getArgValue(node, newRootMode) + argVal and not $genValue => objNew(argVal, newRootMode) + argVal and (val:=getValue node) => interpret2(val,newRootMode,posnForm) + keyedSystemError("S2IS0053",[x]) + +interpret2(object,m1,posnForm) == + -- this is the late interpretCoerce. I removed the call to + -- coerceInteractive, so it only does the JENKS cases ALBI + m1=$ThrowAwayMode => object + x := objVal object + m := objMode object + m=$EmptyMode => + x is [op,:.] and op in '(MAP STREAM) => objNew(x,m1) + m1 = $EmptyMode => objNew(x,m) + systemErrorHere '"interpret2" + m1 => + if (ans := coerceInteractive(object,m1)) then ans + else throwKeyedMsgCannotCoerceWithValue(x,m,m1) + object diff --git a/src/interp/i-toplev.boot.pamphlet b/src/interp/i-toplev.boot.pamphlet deleted file mode 100644 index 411d9b05..00000000 --- a/src/interp/i-toplev.boot.pamphlet +++ /dev/null @@ -1,363 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-toplev.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -This file contains the top-most code for receiving parser output, -calling the analysis routines and printing the result output. It -also contains several flavors of routines that start the interpreter -from LISP. -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"i-analy" -)package "BOOT" - ---% Top Level Interpreter Code - --- When $QuiteCommand is true Spad will not produce any output from --- a top level command -$QuietCommand := NIL --- When $ProcessInteractiveValue is true, we don't want the value printed --- or recorded. -$ProcessInteractiveValue := NIL -$HTCompanionWindowID := NIL - ---% Starting the interpreter from LISP - -spadpo() == - -- starts the interpreter but only displays parsed input - $PrintOnly: local:= true - spad() - -start(:l) == - -- The function start begins the interpreter process, reading in - -- the profile and printing start-up messages. - $PrintCompilerMessageIfTrue: local - $inLispVM : local := nil - if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"interpreter"]) - initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses) - statisticsInitialization() - $InteractiveFrame := makeInitialModemapFrame() - initializeSystemCommands() - initializeInterpreterFrameRing() - SETQ(ERROROUTSTREAM, - DEFIOSTREAM('((DEVICE . CONSOLE)(MODE . OUTPUT)),80,0)) - setOutputAlgebra "%initialize%" - loadExposureGroupData() - if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"database"]) - mkLowerCaseConTable() - if not $ruleSetsInitialized then initializeRuleSets() - if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"constructors"]) - makeConstructorsAutoLoad() - GCMSG(NIL) - SETQ($IOindex,1) - if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"history"]) - initHist() - if functionp 'addtopath then addtopath CONCAT(systemRootDirectory(),'"bin") - SETQ($CURRENT_-DIRECTORY,_*DEFAULT_-PATHNAME_-DEFAULTS_*) - if null(l) then - if $displayStartMsgs then - sayKeyedMsg("S2IZ0053",[namestring ['_.axiom,'input]]) - readSpadProfileIfThere() - if $displayStartMsgs then spadStartUpMsgs() - if $OLDLINE then - SAY fillerSpaces($LINELENGTH,'"=") - sayKeyedMsg("S2IZ0050",[namestring ['axiom,'input]]) - if $OLDLINE ^= 'END__UNIT - then - centerAndHighlight($OLDLINE,$LINELENGTH,'" ") - sayKeyedMsg("S2IZ0051",NIL) - else sayKeyedMsg("S2IZ0052",NIL) - SAY fillerSpaces($LINELENGTH,'"=") - TERPRI() - $OLDLINE := NIL - $superHash := MAKE_-HASHTABLE('UEQUAL) - if null l then runspad() - 'EndOfSpad - -readSpadProfileIfThere() == - -- reads SPADPROF INPUT if it exists - file := ['_.axiom,'input] - MAKE_-INPUT_-FILENAME file => - SETQ(_/EDITFILE,file) - _/RQ () - NIL - ---% Parser Output --> Interpreter - -processInteractive(form, posnForm) == - -- Top-level dispatcher for the interpreter. It sets local variables - -- and then calls processInteractive1 to do most of the work. - -- This function receives the output from the parser. - - initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses) - - $op: local:= (form is [op,:.] => op; form) --name of operator - $Coerce: local := NIL - $compErrorMessageStack:local - $freeVars : local := NIL - $mapList:local := NIL --list of maps being type analyzed - $compilingMap:local:= NIL --true when compiling a map - $compilingLoop:local:= NIL --true when compiling a loop body - $interpOnly: local := NIL --true when in interpret only mode - $whereCacheList: local := NIL --maps compiled because of where - $timeGlobalName: local := '$compTimeSum --see incrementTimeSum - $StreamFrame: local := nil --used in printing streams - $declaredMode: local := NIL --Weak type propagation for symbols - $localVars:local := NIL --list of local variables in function - $analyzingMapList:local := NIL --names of maps currently being - --analyzed - $lastLineInSEQ: local := true --see evalIF and friends - $instantCoerceCount: local := 0 - $instantCanCoerceCount: local := 0 - $instantMmCondCount: local := 0 - $defaultFortVar:= 'X --default FORTRAN variable name - $fortVar : local := --variable name for FORTRAN output - $defaultFortVar - $minivector: local := NIL - $minivectorCode: local := NIL - $minivectorNames: local := NIL - $domPvar: local := NIL - $inRetract: local := NIL - object := processInteractive1(form, posnForm) - --object := ERRORSET(LIST('processInteractive1,LIST('QUOTE,form),LIST('QUOTE,posnForm)),'t,'t) - if not($ProcessInteractiveValue) then - if $reportInstantiations = true then - reportInstantiations() - CLRHASH $instantRecord - writeHistModesAndValues() - updateHist() - object - -processInteractive1(form, posnForm) == - -- calls the analysis and output printing routines - $e : local := $InteractiveFrame - recordFrame 'system - - startTimingProcess 'analysis - object := interpretTopLevel(form, posnForm) - stopTimingProcess 'analysis - - startTimingProcess 'print - if not($ProcessInteractiveValue) then - recordAndPrint(objValUnwrap object,objMode object) - recordFrame 'normal - stopTimingProcess 'print - ---spadtestValueHook(objValUnwrap object, objMode object) - - object - ---% Result Output Printing - -recordAndPrint(x,md) == - -- Prints out the value x which is of type m, and records the changes - -- in environment $e into $InteractiveFrame - -- $printAnyIfTrue is documented in setvart.boot. controlled with )se me any - if md = '(Any) and $printAnyIfTrue then - md' := first x - x' := rest x - else - x' := x - md' := md - $outputMode: local := md --used by DEMO BOOT - mode:= (md=$EmptyMode => quadSch(); md) - if (md ^= $Void) or $printVoidIfTrue then - if null $collectOutput then TERPRI $algebraOutputStream - if $QuietCommand = false then - output(x',md') - putHist('%,'value,objNewWrap(x,md),$e) - if $printTimeIfTrue or $printTypeIfTrue then printTypeAndTime(x',md') - if $printStorageIfTrue then printStorage() - if $printStatisticsSummaryIfTrue then printStatisticsSummary() - if FIXP $HTCompanionWindowID then mkCompanionPage md - $mkTestFlag = true => recordAndPrintTest md - $runTestFlag => - $mkTestOutputType := md - 'done - 'done - -printTypeAndTime(x,m) == --m is the mode/type of the result - $saturn => printTypeAndTimeSaturn(x, m) - printTypeAndTimeNormal(x, m) - -printTypeAndTimeNormal(x,m) == - -- called only if either type or time is to be displayed - if m is ['Union, :argl] then - x' := retract(objNewWrap(x,m)) - m' := objMode x' - m := ['Union, :[arg for arg in argl | sameUnionBranch(arg, m')], '"..."] - if $printTimeIfTrue then - timeString := makeLongTimeString($interpreterTimedNames, - $interpreterTimedClasses) - $printTimeIfTrue and $printTypeIfTrue => - $collectOutput => - $outputLines := [msgText("S2GL0012", [m]), :$outputLines] - sayKeyedMsg("S2GL0014",[m,timeString]) - $printTimeIfTrue => - $collectOutput => nil - sayKeyedMsg("S2GL0013",[timeString]) - $printTypeIfTrue => - $collectOutput => - $outputLines := [justifyMyType msgText("S2GL0012", [m]), :$outputLines] - sayKeyedMsg("S2GL0012",[m]) - -printTypeAndTimeSaturn(x, m) == - -- header - if $printTimeIfTrue then - timeString := makeLongTimeString($interpreterTimedNames, - $interpreterTimedClasses) - else - timeString := '"" - if $printTypeIfTrue then - typeString := form2StringAsTeX devaluate m - else - typeString := '"" - if $printTypeIfTrue then - printAsTeX('"\axPrintType{") - if CONSP typeString then - MAPC(FUNCTION printAsTeX, typeString) - else - printAsTeX(typeString) - printAsTeX('"}") - if $printTimeIfTrue then - printAsTeX('"\axPrintTime{") - printAsTeX(timeString) - printAsTeX('"}") - -printAsTeX(x) == PRINC(x, $texOutputStream) - -sameUnionBranch(uArg, m) == - uArg is [":", ., t] => t = m - uArg = m - -msgText(key, args) == - msg := segmentKeyedMsg getKeyedMsg key - msg := substituteSegmentedMsg(msg,args) - msg := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN) - APPLY(function CONCAT, [STRINGIMAGE x for x in CDAR msg]) - -justifyMyType(t) == - len := #t - len > $LINELENGTH => t - CONCAT(fillerSpaces($LINELENGTH-len), t) - -typeTimePrin x == - $highlightDelta: local:= 0 - maprinSpecial(x,0,79) - -printStorage() == - $collectOutput => nil - storeString := - makeLongSpaceString($interpreterTimedNames, $interpreterTimedClasses) - sayKeyedMsg("S2GL0016",[storeString]) - -printStatisticsSummary() == - $collectOutput => nil - summary := statisticsSummary() - sayKeyedMsg("S2GL0017",[summary]) - ---% Interpreter Middle-Level Driver + Utilities - -interpretTopLevel(x, posnForm) == - -- Top level entry point from processInteractive1. Sets up catch - -- for a thrown result - savedTimerStack := COPY $timedNameStack - c := CATCH('interpreter,interpret(x, posnForm)) - while savedTimerStack ^= $timedNameStack repeat - stopTimingProcess peekTimedName() - c = 'tryAgain => interpretTopLevel(x, posnForm) - c - -interpret(x, :restargs) == - posnForm := if PAIRP restargs then CAR restargs else restargs - --type analyzes and evaluates expression x, returns object - $env:local := [[NIL]] - $eval:local := true --generate code-- don't just type analyze - $genValue:local := true --evaluate all generated code - interpret1(x,nil,posnForm) - -interpret1(x,rootMode,posnForm) == - -- dispatcher for the type analysis routines. type analyzes and - -- evaluates the expression x in the rootMode (if non-nil) - -- which may be $EmptyMode. returns an object if evaluating, and a - -- modeset otherwise - - -- create the attributed tree - - node := mkAtreeWithSrcPos(x, posnForm) - if rootMode then putTarget(node,rootMode) - - -- do type analysis and evaluation of expression. The real guts - - modeSet:= bottomUp node - not $eval => modeSet - newRootMode := (null rootMode => first modeSet ; rootMode) - argVal := getArgValue(node, newRootMode) - argVal and not $genValue => objNew(argVal, newRootMode) - argVal and (val:=getValue node) => interpret2(val,newRootMode,posnForm) - keyedSystemError("S2IS0053",[x]) - -interpret2(object,m1,posnForm) == - -- this is the late interpretCoerce. I removed the call to - -- coerceInteractive, so it only does the JENKS cases ALBI - m1=$ThrowAwayMode => object - x := objVal object - m := objMode object - m=$EmptyMode => - x is [op,:.] and op in '(MAP STREAM) => objNew(x,m1) - m1 = $EmptyMode => objNew(x,m) - systemErrorHere '"interpret2" - m1 => - if (ans := coerceInteractive(object,m1)) then ans - else throwKeyedMsgCannotCoerceWithValue(x,m,m1) - object -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot new file mode 100644 index 00000000..b064c526 --- /dev/null +++ b/src/interp/i-util.boot @@ -0,0 +1,229 @@ +-- 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. + + +import '"g-util" +)package "BOOT" + +--% The function for making prompts + +spadPrompt() == + SAY '" AXIOM" + sayNewLine() + +inputPrompt str == + -- replaces older INPUT-PROMPT + atom (x := $SCREENSIZE()) => NIL + p := CAR(x) - 2 + y := $OLDLINE + SETQ($OLDLINE,NIL) + y => _$SHOWLINE(STRCONC(str,EBCDIC 19,y),p) + 0 = SIZE str => NIL + _$SHOWLINE(STRCONC(str,EBCDIC 19),p) + +protectedPrompt(:p) == + [str,:br] := p + 0 = SIZE str => inputPrompt str + msg := EBCDIC 29 -- start of field + msg := + if br then STRCONC(msg,EBCDIC 232) -- bright write protect + else STRCONC(msg,EBCDIC 96) -- write protect + msg := STRCONC(msg,str,EBCDIC 29,EBCDIC 64) -- unprotect again + inputPrompt msg + +MKPROMPT() == + $inputPromptType = 'none => '"" + $inputPromptType = 'plain => '"-> " + $inputPromptType = 'step => + STRCONC('"(",STRINGIMAGE $IOindex,'") -> ") + $inputPromptType = 'frame => + STRCONC(STRINGIMAGE $interpreterFrameName, + '" (",STRINGIMAGE $IOindex,'") -> ") + STRCONC(STRINGIMAGE $interpreterFrameName, + '" [", SUBSTRING(CURRENTTIME(),8,NIL),'"] [", + STRINGIMAGE $IOindex, '"] -> ") + +--% Miscellaneous + +Zeros n == + BOUNDP '$ZeroVecCache and #$ZeroVecCache=n => $ZeroVecCache + $ZeroVecCache:= MAKE_-VEC n + for i in 0..n-1 repeat $ZeroVecCache.i:=0 + $ZeroVecCache + +LZeros n == + n < 1 => nil + l := [0] + for i in 2..n repeat l := [0, :l] + l + +-- bpi2FunctionName x == +-- s:= BPINAME x => s +-- x + +-- subrToName x == BPINAME x + +-- formerly in clammed.boot + +isSubDomain(d1,d2) == + -- d1 and d2 are different domains + subDomainList := '(Integer NonNegativeInteger PositiveInteger) + ATOM d1 or ATOM d2 => nil + l := MEMQ(CAR d2, subDomainList) => + MEMQ(CAR d1, CDR l) + nil + +$variableNumberAlist := nil + +variableNumber(x) == + p := ASSQ(x, $variableNumberAlist) + null p => + $variableNumberAlist := [[x,:0], :$variableNumberAlist] + 0 + RPLACD(p, 1+CDR p) + CDR p + +newType? t == nil + + +-- functions used at run-time which were formerly in the compiler files + +Undef(:u) == + u':= LAST u + [[domain,slot],op,sig]:= u' + domain':=eval mkEvalable domain + ^EQ(CAR ELT(domain',slot), function Undef) => +-- OK - thefunction is now defined + [:u'',.]:=u + if $reportBottomUpFlag then + sayMessage concat ['" Retrospective determination of slot",'%b, + slot,'%d,'"of",'%b,:prefix2String domain,'%d] + APPLY(CAR ELT(domain',slot),[:u'',CDR ELT(domain',slot)]) + throwKeyedMsg("S2IF0008",[formatOpSignature(op,sig),domain]) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +devaluate d == + not REFVECP d => d + QSGREATERP(QVSIZE d,5) and QREFELT(d,3) is ['Category] => QREFELT(d,0) + QSGREATERP(QVSIZE d,0) => + d':=QREFELT(d,0) + isFunctor d' => d' + d + d + +devaluateList l == [devaluate d for d in l] + +--HasAttribute(domain,attrib) == +----> +-- isNewWorldDomain domain => newHasAttribute(domain,attrib) +----+ +-- (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain) + +HasSignature(domain,[op,sig]) == + compiledLookup(op,sig,domain) + +--HasCategory(domain,catform') == +-- catform' is ['SIGNATURE,:f] => HasSignature(domain,f) +-- catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f) +-- catform:= devaluate catform' +-- domain0:=domain.0 +-- isNewWorldDomain domain => newHasCategory(domain,catform) +-- slot4 := domain.4 +-- catlist := slot4.1 +-- member(catform,catlist) or +-- MEMQ(opOf(catform),'(Object Type)) or --temporary hack +-- or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] + +makeInitialModemapFrame() == COPY $InitialModemapFrame + +isCapitalWord x == + (y := PNAME x) and and/[UPPER_-CASE_-P y.i for i in 0..MAXINDEX y] + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +domainEqual(a,b) == VECP a and VECP b and a.0 = b.0 + +lispize x == first optimize [x] + +$newCompilerUnionFlag := true + +orderUnionEntries l == + $newCompilerUnionFlag => l + first l is [":",.,.] => l -- new style Unions + [a,b]:= + split(l,nil,nil) where + split(l,a,b) == + l is [x,:l'] => + (STRINGP x => split(l',[x,:a],b); split(l',a,[x,:b])) + [a,b] + [:orderList a,:orderList b] + +mkPredList listOfEntries == + $newCompilerUnionFlag => + [['EQCAR,"#1",i] for arg in listOfEntries for i in 0..] + first listOfEntries is [":",.,.] => -- new Tagged Unions + [['EQCAR,"#1",MKQ tag] for [.,tag,.] in listOfEntries] + --1. generate list of type-predicate pairs from union specification + initTypePredList:= + [selTypePred for x in listOfEntries] where + selTypePred() == + STRINGP x => [x,'EQUAL,"#1",x] + [x,:GETL(opOf x,"BasicPredicate")] + typeList:= ASSOCLEFT initTypePredList + initPredList:= ASSOCRIGHT initTypePredList + hasDuplicatePredicate:= + fn initPredList where + fn x == + null x => false + first x and member(first x,rest x) => true + fn rest x + --if duplicate predicate, kill them all + if hasDuplicatePredicate then initPredList:= [nil for x in initPredList] + nonEmptyPredList:= [p for p in initPredList | p^=nil] + numberWithoutPredicate:= #listOfEntries-#nonEmptyPredList + predList:= + numberWithoutPredicate=0 and not hasDuplicatePredicate => initPredList + numberWithoutPredicate=1 and null LAST initPredList and + [STRINGP x for x in rest REVERSE listOfEntries] => + allButLast:= rest REVERSE initPredList + NREVERSE [['NULL,MKPF(allButLast,"OR")],:allButLast] + --otherwise, generate a tagged-union + --we have made an even number of REVERSE operations, therefore + --the original order is preserved. JHD 25.Sept.1983 + tagPredList:= [["EQCAR","#1",i] for i in 1..numberWithoutPredicate] + [addPredIfNecessary for p in initPredList] where + addPredIfNecessary() == + p => p + [u,:tagPredList]:= tagPredList + u + predList + + + diff --git a/src/interp/i-util.boot.pamphlet b/src/interp/i-util.boot.pamphlet deleted file mode 100644 index 3539c195..00000000 --- a/src/interp/i-util.boot.pamphlet +++ /dev/null @@ -1,263 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-util.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -Wrapping and Unwrapping Values - -A wrapped value represents something that need not be evaluated -when code is generated. This includes objects from domains or things -that just happed to evaluate to themselves. Typically generated -lisp code is unwrapped. - -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"g-util" -)package "BOOT" - ---% The function for making prompts - -spadPrompt() == - SAY '" AXIOM" - sayNewLine() - -inputPrompt str == - -- replaces older INPUT-PROMPT - atom (x := $SCREENSIZE()) => NIL - p := CAR(x) - 2 - y := $OLDLINE - SETQ($OLDLINE,NIL) - y => _$SHOWLINE(STRCONC(str,EBCDIC 19,y),p) - 0 = SIZE str => NIL - _$SHOWLINE(STRCONC(str,EBCDIC 19),p) - -protectedPrompt(:p) == - [str,:br] := p - 0 = SIZE str => inputPrompt str - msg := EBCDIC 29 -- start of field - msg := - if br then STRCONC(msg,EBCDIC 232) -- bright write protect - else STRCONC(msg,EBCDIC 96) -- write protect - msg := STRCONC(msg,str,EBCDIC 29,EBCDIC 64) -- unprotect again - inputPrompt msg - -MKPROMPT() == - $inputPromptType = 'none => '"" - $inputPromptType = 'plain => '"-> " - $inputPromptType = 'step => - STRCONC('"(",STRINGIMAGE $IOindex,'") -> ") - $inputPromptType = 'frame => - STRCONC(STRINGIMAGE $interpreterFrameName, - '" (",STRINGIMAGE $IOindex,'") -> ") - STRCONC(STRINGIMAGE $interpreterFrameName, - '" [", SUBSTRING(CURRENTTIME(),8,NIL),'"] [", - STRINGIMAGE $IOindex, '"] -> ") - ---% Miscellaneous - -Zeros n == - BOUNDP '$ZeroVecCache and #$ZeroVecCache=n => $ZeroVecCache - $ZeroVecCache:= MAKE_-VEC n - for i in 0..n-1 repeat $ZeroVecCache.i:=0 - $ZeroVecCache - -LZeros n == - n < 1 => nil - l := [0] - for i in 2..n repeat l := [0, :l] - l - --- bpi2FunctionName x == --- s:= BPINAME x => s --- x - --- subrToName x == BPINAME x - --- formerly in clammed.boot - -isSubDomain(d1,d2) == - -- d1 and d2 are different domains - subDomainList := '(Integer NonNegativeInteger PositiveInteger) - ATOM d1 or ATOM d2 => nil - l := MEMQ(CAR d2, subDomainList) => - MEMQ(CAR d1, CDR l) - nil - -$variableNumberAlist := nil - -variableNumber(x) == - p := ASSQ(x, $variableNumberAlist) - null p => - $variableNumberAlist := [[x,:0], :$variableNumberAlist] - 0 - RPLACD(p, 1+CDR p) - CDR p - -newType? t == nil - - --- functions used at run-time which were formerly in the compiler files - -Undef(:u) == - u':= LAST u - [[domain,slot],op,sig]:= u' - domain':=eval mkEvalable domain - ^EQ(CAR ELT(domain',slot), function Undef) => --- OK - thefunction is now defined - [:u'',.]:=u - if $reportBottomUpFlag then - sayMessage concat ['" Retrospective determination of slot",'%b, - slot,'%d,'"of",'%b,:prefix2String domain,'%d] - APPLY(CAR ELT(domain',slot),[:u'',CDR ELT(domain',slot)]) - throwKeyedMsg("S2IF0008",[formatOpSignature(op,sig),domain]) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -devaluate d == - not REFVECP d => d - QSGREATERP(QVSIZE d,5) and QREFELT(d,3) is ['Category] => QREFELT(d,0) - QSGREATERP(QVSIZE d,0) => - d':=QREFELT(d,0) - isFunctor d' => d' - d - d - -devaluateList l == [devaluate d for d in l] - ---HasAttribute(domain,attrib) == -----> --- isNewWorldDomain domain => newHasAttribute(domain,attrib) -----+ --- (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain) - -HasSignature(domain,[op,sig]) == - compiledLookup(op,sig,domain) - ---HasCategory(domain,catform') == --- catform' is ['SIGNATURE,:f] => HasSignature(domain,f) --- catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f) --- catform:= devaluate catform' --- domain0:=domain.0 --- isNewWorldDomain domain => newHasCategory(domain,catform) --- slot4 := domain.4 --- catlist := slot4.1 --- member(catform,catlist) or --- MEMQ(opOf(catform),'(Object Type)) or --temporary hack --- or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] - -makeInitialModemapFrame() == COPY $InitialModemapFrame - -isCapitalWord x == - (y := PNAME x) and and/[UPPER_-CASE_-P y.i for i in 0..MAXINDEX y] - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -domainEqual(a,b) == VECP a and VECP b and a.0 = b.0 - -lispize x == first optimize [x] - -$newCompilerUnionFlag := true - -orderUnionEntries l == - $newCompilerUnionFlag => l - first l is [":",.,.] => l -- new style Unions - [a,b]:= - split(l,nil,nil) where - split(l,a,b) == - l is [x,:l'] => - (STRINGP x => split(l',[x,:a],b); split(l',a,[x,:b])) - [a,b] - [:orderList a,:orderList b] - -mkPredList listOfEntries == - $newCompilerUnionFlag => - [['EQCAR,"#1",i] for arg in listOfEntries for i in 0..] - first listOfEntries is [":",.,.] => -- new Tagged Unions - [['EQCAR,"#1",MKQ tag] for [.,tag,.] in listOfEntries] - --1. generate list of type-predicate pairs from union specification - initTypePredList:= - [selTypePred for x in listOfEntries] where - selTypePred() == - STRINGP x => [x,'EQUAL,"#1",x] - [x,:GETL(opOf x,"BasicPredicate")] - typeList:= ASSOCLEFT initTypePredList - initPredList:= ASSOCRIGHT initTypePredList - hasDuplicatePredicate:= - fn initPredList where - fn x == - null x => false - first x and member(first x,rest x) => true - fn rest x - --if duplicate predicate, kill them all - if hasDuplicatePredicate then initPredList:= [nil for x in initPredList] - nonEmptyPredList:= [p for p in initPredList | p^=nil] - numberWithoutPredicate:= #listOfEntries-#nonEmptyPredList - predList:= - numberWithoutPredicate=0 and not hasDuplicatePredicate => initPredList - numberWithoutPredicate=1 and null LAST initPredList and - [STRINGP x for x in rest REVERSE listOfEntries] => - allButLast:= rest REVERSE initPredList - NREVERSE [['NULL,MKPF(allButLast,"OR")],:allButLast] - --otherwise, generate a tagged-union - --we have made an even number of REVERSE operations, therefore - --the original order is preserved. JHD 25.Sept.1983 - tagPredList:= [["EQCAR","#1",i] for i in 1..numberWithoutPredicate] - [addPredIfNecessary for p in initPredList] where - addPredIfNecessary() == - p => p - [u,:tagPredList]:= tagPredList - u - predList - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3