diff --git a/changelog b/changelog index 4951176..b5d9a3b 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090822 tpd src/axiom-website/patches.html 20090822.01.tpd.patch +20090822 tpd src/interp/Makefile move i-map.boot to i-map.lisp +20090822 tpd src/interp/i-map.lisp added, rewritten from i-map.boot +20090822 tpd src/interp/i-map.boot removed, rewritten to i-map.lisp 20090821 tpd src/axiom-website/patches.html 20090821.05.tpd.patch 20090821 tpd src/interp/Makefile move i-funsel.boot to i-funsel.lisp 20090821 tpd src/interp/i-funsel.lisp added, rewritten from i-funsel.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index a7c5e57..5cbdb18 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1834,5 +1834,7 @@ bookvol10.4, unittest2 fix credits output
i-intern.lisp rewrite from boot to lisp
20090821.05.tpd.patch i-funsel.lisp rewrite from boot to lisp
+20090822.01.tpd.patch +i-map.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 4b550b8..64686c1 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -427,7 +427,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ - ${DOC}/i-map.boot.dvi ${DOC}/incl.boot.dvi \ + ${DOC}/incl.boot.dvi \ ${DOC}/info.boot.dvi ${DOC}/interop.boot.dvi \ ${DOC}/intfile.boot.dvi \ ${DOC}/intint.lisp.dvi ${DOC}/int-top.boot.dvi \ @@ -3247,45 +3247,27 @@ ${MID}/i-intern.lisp: ${IN}/i-intern.lisp.pamphlet @ -\subsection{i-map.boot} +\subsection{i-map.lisp} <>= -${OUT}/i-map.${O}: ${MID}/i-map.clisp - @ echo 303 making ${OUT}/i-map.${O} from ${MID}/i-map.clisp - @ (cd ${MID} ; \ +${OUT}/i-map.${O}: ${MID}/i-map.lisp + @ echo 136 making ${OUT}/i-map.${O} from ${MID}/i-map.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-map.clisp"' \ + echo '(progn (compile-file "${MID}/i-map.lisp"' \ ':output-file "${OUT}/i-map.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-map.clisp"' \ + echo '(progn (compile-file "${MID}/i-map.lisp"' \ ':output-file "${OUT}/i-map.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-map.clisp: ${IN}/i-map.boot.pamphlet - @ echo 304 making ${MID}/i-map.clisp from ${IN}/i-map.boot.pamphlet +<>= +${MID}/i-map.lisp: ${IN}/i-map.lisp.pamphlet + @ echo 137 making ${MID}/i-map.lisp from \ + ${IN}/i-map.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-map.boot.pamphlet >i-map.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-map.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-map.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-map.boot ) - -@ -<>= -${DOC}/i-map.boot.dvi: ${IN}/i-map.boot.pamphlet - @echo 305 making ${DOC}/i-map.boot.dvi from ${IN}/i-map.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-map.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-map.boot ; \ - rm -f ${DOC}/i-map.boot.pamphlet ; \ - rm -f ${DOC}/i-map.boot.tex ; \ - rm -f ${DOC}/i-map.boot ) + ${TANGLE} ${IN}/i-map.lisp.pamphlet >i-map.lisp ) @ @@ -6525,8 +6507,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-map.boot.pamphlet b/src/interp/i-map.boot.pamphlet deleted file mode 100644 index 97c825b..0000000 --- a/src/interp/i-map.boot.pamphlet +++ /dev/null @@ -1,1181 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-map.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. - -@ -<<*>>= -<> - ---% User Function Creation and Analysis Code - -SETANDFILEQ($mapTarget,nil) -SETANDFILEQ($mapReturnTypes,nil) -SETANDFILEQ($mapName,'noMapName) -SETANDFILEQ($mapThrowCount, 0) -- times a "return" occurs in map -SETANDFILEQ($compilingMap, NIL) -SETANDFILEQ($definingMap, NIL) - ---% Generating internal names for functions - -SETANDFILEQ($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 := - not (GET(op,'Nud) or GET(op,'Led) or GET(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:= setUnion(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-map.lisp.pamphlet b/src/interp/i-map.lisp.pamphlet new file mode 100644 index 0000000..31dd942 --- /dev/null +++ b/src/interp/i-map.lisp.pamphlet @@ -0,0 +1,3915 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-map.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;SETANDFILEQ($mapTarget,nil) + +(SETANDFILEQ |$mapTarget| NIL) + +;SETANDFILEQ($mapReturnTypes,nil) + +(SETANDFILEQ |$mapReturnTypes| NIL) + +;SETANDFILEQ($mapName,'noMapName) + +(SETANDFILEQ |$mapName| (QUOTE |noMapName|)) + +;SETANDFILEQ($mapThrowCount, 0) -- times a "return" occurs in map + +(SETANDFILEQ |$mapThrowCount| 0) + +;SETANDFILEQ($compilingMap, NIL) + +(SETANDFILEQ |$compilingMap| NIL) + +;SETANDFILEQ($definingMap, NIL) + +(SETANDFILEQ |$definingMap| NIL) + +;--% Generating internal names for functions +;SETANDFILEQ($specialMapNameSuffix, NIL) + +(SETANDFILEQ |$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 + +(DEFUN |makeInternalMapName| (|userName| |numArgs| |numMms| |extraPart|) + (PROG (|name|) + (RETURN + (PROGN + (SPADLET |name| + (CONCAT "*" + (STRINGIMAGE |numArgs|) ";" + (|object2String| |userName|) ";" + (STRINGIMAGE |numMms|) ";" + (|object2String| (FRAMENAME (CAR |$interpreterFrameRing|))))) + (COND + (|extraPart| + (SPADLET |name| (CONCAT |name| ";" |extraPart|)))) + (COND + (|$specialMapNameSuffix| + (SPADLET |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 + +(DEFUN |isInternalMapName| (|name|) + (PROG (|name'| |sz|) + (RETURN + (COND + ((OR (NULL (IDENTP |name|)) + (BOOT-EQUAL |name| (QUOTE *)) + (BOOT-EQUAL |name| (QUOTE **))) + NIL) + ((QUOTE T) + (SPADLET |sz| (SIZE (SPADLET |name'| (PNAME |name|)))) + (COND + ((OR (> 7 |sz|) (NEQUAL (|char| (QUOTE *)) (ELT |name'| 0))) NIL) + ((NULL (DIGITP (ELT |name'| 1))) NIL) + ((NULL (STRPOS (MAKESTRING ";") |name'| 1 NIL)) NIL) + ((QUOTE T) (QUOTE T)))))))) + +;makeInternalMapMinivectorName(name) == +; STRINGP name => +; INTERN STRCONC(name,'";MV") +; INTERN STRCONC(PNAME name,'";MV") + +(DEFUN |makeInternalMapMinivectorName| (|name|) + (COND + ((STRINGP |name|) (INTERN (STRCONC |name| (MAKESTRING ";MV")))) + ((QUOTE T) (INTERN (STRCONC (PNAME |name|) (MAKESTRING ";MV")))))) + +;mkCacheName(name) == INTERNL(STRINGIMAGE name,'";AL") + +(DEFUN |mkCacheName| (|name|) + (INTERNL (STRINGIMAGE |name|) (MAKESTRING ";AL"))) + +;mkAuxiliaryName(name) == INTERNL(STRINGIMAGE name,'";AUX") + +(DEFUN |mkAuxiliaryName| (|name|) + (INTERNL (STRINGIMAGE |name|) (MAKESTRING ";AUX"))) + +;--% Adding a function definition +;isMapExpr x == x is ['MAP,:.] + +(DEFUN |isMapExpr| (|x|) + (AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE MAP)))) + +;isMap x == +; y := get(x,'value,$InteractiveFrame) => +; objVal y is ['MAP,:.] => x + +(DEFUN |isMap| (|x|) + (PROG (|y| |ISTMP#1|) + (RETURN + (SEQ + (COND + ((SPADLET |y| (|get| |x| (QUOTE |value|) |$InteractiveFrame|)) + (EXIT + (COND + ((PROGN + (SPADLET |ISTMP#1| (|objVal| |y|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) (QUOTE MAP)))) + (EXIT |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) + +(DEFUN |addDefMap| (#0=#:G166106 |pred|) + (PROG (|$env| |$eval| |$genValue| |$freeVars| |$localVars| |mapsig| |rhs| + |lhs| |op| |oldMode| |op'| |parameters| |someDecs| |d'| |allDecs| + |mapmode| |ISTMP#1| |ISTMP#2| |mapargs| |numargs| |userVariables1| + |userVariables2| |userVariables3| |userVariables4| |newDependencies|) + (DECLARE (SPECIAL |$env| |$eval| |$genValue| |$freeVars| |$localVars|)) + (RETURN + (SEQ + (PROGN + (SPADLET |lhs| (CADR #0#)) + (SPADLET |mapsig| (CADDR #0#)) + (SPADLET |rhs| (CAR (CDDDDR #0#))) + (COND + ((NULL (PAIRP |lhs|)) + (SPADLET |op| |lhs|) + (|putHist| |op| (QUOTE |isInterpreterRule|) (QUOTE T) |$e|) + (|putHist| |op| (QUOTE |isInterpreterFunction|) NIL |$e|) + (SPADLET |lhs| (CONS |lhs| NIL))) + ((QUOTE T) + (SPADLET |op| (CAR |lhs|)) + (COND + ((AND (SPADLET |oldMode| (|get| |op| (QUOTE |mode|) |$e|)) + (NULL + (AND + (PAIRP |oldMode|) + (EQ (QCAR |oldMode|) (QUOTE |Mapping|))))) + (|throwKeyedMsg| (QUOTE S2IM0001) (CONS |op| (CONS |oldMode| NIL)))) + ((QUOTE T) + (|putHist| |op| (QUOTE |isInterpreterRule|) NIL |$e|) + (|putHist| |op| (QUOTE |isInterpreterFunction|) (QUOTE T) |$e|))))) + (COND + ((OR (NUMBERP |op|) (|member| |op| (QUOTE (|true| |false| |nil| % %%)))) + (|throwKeyedMsg| (QUOTE S2IM0002) (CONS |lhs| NIL))) + ((NEQUAL |op| (SPADLET |op'| (|unabbrev| |op|))) + (|throwKeyedMsg| (QUOTE S2IM0003) (CONS |op| (CONS |op'| NIL)))) + ((QUOTE T) + (SPADLET |parameters| + (PROG (#1=#:G166128) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166134 (CDR |lhs|) (CDR #2#)) (|p| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |p| (CAR #2#)) NIL)) + (NREVERSE0 #1#)) + (SEQ (EXIT (COND ((IDENTP |p|) (SETQ #1# (CONS |p| #1#)))))))))) + (SPADLET |someDecs| NIL) + (SPADLET |allDecs| (QUOTE T)) + (SPADLET |mapmode| (CONS (QUOTE |Mapping|) NIL)) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |$eval| (QUOTE T)) + (SPADLET |$genValue| (QUOTE T)) + (DO ((#3=#:G166143 |mapsig| (CDR #3#)) (|d| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |d| (CAR #3#)) NIL)) NIL) + (SEQ + (EXIT + (COND + (|d| + (SPADLET |someDecs| (QUOTE T)) + (SPADLET |d'| (|evaluateType| (|unabbrev| |d|))) + (COND + ((|isPartialMode| |d'|) (|throwKeyedMsg| (QUOTE S2IM0004) NIL)) + ((QUOTE T) (SPADLET |mapmode| (CONS |d'| |mapmode|))))) + ((QUOTE T) (SPADLET |allDecs| NIL)))))) + (COND + (|allDecs| + (SPADLET |mapmode| (NREVERSE |mapmode|)) + (|putHist| |op| (QUOTE |mode|) |mapmode| |$e|) + (|sayKeyedMsg| (QUOTE S2IM0006) + (CONS (|formatOpSignature| |op| (CDR |mapmode|)) NIL))) + (|someDecs| (|throwKeyedMsg| (QUOTE S2IM0007) (CONS |op| NIL))) + ((QUOTE T) NIL)) + (COND + ((PROGN + (SPADLET |ISTMP#1| (|get| |op| (QUOTE |mode|) |$e|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN (SPADLET |mapargs| (QCDR |ISTMP#2|)) (QUOTE T)))))) + (SEQ + (COND + ((EQCAR |rhs| (QUOTE |rules|)) + (COND + ((NEQUAL 0 (SPADLET |numargs| (|#| (CDR |lhs|)))) + (EXIT + (|throwKeyedMsg| 'S2IM0027 (CONS |numargs| (CONS |op| NIL))))))) + ((NEQUAL (|#| (CDR |lhs|)) (|#| |mapargs|)) + (|throwKeyedMsg| (QUOTE S2IM0008) (CONS |op| NIL))))))) + (SPADLET |userVariables1| (|getUserIdentifiersIn| |rhs|)) + (SPADLET |$freeVars| NIL) + (SPADLET |$localVars| NIL) + (DO ((#4=#:G166152 |parameters| (CDR #4#)) (|parm| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |parm| (CAR #4#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |parm|)))) + (SPADLET |userVariables2| + (SETDIFFERENCE |userVariables1| (|findLocalVars| |op| |rhs|))) + (SPADLET |userVariables3| (SETDIFFERENCE |userVariables2| |parameters|)) + (SPADLET |userVariables4| + (REMDUP (SETDIFFERENCE |userVariables3| (CONS |op| NIL)))) + (SPADLET |newDependencies| + (|makeNewDependencies| |op| |userVariables4|)) + (|putDependencies| |op| |newDependencies|) + (|clearDependencies| |op| (QUOTE 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) + +(DEFUN |addMap| (|lhs| |rhs| |pred|) + (PROG (|$sl| |op| |argl| |formalArgList| |ISTMP#1| |s| |ISTMP#2| |p| + |predList| |x| |argList| |argPredList| |finalPred| |body| |obj| + |oldMap| |newMap| |type| |recursive|) + (DECLARE (SPECIAL |$sl|)) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (CAR |lhs|)) + (SPADLET |argl| (CDR |lhs|)) + (SPADLET |$sl| NIL) + (SPADLET |formalArgList| + (PROG (#0=#:G166242) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166248 |argl| (CDR #1#)) + (|x| NIL) + (#2=#:G166249 |$FormalMapVariableList| (CDR #2#)) + (|s| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |s| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (|mkFormalArg| (|makeArgumentIntoNumber| |x|) |s|) + #0#)))))))) + (SPADLET |argList| + (PROG (#3=#:G166271) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166285 |formalArgList| (CDR #4#)) (|x| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS + (PROGN + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE SUCHTHAT)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |s| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |p| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |predList| (CONS |p| |predList|)) + (SPADLET |x| |s|))) + |x|) + #3#)))))))) + (|mkMapAlias| |op| |argl|) + (SPADLET |argPredList| (NREVERSE |predList|)) + (SPADLET |finalPred| + (MKPF + (COND + ((AND |pred| (NEQUAL |pred| (QUOTE T))) + (APPEND |argPredList| (CONS (SUBLISNQ |$sl| |pred|) NIL))) + ((QUOTE T) |argPredList|)) (QUOTE |and|))) + (SPADLET |body| (SUBLISNQ |$sl| |rhs|)) + (SPADLET |oldMap| + (COND + ((SPADLET |obj| (|get| |op| (QUOTE |value|) |$InteractiveFrame|)) + (|objVal| |obj|)) + ((QUOTE T) NIL))) + (SPADLET |newMap| + (|augmentMap| |op| |argList| |finalPred| |body| |oldMap|)) + (COND + ((NULL |newMap|) + (|sayRemoveFunctionOrValue| |op|) + (|putHist| |op| (QUOTE |alias|) NIL |$e|) + (INTERN " " "BOOT")) + ((QUOTE T) + (COND + ((|get| |op| (QUOTE |isInterpreterRule|) |$e|) + (SPADLET |type| (CONS (QUOTE |RuleCalled|) (CONS |op| NIL)))) + ((QUOTE T) + (SPADLET |type| (CONS (QUOTE |FunctionCalled|) (CONS |op| NIL))))) + (SPADLET |recursive| + (COND + ((EQL (|depthOfRecursion| |op| |newMap|) 0) NIL) + ((QUOTE T) (QUOTE T)))) + (|putHist| |op| (QUOTE |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 + +(DEFUN |augmentMap| (|op| |args| |pred| |body| |oldMap|) + (PROG (|pattern| |newMap| |entry| |tail| |resultMap|) + (RETURN + (PROGN + (SPADLET |pattern| (|makePattern| |args| |pred|)) + (SPADLET |newMap| (|deleteMap| |op| |pattern| |oldMap|)) + (COND + ((BOOT-EQUAL |body| (INTERN " " "BOOT")) + (COND + ((BOOT-EQUAL |newMap| |oldMap|) + (|sayMSG| (CONS " Cannot find part of" + (APPEND (|bright| |op|) (CONS "to delete." NIL)))))) + |newMap|) + ((QUOTE T) + (SPADLET |entry| (CONS |pattern| |body|)) + (SPADLET |resultMap| + (COND + ((AND (PAIRP |newMap|) + (EQ (QCAR |newMap|) (QUOTE MAP)) + (PROGN (SPADLET |tail| (QCDR |newMap|)) (QUOTE T))) + (CONS (QUOTE MAP) (APPEND |tail| (CONS |entry| NIL)))) + ((QUOTE T) (CONS (QUOTE MAP) (CONS |entry| NIL))))) + |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 + +(DEFUN |deleteMap| (|op| |pattern| |map|) + (PROG (|tail| |replacement| |newMap|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |map|) + (EQ (QCAR |map|) (QUOTE MAP)) + (PROGN (SPADLET |tail| (QCDR |map|)) (QUOTE T))) + (SPADLET |newMap| + (CONS (QUOTE MAP) + (PROG (#0=#:G166340) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166346 |tail| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((COND + ((AND (PAIRP |x|) + (EQUAL (QCAR |x|) |pattern|) + (PROGN (SPADLET |replacement| (QCDR |x|)) (QUOTE T))) + (|sayDroppingFunctions| |op| (CONS |x| NIL))) + ((QUOTE T) (QUOTE T))) + (SETQ #0# (CONS |x| #0#))))))))))) + (COND + ((NULL (CDR |newMap|)) NIL) + ((QUOTE T) |newMap|))) + ((QUOTE T) 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 := +; not (GET(op,'Nud) or GET(op,'Led) or GET(op,'up))=> +; NCONC(getUserIdentifiersIn op, argIdList) +; argIdList +; REMDUP bodyIdList + +(DEFUN |getUserIdentifiersIn| (|body|) + (PROG (|ISTMP#1| |ISTMP#2| |body1| |itl| |userIds| |op| |l| |argIdList| + |bodyIdList|) + (RETURN + (SEQ + (COND + ((NULL |body|) NIL) + ((IDENTP |body|) + (COND + ((|isSharpVarWithNum| |body|) NIL) + ((BOOT-EQUAL |body| (INTERN " " "BOOT")) NIL) + ((QUOTE T) (CONS |body| NIL)))) + ((AND (PAIRP |body|) (EQ (QCAR |body|) (QUOTE WRAPPED))) NIL) + ((OR + (AND + (PAIRP |body|) + (EQ (QCAR |body|) (QUOTE COLLECT)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body1| (QCAR |ISTMP#2|)) + (SPADLET |itl| (QCDR |ISTMP#2|)) + (QUOTE T)) + (PROGN (SPADLET |itl| (NREVERSE |itl|)) (QUOTE T))))) + (AND (PAIRP |body|) + (EQ (QCAR |body|) (QUOTE REPEAT)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |body|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body1| (QCAR |ISTMP#2|)) + (SPADLET |itl| (QCDR |ISTMP#2|)) + (QUOTE T)) + (PROGN (SPADLET |itl| (NREVERSE |itl|)) (QUOTE T)))))) + (SPADLET |userIds| + (S+ (|getUserIdentifiersInIterators| |itl|) + (|getUserIdentifiersIn| |body1|))) + (S- |userIds| (|getIteratorIds| |itl|))) + ((AND (PAIRP |body|) + (PROGN + (SPADLET |op| (QCAR |body|)) + (SPADLET |l| (QCDR |body|)) + (QUOTE T))) + (PROGN + (SPADLET |argIdList| + (PROG (#0=#:G166391) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166396 |l| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# (APPEND #0# (|getUserIdentifiersIn| |y|))))))))) + (SPADLET |bodyIdList| + (COND + ((NULL + (OR + (GETL |op| (QUOTE |Nud|)) + (GETL |op| (QUOTE |Led|)) + (GETL |op| (QUOTE |up|)))) + (NCONC (|getUserIdentifiersIn| |op|) |argIdList|)) + ((QUOTE T) |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 + +(DEFUN |getUserIdentifiersInIterators| (|itl|) + (PROG (|i| |l| |ISTMP#2| |y| |op| |ISTMP#1| |a| |varList|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G166485 |itl| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE STEP)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |i| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (SPADLET |varList| + (APPEND + (PROG (#1=#:G166491) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166496 |l| (CDR #2#)) (|y| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |y| (CAR #2#)) NIL)) #1#) + (SEQ + (EXIT + (SETQ #1# (APPEND #1# (|getUserIdentifiersIn| |y|)))))))) + |varList|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE IN)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |varList| (APPEND (|getUserIdentifiersIn| |y|) |varList|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE ON)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |varList| (APPEND (|getUserIdentifiersIn| |y|) |varList|))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) + (|member| |op| (QUOTE (|\|| WHILE UNTIL)))) + (SPADLET |varList| (APPEND (|getUserIdentifiersIn| |a|) |varList|))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "getUserIdentifiersInIterators" + (CONS "unknown iterator construct" NIL)))))))) + (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 + +(DEFUN |getIteratorIds| (|itl|) + (PROG (|i| |ISTMP#1| |y| |varList|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G166551 |itl| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE STEP)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |i| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |varList| (CONS |i| |varList|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE IN)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |varList| (CONS |y| |varList|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE ON)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |varList| (CONS |y| |varList|))) + ((QUOTE T) 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] + +(DEFUN |makeArgumentIntoNumber| (|x|) + (PROG (|ISTMP#1| |n|) + (RETURN + (COND + ((BOOT-EQUAL |x| |$Zero|) 0) + ((BOOT-EQUAL |x| |$One|) 1) + ((ATOM |x|) |x|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE -)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |n| (QCAR |ISTMP#1|)) + (QUOTE T)))) + (NUMBERP |n|)) + (SPADDIFFERENCE |n|)) + ((QUOTE T) + (CONS (|removeZeroOne| (CAR |x|)) (|removeZeroOne| (CDR |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) + +(DEFUN |mkMapAlias| (|op| |argl|) + (PROG (|u| |alias| |newAlias|) + (RETURN + (SEQ + (PROGN + (SPADLET |u| (|mkAliasList| |argl|)) + (SPADLET |newAlias| + (COND + ((SPADLET |alias| (|get| |op| (QUOTE |alias|) |$e|)) + (PROG (#0=#:G166587) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166593 |alias| (CDR #1#)) + (|x| NIL) + (#2=#:G166594 |u| (CDR #2#)) + (|y| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |y| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (COND (|y| |y|) ((QUOTE T) |x|)) #0#)))))))) + ((QUOTE T) |u|))) + (SPADLET |$e| (|putHist| |op| (QUOTE |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]) + +(DEFUN |mkAliasList,fn| (|l| |acc|) + (SEQ + (IF (NULL |l|) (EXIT (NREVERSE |acc|))) + (IF (OR (NULL (IDENTP (CAR |l|))) (|member| (CAR |l|) |acc|)) + (EXIT (|mkAliasList,fn| (CDR |l|) (CONS NIL |acc|)))) + (EXIT (|mkAliasList,fn| (CDR |l|) (CONS (CAR |l|) |acc|))))) + +(DEFUN |mkAliasList| (|l|) (|mkAliasList,fn| |l| NIL)) +;args2Tuple args == +; args is [first,:rest] => +; null rest => first +; ["Tuple",:args] +; nil + +(DEFUN |args2Tuple| (|args|) + (PROG (CAR CDR) + (RETURN + (COND + ((AND (PAIRP |args|) + (PROGN + (SPADLET CAR (QCAR |args|)) + (SPADLET CDR (QCDR |args|)) + (QUOTE T))) + (COND ((NULL CDR) CAR) ((QUOTE T) (CONS (QUOTE |Tuple|) |args|)))) + ((QUOTE T) 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) + +(DEFUN |makePattern| (|args| |pred|) + (PROG (|nargs| |ISTMP#1| |ISTMP#2| |n| |u|) + (RETURN + (PROGN + (SPADLET |nargs| (|#| |args|)) + (COND + ((EQL |nargs| 1) + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE =)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |#1|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |n| (QCAR |ISTMP#2|)) (QUOTE T))))))) + |n|) + ((QUOTE T) (|addPatternPred| (QUOTE |#1|) |pred|)))) + ((SPADLET |u| (|canMakeTuple| |nargs| |pred|)) |u|) + ((QUOTE T) + (|addPatternPred| + (CONS (QUOTE |Tuple|) (TAKE |nargs| |$FormalMapVariableList|)) + |pred|))))))) + +;addPatternPred(arg,pred) == +; pred=true => arg +; ["|",arg,pred] + +(DEFUN |addPatternPred| (|arg| |pred|) + (COND + ((BOOT-EQUAL |pred| (QUOTE T)) |arg|) + ((QUOTE T) (CONS (QUOTE |\||) (CONS |arg| (CONS |pred| NIL)))))) + +;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] + +(DEFUN |canMakeTuple| (|nargs| |pred|) + (PROG (|l| |ISTMP#1| |ISTMP#2| |a| |u|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |and|)) + (PROGN (SPADLET |l| (QCDR |pred|)) (QUOTE T)) + (BOOT-EQUAL |nargs| (|#| |l|)) + (SPADLET |u| + (PROG (#0=#:G166675) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166687 |$FormalMapVariableList| (CDR #1#)) + (|y| NIL) + (#2=#:G166688 (|orderList| |l|) (CDR #2#)) + (|x| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |y| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |x| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (COND + ((AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE =)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (EQUAL (QCAR |ISTMP#1|) |y|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) (QUOTE T))))))) + |a|) + ((QUOTE T) (RETURN NIL))) + #0#))))))))) + (EXIT (CONS (QUOTE |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."] + +(DEFUN |sayRemoveFunctionOrValue| (|x|) + (PROG (|obj| |md|) + (RETURN + (COND + ((AND (SPADLET |obj| (|getValue| |x|)) (SPADLET |md| (|objMode| |obj|))) + (COND + ((BOOT-EQUAL |md| |$EmptyMode|) + (|sayMessage| + (CONS " " + (APPEND (|bright| |x|) (CONS "now has no function parts." NIL))))) + ((QUOTE T) + (|sayMessage| + (CONS " value for" + (APPEND (|bright| |x|) (CONS "has been removed." NIL))))))) + ((QUOTE T) + (|sayMessage| + (CONS " " + (APPEND (|bright| |x|) + (CONS "has no value so this does nothing." NIL))))))))) + +;sayDroppingFunctions(op,l) == +; sayKeyedMsg("S2IM0017",[#l,op]) +; if $displayDroppedMap then +; for [pattern,:replacement] in l repeat +; displaySingleRule(op,pattern,replacement) +; nil + +(DEFUN |sayDroppingFunctions| (|op| |l|) + (PROG (|pattern| |replacement|) + (RETURN + (SEQ + (PROGN + (|sayKeyedMsg| (QUOTE S2IM0017) (CONS (|#| |l|) (CONS |op| NIL))) + (COND + (|$displayDroppedMap| + (DO ((#0=#:G166722 |l| (CDR #0#)) (#1=#:G166713 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |pattern| (CAR #1#)) + (SPADLET |replacement| (CDR #1#)) + #1#) + NIL)) + NIL) + (SEQ (EXIT (|displaySingleRule| |op| |pattern| |replacement|)))))) + NIL))))) + +;makeRuleForm(op,pattern)== +; pattern is ["Tuple",:l] => [op,:l] +; [op,:pattern] + +(DEFUN |makeRuleForm| (|op| |pattern|) + (PROG (|l|) + (RETURN + (COND + ((AND (PAIRP |pattern|) + (EQ (QCAR |pattern|) (QUOTE |Tuple|)) + (PROGN (SPADLET |l| (QCDR |pattern|)) (QUOTE T))) + (CONS |op| |l|)) + ((QUOTE T) (CONS |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]] + +(DEFUN |mkFormalArg| (|x| |s|) + (PROG (|y|) + (RETURN + (COND + ((|isConstantArgument| |x|) + (CONS + (QUOTE SUCHTHAT) + (CONS |s| (CONS (CONS (QUOTE =) (CONS |s| (CONS |x| NIL))) NIL)))) + ((|isPatternArgument| |x|) + (CONS + (QUOTE SUCHTHAT) + (CONS |s| (CONS (CONS (QUOTE |is|) (CONS |s| (CONS |x| NIL))) NIL)))) + ((IDENTP |x|) + (COND + ((SPADLET |y| (LASSOC |x| |$sl|)) + (CONS + (QUOTE SUCHTHAT) + (CONS |s| (CONS (CONS (QUOTE =) (CONS |s| (CONS |y| NIL))) NIL)))) + ((QUOTE T) (SPADLET |$sl| (CONS (CONS |x| |s|) |$sl|)) |s|))) + ((QUOTE T) + (CONS + (QUOTE SUCHTHAT) + (CONS |s| (CONS (CONS (QUOTE =) (CONS |s| (CONS |x| NIL))) NIL)))))))) + +;isConstantArgument x == +; NUMBERP x => x +; x is ["QUOTE",.] => x + +(DEFUN |isConstantArgument| (|x|) + (PROG (|ISTMP#1|) + (RETURN + (COND + ((NUMBERP |x|) |x|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE QUOTE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + |x|))))) + +;isPatternArgument x == x is ["construct",:.] + +(DEFUN |isPatternArgument| (|x|) + (AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE |construct|)))) + +;--% Map dependencies +;makeNewDependencies (op, userVariables) == +; null userVariables => nil +; --add the new dependencies +; [[(first userVariables),op], +; :makeNewDependencies (op, rest userVariables)] + +(DEFUN |makeNewDependencies| (|op| |userVariables|) + (COND + ((NULL |userVariables|) NIL) + ((QUOTE T) + (CONS + (CONS (CAR |userVariables|) (CONS |op| NIL)) + (|makeNewDependencies| |op| (CDR |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) + +(DEFUN |putDependencies,removeObsoleteDependencies| (|op| |oldDep|) + (SEQ + (IF (NULL |oldDep|) (EXIT NIL)) + (IF (BOOT-EQUAL |op| (CDR (CAR |oldDep|))) + (EXIT (|putDependencies,removeObsoleteDependencies| |op| (CDR |oldDep|)))) + (EXIT + (CONS + (CAR |oldDep|) + (|putDependencies,removeObsoleteDependencies| |op| (CDR |oldDep|)))))) + +(DEFUN |putDependencies| (|op| |dependencies|) + (PROG (|oldDependencies| |newDependencies|) + (RETURN + (PROGN + (SPADLET |oldDependencies| (|getFlag| (QUOTE |$dependencies|))) + (SPADLET |oldDependencies| + (|putDependencies,removeObsoleteDependencies| |op| |oldDependencies|)) + (SPADLET |newDependencies| (|union| |dependencies| |oldDependencies|)) + (|putFlag| (QUOTE |$dependencies|) |newDependencies|))))) + +;clearDependencies(x,clearLocalModemapsIfTrue) == +; $dependencies: local:= COPY getFlag "$dependencies" +; clearDep1(x,nil,nil,$dependencies) + +(DEFUN |clearDependencies| (|x| |clearLocalModemapsIfTrue|) + (PROG (|$dependencies|) + (DECLARE (SPECIAL |$dependencies|)) + (RETURN + (PROGN + (SPADLET |$dependencies| (COPY (|getFlag| (QUOTE |$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:= setUnion(toDoList, +; setDifference(CDR a,doneList)) +; toDoList is [a,:res] => clearDep1(a,res,newDone,depList) +; 'done + +(DEFUN |clearDep1| (|x| |toDoList| |doneList| |depList|) + (PROG (|newDone| |a| |res|) + (RETURN + (SEQ + (COND + ((|member| |x| |doneList|) NIL) + ((QUOTE T) + (|clearCache| |x|) + (SPADLET |newDone| (CONS |x| |doneList|)) + (DO ((#0=#:G166792 NIL (NULL |a|))) + (#0# NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |a| (ASSQ |x| |depList|)) + (COND + (|a| + (PROGN + (SPADLET |depList| (|delete| |a| |depList|)) + (SPADLET |toDoList| + (|union| |toDoList| (SETDIFFERENCE (CDR |a|) |doneList|)))))))))) + (COND + ((AND (PAIRP |toDoList|) + (PROGN + (SPADLET |a| (QCAR |toDoList|)) + (SPADLET |res| (QCDR |toDoList|)) + (QUOTE T))) + (|clearDep1| |a| |res| |newDone| |depList|)) + ((QUOTE T) (QUOTE |done|))))))))) + +;--% Formatting and displaying maps +;displayRule(op,rule) == +; null rule => nil +; mathprint ["CONCAT","Definition: ", rule] +; nil + +(DEFUN |displayRule| (|op| |rule|) + (COND + ((NULL |rule|) NIL) + ((QUOTE T) + (|mathprint| + (CONS (QUOTE CONCAT) (CONS (QUOTE |Definition: |) (CONS |rule| NIL)))) + 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 + +(DEFUN |outputFormat| (|x| |m|) + (PROG (T$) + (RETURN + (COND + ((IDENTP |m|) |x|) + ((OR (BOOT-EQUAL |m| |$OutputForm|) (BOOT-EQUAL |m| |$EmptyMode|)) |x|) + ((|categoryForm?| |m|) |x|) + ((|isMapExpr| |x|) |x|) + ((|containsVars| |x|) |x|) + ((AND (ATOM |x|) (BOOT-EQUAL (CAR |m|) (QUOTE |List|))) |x|) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |construct|)) + (BOOT-EQUAL |m| (QUOTE (|List| (|Expression|))))) + |x|) + ((QUOTE T) + (SPADLET T$ + (OR + (|coerceInteractive| + (|objNewWrap| |x| (|maximalSuperType| |m|)) |$OutputForm|) + (RETURN |x|))) + (|objValUnwrap| T$)))))) + +;displaySingleRule($op,pattern,replacement) == +; mathprint ['MAP,[pattern,:replacement]] + +(DEFUN |displaySingleRule| (|$op| |pattern| |replacement|) + (DECLARE (SPECIAL |$op|)) + (|mathprint| (CONS (QUOTE MAP) (CONS (CONS |pattern| |replacement|) NIL)))) + +;displayMap(headingIfTrue,$op,map) == +; mathprint +; headingIfTrue => ['CONCAT,PNAME "value: ",map] +; map + +(DEFUN |displayMap| (|headingIfTrue| |$op| |map|) + (DECLARE (SPECIAL |$op|)) + (|mathprint| + (COND + (|headingIfTrue| + (CONS (QUOTE CONCAT) (CONS (PNAME (QUOTE |value: |)) (CONS |map| NIL)))) + ((QUOTE T) |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 + +(DEFUN |simplifyMapPattern,unTrivialize| (|x|) + (PROG (|l| |op| |ISTMP#1| |a| |ISTMP#2|) + (RETURN + (SEQ + (IF (AND + (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |l| (QCDR |x|)) + (QUOTE T))) + (|member| |op| (QUOTE (|and| |or|)))) + (EXIT + (MKPF + (PROG (#0=#:G166866) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166871 |l| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|simplifyMapPattern,unTrivialize| |y|) #0#))))))) + |op|))) + (IF (AND + (AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (EQUAL (QCAR |ISTMP#2|) |a|)))))) + (|member| |op| (QUOTE (= |is|)))) + (EXIT (QUOTE T))) + (EXIT |x|))))) + +(DEFUN |simplifyMapPattern| (|x| |alias|) + (PROG (|lhs| |rhs| |ISTMP#1| |y| |ISTMP#2| |sl| |y'| |pred| |rhs'|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G166896 |alias| (CDR #0#)) + (|a| NIL) + (#1=#:G166897 |$FormalMapVariableList| (CDR #1#)) + (|m| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |a| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |m| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((AND |a| (NULL (CONTAINED |a| |x|))) + (SPADLET |x| (MSUBST |a| |m| |x|))))))) + (SPADLET |lhs| (CAR |x|)) + (SPADLET |rhs| (CDR |x|)) + (SPADLET |rhs| (|simplifyMapConstructorRefs| |rhs|)) + (SPADLET |x| (CONS |lhs| |rhs|)) + (COND + ((AND (PAIRP |lhs|) + (EQ (QCAR |lhs|) (QUOTE |\||)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |lhs|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |pred| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (SPADLET |pred| (|predTran| |pred|)) + (COND + ((SPADLET |sl| (|getEqualSublis| |pred|)) + (SPADLET |y'| (SUBLIS |sl| |y|)) + (SPADLET |pred| + (|simplifyMapPattern,unTrivialize| (SUBLIS |sl| |pred|))) + (SPADLET |rhs'| (SUBLIS |sl| |rhs|)) + (COND + ((BOOT-EQUAL |pred| (QUOTE T)) (CONS |y'| |rhs'|)) + ((QUOTE T) + (CONS + (CONS + (QUOTE PAREN) + (CONS (CONS (QUOTE |\||) (CONS |y'| (CONS |pred| NIL))) NIL)) + |rhs'|)))) + ((BOOT-EQUAL |pred| (QUOTE T)) (CONS |y| |rhs|)) + ((QUOTE T) + (CONS + (CONS + (QUOTE PAREN) + (CONS (CONS (QUOTE |\||) (CONS |y| (CONS |pred| NIL))) NIL)) + |rhs|)))) + ((BOOT-EQUAL |lhs| (QUOTE T)) (CONS (QUOTE |true|) |rhs|)) + ((QUOTE T) |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 + +(DEFUN |simplifyMapConstructorRefs| (|form|) + (PROG (|op| |args| |obj| |ISTMP#1| |dom| |dom'| |dom''|) + (RETURN + (SEQ + (COND + ((ATOM |form|) |form|) + ((QUOTE T) + (SPADLET |op| (CAR |form|)) + (SPADLET |args| (CDR |form|)) + (COND + ((|member| |op| (QUOTE (|exit| SEQ))) + (CONS |op| + (PROG (#0=#:G166943) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166948 |args| (CDR #1#)) (|a| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |a| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|simplifyMapConstructorRefs| |a|) #0#))))))))) + ((|member| |op| (QUOTE (REPEAT))) + (CONS |op| + (CONS + (CAR |args|) + (PROG (#2=#:G166958) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G166963 (CDR |args|) (CDR #3#)) (|a| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |a| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# (CONS (|simplifyMapConstructorRefs| |a|) #2#)))))))))) + ((|member| |op| (QUOTE (|:| |::| @))) + (COND + ((AND (PAIRP |args|) + (PROGN + (SPADLET |obj| (QCAR |args|)) + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |dom| (QCAR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |dom'| (|prefix2String| |dom|)) + (SPADLET |dom''| + (COND + ((ATOM |dom'|) |dom'|) + ((NULL (CDR |dom'|)) (CAR |dom'|)) + ((QUOTE T) (APPLY (QUOTE CONCAT) |dom'|)))) + (CONS |op| (CONS |obj| (CONS |dom''| NIL)))) + ((QUOTE T) |form|))) + ((QUOTE T) |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 + +(DEFUN |predTran| (|x|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c|) + (RETURN + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (COND + ((BOOT-EQUAL |c| (QUOTE |false|)) + (MKPF + (CONS (|predTran| |a|) (CONS (|predTran| |b|) NIL)) + (QUOTE |and|))) + ((BOOT-EQUAL |b| (QUOTE |true|)) + (MKPF + (CONS (|predTran| |a|) (CONS (|predTran| |c|) NIL)) + (QUOTE |or|))) + ((AND (BOOT-EQUAL |b| (QUOTE |false|)) (BOOT-EQUAL |c| (QUOTE |true|))) + (CONS (QUOTE |not|) (CONS (|predTran| |a|) NIL))) + ((QUOTE T) |x|))) + ((QUOTE T) |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 + +(DEFUN |getEqualSublis,fn| (|x| |sl|) + (PROG (|op| |l| |ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (SEQ + (IF (AND + (PROGN + (SPADLET |ISTMP#1| (SPADLET |x| (SUBLIS |sl| |x|))) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (|member| |op| (QUOTE (|and| |or|)))) + (EXIT + (SEQ + (DO ((#0=#:G167072 |l| (CDR #0#)) (|y| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |y| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (SPADLET |sl| (|getEqualSublis,fn| |y| |sl|))))) + (EXIT |sl|)))) + (IF (AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |is|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (EXIT (CONS (CONS |a| |b|) |sl|))) + (IF (AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE =)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (EXIT + (SEQ + (IF (AND (IDENTP |a|) (NULL (CONTAINED |a| |b|))) + (EXIT (CONS (CONS |a| |b|) |sl|))) + (IF (AND (IDENTP |b|) (NULL (CONTAINED |b| |a|))) + (EXIT (CONS (CONS |b| |a|) |sl|))) + (EXIT |sl|)))) + (EXIT |sl|))))) + +(DEFUN |getEqualSublis| (|pred|) (|getEqualSublis,fn| |pred| NIL)) + +;--% User function analysis +;mapCatchName mapname == +; INTERN STRCONC('"$",STRINGIMAGE mapname,'"CatchMapIdentifier$") + +(DEFUN |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 + +(DEFUN |analyzeMap,f| (|x|) + (SEQ + (IF (|isEqualOrSubDomain| |x| |$Integer|) (EXIT |$Integer|)) + (EXIT |x|))) + +(DEFUN |analyzeMap| (|op| |argTypes| |mapDef| |tar|) + (PROG (|$compilingMap| |$definingMap| |$minivector| |$mapThrowCount| + |$mapReturnTypes| |$repeatLabel| |$breakCount| |$mapTarget| + |$interpOnly| |$mapName| |mapAndArgTypes| |ISTMP#2| |target| + |map| |x| |opName| |fun| |ISTMP#1| |sig|) + (DECLARE (SPECIAL |$compilingMap| |$definingMap| |$minivector| + |$mapThrowCount| |$mapReturnTypes| |$repeatLabel| + |$breakCount| |$mapTarget| |$interpOnly| |$mapName|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$compilingMap| (QUOTE T)) + (SPADLET |$definingMap| (QUOTE T)) + (SPADLET |$minivector| NIL) + (SPADLET |$mapThrowCount| 0) + (SPADLET |$mapReturnTypes| NIL) + (SPADLET |$repeatLabel| NIL) + (SPADLET |$breakCount| 0) + (SPADLET |$mapTarget| |tar|) + (SPADLET |$interpOnly| NIL) + (SPADLET |$mapName| (ELT |op| 0)) + (COND + ((|get| |$mapName| (QUOTE |recursive|) |$e|) + (SPADLET |argTypes| + (PROG (#0=#:G167131) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167136 |argTypes| (CDR #1#)) (|t| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |t| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|analyzeMap,f| |t|) #0#)))))))))) + (SPADLET |mapAndArgTypes| (CONS |$mapName| |argTypes|)) + (COND + ((|member| |mapAndArgTypes| |$analyzingMapList|) + (COND + ((PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN (SPADLET |target| (QCAR |ISTMP#2|)) (QUOTE T)))))) + |target|) + ((QUOTE T) + (|throwKeyedMsg| (QUOTE S2IM0009) + (CONS |$mapName| + (CONS + (PROG (#2=#:G167142) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167148 |$analyzingMapList| (CDR #3#)) + (#4=#:G167116 NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN (PROGN (SPADLET |map| (CAR #4#)) #4#) NIL)) + #2#) + (SEQ + (EXIT + (SETQ #2# + (APPEND #2# (CONS (MAKESTRING " ") (CONS |map| NIL))))))))) + NIL)))))) + ((QUOTE T) + (PUSH |mapAndArgTypes| |$analyzingMapList|) + (SPADLET |mapDef| + (|mapDefsWithCorrectArgCount| (|#| |argTypes|) |mapDef|)) + (COND + ((NULL |mapDef|) (POP |$analyzingMapList|) NIL) + ((QUOTE T) + (UNWIND-PROTECT + (SPADLET |x| + (CATCH + (QUOTE |mapCompiler|) + (|analyzeMap0| |op| |argTypes| |mapDef|))) + (POP |$analyzingMapList|)) + (COND + ((BOOT-EQUAL |x| (QUOTE |tryInterpOnly|)) + (SPADLET |opName| (|getUnname| |op|)) + (SPADLET |fun| (|mkInterpFun| |op| |opName| |argTypes|)) + (COND + ((NULL + (PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |sig| + (CONS NIL + (PROG (#5=#:G167159) + (SPADLET #5# NIL) + (RETURN + (DO ((#6=#:G167164 |argTypes| (CDR #6#)) (|type| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |type| (CAR #6#)) NIL)) + (NREVERSE0 #5#)) + (SEQ (EXIT (SETQ #5# (CONS NIL #5#))))))))))) + (SPADLET |$e| + (|putHist| |opName| + (QUOTE |localModemap|) + (CONS + (CONS + (CONS (QUOTE |interpOnly|) |sig|) + (CONS |fun| (CONS NIL NIL))) + NIL) + |$e|))) + ((QUOTE T) |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) + +(DEFUN |analyzeMap0| (|op| |argTypes| |mapDef|) + (PROG (|$MapArgumentTypeList| |m| |ISTMP#1| |sig|) + (DECLARE (SPECIAL |$MapArgumentTypeList|)) + (RETURN + (PROGN + (SPADLET |$MapArgumentTypeList| |argTypes|) + (COND + ((NEQUAL (|numMapArgs| |mapDef|) (|#| |argTypes|)) NIL) + ((OR + (PROGN + (SPADLET |ISTMP#1| (SPADLET |m| (|getMode| |op|))) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T)))) + (AND |m| (SPADLET |sig| (CONS |m| NIL)))) + (|analyzeDeclaredMap| |op| |argTypes| |sig| |mapDef| |$mapList|)) + ((QUOTE T) + (|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) + +(DEFUN |compFailure| (|msg|) + (COND + ((NULL |$useCoerceOrCroak|) + (THROW (QUOTE |coerceOrCroaker|) (QUOTE |croaked|))) + ((QUOTE T) + (COND + (|$reportInterpOnly| + (|sayMSG| |msg|) + (|sayMSG| (MAKESTRING " We will attempt to interpret the code.")))) + (COND + ((NULL |$compilingMap|) + (THROW (QUOTE |loopCompiler|) (QUOTE |tryInterpOnly|))) + ((QUOTE T) + (THROW (QUOTE |mapCompiler|) (QUOTE |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 + +(DEFUN |mkInterpFun| (|op| |opName| |argTypes|) + (PROG (|ISTMP#1| |sig| |parms| |arglCode| |funName| |body|) + (RETURN + (SEQ + (COND + ((NULL + (PROGN + (SPADLET |ISTMP#1| (|getMode| |op|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T))))) + NIL) + ((QUOTE T) + (SPADLET |parms| + (PROG (#0=#:G167251) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167257 |argTypes| (CDR #1#)) + (|type| NIL) + (#2=#:G167258 |$FormalMapVariableList| (CDR #2#)) + (|var| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |type| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |var| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) + (SPADLET |arglCode| + (CONS + (QUOTE LIST) + (PROG (#3=#:G167272) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G167278 |argTypes| (CDR #4#)) + (|type| NIL) + (#5=#:G167279 |parms| (CDR #5#)) + (|argName| NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ |type| (CAR #4#)) NIL) + (ATOM #5#) + (PROGN (SETQ |argName| (CAR #5#)) NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS + (CONS + (QUOTE |putValueValue|) + (CONS + (CONS (QUOTE |mkAtreeNode|) (CONS (MKQ |argName|) NIL)) + (CONS + (|objNewCode| + (CONS (QUOTE |wrap|) (CONS |argName| NIL)) |type|) + NIL))) + #3#))))))))) + (SPADLET |funName| (GENSYM)) + (SPADLET |body| + (CONS + (QUOTE |rewriteMap1|) + (CONS (MKQ |opName|) (CONS |arglCode| (CONS (MKQ |sig|) NIL))))) + (|putMapCode| |opName| |body| |sig| |funName| |parms| NIL) + (|genMapCode| |opName| |body| |sig| |funName| |parms| NIL) + |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) + +(DEFUN |rewriteMap| (|op| |opName| |argl|) + (PROG (|ISTMP#1| |sig| |arglCode|) + (RETURN + (SEQ + (COND + ((NULL |$genValue|) + (COND + ((NULL + (PROGN + (SPADLET |ISTMP#1| (|get| |opName| (QUOTE |mode|) |$e|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN (SPADLET |sig| (QCDR |ISTMP#1|)) (QUOTE T))))) + (|compFailure| (CONS " Cannot compile map:" (|bright| |opName|)))) + ((QUOTE T) + (SPADLET |arglCode| + (CONS + (QUOTE LIST) + (PROG (#0=#:G167311) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167317 |argl| (CDR #1#)) + (|arg| NIL) + (#2=#:G167318 |$FormalMapVariableList| (CDR #2#)) + (|argName| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |arg| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |argName| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS + (QUOTE |putValueValue|) + (CONS + (CONS (QUOTE |mkAtreeNode|) (CONS (MKQ |argName|) NIL)) + (CONS + (|objNewCode| + (CONS + (QUOTE |wrap|) + (CONS + (|wrapped2Quote| (|objVal| (|getValue| |arg|))) + NIL)) + (|getMode| |arg|)) + NIL))) + #0#))))))))) + (|putValue| |op| + (|objNew| + (CONS + (QUOTE |rewriteMap1|) + (CONS (MKQ |opName|) (CONS |arglCode| (CONS (MKQ |sig|) NIL)))) + (CAR |sig|))) + (|putModeSet| |op| (CONS (CAR |sig|) NIL))))) + ((QUOTE T) (|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 + +(DEFUN |putBodyInEnv| (|opName| |numArgs|) + (PROG (|val| |ISTMP#1| |bod|) + (RETURN + (PROGN + (SPADLET |val| (|get| |opName| (QUOTE |value|) |$e|)) + (COND + ((AND (PAIRP |val|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |val|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) + (PROGN (SPADLET |bod| (QCDR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |$e| + (|putHist| |opName| + (QUOTE |mapBody|) + (|combineMapParts| (|mapDefsWithCorrectArgCount| |numArgs| |bod|)) + |$e|))) + ((QUOTE T) (QUOTE |failed|))))))) + +;removeBodyFromEnv(opName) == +; $e := putHist(opName, 'mapBody, nil, $e) + +(DEFUN |removeBodyFromEnv| (|opName|) + (SPADLET |$e| (|putHist| |opName| (QUOTE |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]) + +(DEFUN |rewriteMap0| (|op| |opName| |argl|) + (PROG (|$env| |s| |ISTMP#1| |ISTMP#2| |tar| |t| |argTypes| |m| |val| |ms|) + (DECLARE (SPECIAL |$env|)) + (RETURN + (SEQ + (PROGN + (|putBodyInEnv| |opName| (|#| |argl|)) + (COND + ((SPADLET |s| (|get| |opName| (QUOTE |mode|) |$e|)) + (SPADLET |tar| (CADR |s|)) + (SPADLET |argTypes| (CDDR |s|))) + ((QUOTE T) + (SPADLET |tar| NIL) (SPADLET |argTypes| NIL))) + (SPADLET |ISTMP#1| (|get| |opName| (QUOTE |mode|) |$e|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |Mapping|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |tar| (QCAR |ISTMP#2|)) + (SPADLET |argTypes| (QCDR |ISTMP#2|)) + (QUOTE T))))) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (DO ((#0=#:G167379 |argl| (CDR #0#)) + (|arg| NIL) + (#1=#:G167380 |$FormalMapVariableList| (CDR #1#)) + (|var| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |arg| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |var| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (COND + (|argTypes| + (SPADLET |t| (CAR |argTypes|)) + (SPADLET |argTypes| (CDR |argTypes|)) + (SPADLET |val| + (COND + ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Mapping|))) + (|getValue| |arg|)) + ((QUOTE T) (|coerceInteractive| (|getValue| |arg|) |t|))))) + ((QUOTE T) (SPADLET |val| (|getValue| |arg|)))) + (SPADLET |$env| (|put| |var| (QUOTE |value|) |val| |$env|)) + (COND + ((VECP |arg|) + (SPADLET |$env| + (|put| |var| (QUOTE |name|) (|getUnname| |arg|) |$env|)))) + (COND + ((SPADLET |m| (|getMode| |arg|)) + (SPADLET |$env| (|put| |var| (QUOTE |mode|) |m| |$env|)))))))) + (COND + ((NULL (SPADLET |val| (|interpMap| |opName| |tar|))) + (|throwKeyedMsg| (QUOTE S2IM0010) (CONS |opName| NIL))) + ((QUOTE T) + (|putValue| |op| |val|) + (|removeBodyFromEnv| |opName|) + (SPADLET |ms| (|putModeSet| |op| (CONS (|objMode| |val|) NIL)))))))))) + +;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) + +(DEFUN |rewriteMap1| (|opName| |argl| |sig|) + (PROG (|$env| |tar| |v| |evArgl| |t| |argTypes| |m| |val|) + (DECLARE (SPECIAL |$env|)) + (RETURN + (SEQ + (PROGN + (|putBodyInEnv| |opName| (|#| |argl|)) + (COND + (|sig| (SPADLET |tar| (CAR |sig|)) (SPADLET |argTypes| (CDR |sig|))) + ((QUOTE T) (SPADLET |tar| NIL) (SPADLET |argTypes| NIL))) + (SPADLET |evArgl| NIL) + (DO ((#0=#:G167426 (REVERSE |argl|) (CDR #0#)) (|arg| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |arg| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |v| (|getValue| |arg|)) + (SPADLET |evArgl| + (CONS (|objNew| (|objVal| |v|) (|objMode| |v|)) |evArgl|)))))) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (DO ((#1=#:G167441 |argl| (CDR #1#)) + (|arg| NIL) + (#2=#:G167442 |evArgl| (CDR #2#)) + (|evArg| NIL) + (#3=#:G167443 |$FormalMapVariableList| (CDR #3#)) + (|var| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |arg| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |evArg| (CAR #2#)) NIL) + (ATOM #3#) + (PROGN (SETQ |var| (CAR #3#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (COND + (|argTypes| + (SPADLET |t| (CAR |argTypes|)) + (SPADLET |argTypes| (CDR |argTypes|)) + (SPADLET |val| + (COND + ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Mapping|))) |evArg|) + ((QUOTE T) (|coerceInteractive| |evArg| |t|))))) + ((QUOTE T) (SPADLET |val| |evArg|))) + (SPADLET |$env| (|put| |var| (QUOTE |value|) |val| |$env|)) + (COND + ((VECP |arg|) + (SPADLET |$env| + (|put| |var| (QUOTE |name|) (|getUnname| |arg|) |$env|)))) + (COND + ((SPADLET |m| (|getMode| |arg|)) + (SPADLET |$env| (|put| |var| (QUOTE |mode|) |m| |$env|)))))))) + (SPADLET |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 + +(DEFUN |interpMap| (|opName| |tar|) + (PROG (|$genValue| |$interpMapTag| |$interpOnly| |$localVars| |$mapName| + |$mapTarget| |body| |savedTimerStack| |catchName| |c|) + (DECLARE (SPECIAL |$genValue| |$interpMapTag| |$interpOnly| |$localVars| + |$mapName| |$mapTarget|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$genValue| (QUOTE T)) + (SPADLET |$interpMapTag| NIL) + (SPADLET |$interpOnly| (QUOTE T)) + (SPADLET |$localVars| NIL) + (DO ((#0=#:G167481 (|get| |opName| (QUOTE |localVars|) |$e|) (CDR #0#)) + (|lvar| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |lvar| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |opName| |lvar|)))) + (SPADLET |$mapName| |opName|) + (SPADLET |$mapTarget| |tar|) + (SPADLET |body| (|get| |opName| (QUOTE |mapBody|) |$e|)) + (SPADLET |savedTimerStack| (COPY |$timedNameStack|)) + (SPADLET |catchName| (|mapCatchName| |$mapName|)) + (SPADLET |c| (CATCH |catchName| (|interpret1| |body| |tar| NIL))) + (DO () + ((NULL (NEQUAL |savedTimerStack| |$timedNameStack|)) NIL) + (SEQ (EXIT (|stopTimingProcess| (|peekTimedName|))))) + |c|))))) + +;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 + +(DEFUN |analyzeDeclaredMap| (|op| |argTypes| |sig| |mapDef| |$mapList|) + (DECLARE (SPECIAL |$mapList|)) + (PROG (|opName| |mmS| |mmSig| |mm|) + (RETURN + (SEQ + (PROGN + (SPADLET |opName| (|getUnname| |op|)) + (SPADLET |$mapList| (CONS |opName| |$mapList|)) + (SPADLET |$mapTarget| (CAR |sig|)) + (COND + ((AND + (SPADLET |mmS| (|get| |opName| (QUOTE |localModemap|) |$e|)) + (SPADLET |mm| + (PROG (#0=#:G167521) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167529 NIL #0#) + (#2=#:G167530 |mmS| (CDR #2#)) + (|mm| NIL)) + ((OR #1# + (ATOM #2#) + (PROGN (SETQ |mm| (CAR #2#)) NIL) + (PROGN (PROGN (SPADLET |mmSig| (CDAR |mm|)) |mm|) NIL)) + #0#) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |mmSig| |sig|) (SETQ #0# (OR #0# |mm|))))))))))) + (|compileCoerceMap| |opName| |argTypes| |mm|)) + ((QUOTE T) + (|compileDeclaredMap| |opName| |sig| |mapDef|) + (COND + ((NEQUAL |argTypes| (CDR |sig|)) + (|analyzeDeclaredMap| |op| |argTypes| |sig| |mapDef| |$mapList|)) + ((QUOTE T) (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 + +(DEFUN |compileDeclaredMap| (|op| |sig| |mapDef|) + (PROG (|$localVars| |$freeVars| |$env| |parms| |body| |name| |val| + |isRecursive|) + (DECLARE (SPECIAL |$localVars| |$freeVars| |$env|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$localVars| NIL) + (SPADLET |$freeVars| NIL) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |parms| + (PROG (#0=#:G167555) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167561 |$FormalMapVariableList| (CDR #1#)) + (|var| NIL) + (#2=#:G167562 (CDR |sig|) (CDR #2#)) + (|m| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |var| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |m| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) + (DO ((#3=#:G167575 (CDR |sig|) (CDR #3#)) + (|m| NIL) + (#4=#:G167576 |parms| (CDR #4#)) + (|var| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |m| (CAR #3#)) NIL) + (ATOM #4#) + (PROGN (SETQ |var| (CAR #4#)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |$env| (|put| |var| (QUOTE |mode|) |m| |$env|))))) + (SPADLET |body| (|getMapBody| |op| |mapDef|)) + (DO ((#5=#:G167588 |parms| (CDR #5#)) (|lvar| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |lvar| (CAR #5#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (DO ((#6=#:G167597 (|getLocalVars| |op| |body|) (CDR #6#)) (|lvar| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |lvar| (CAR #6#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (SPADLET |name| (|makeLocalModemap| |op| |sig|)) + (SPADLET |val| (|compileBody| |body| (CAR |sig|))) + (SPADLET |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 + +(DEFUN |putMapCode| (|op| |code| |sig| |name| |parms| |isRecursive|) + (PROG (|codeInfo| |allCode|) + (RETURN + (PROGN + (SPADLET |codeInfo| + (VECTOR |op| |code| |sig| |name| |parms| |isRecursive|)) + (SPADLET |allCode| + (CONS |codeInfo| (|get| |op| (QUOTE |generatedCode|) |$e|))) + (SPADLET |$e| + (|putHist| |op| (QUOTE |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 + +(DEFUN |makeLocalModemap| (|op| |sig|) + (PROG (|currentMms| |newName| |newMm| |mms|) + (RETURN + (PROGN + (COND + ((SPADLET |currentMms| (|get| |op| (QUOTE |localModemap|) |$e|)) + (|untraceMapSubNames| (CONS (CADAR |currentMms|) NIL)))) + (SPADLET |newName| + (|makeInternalMapName| |op| + (SPADDIFFERENCE (|#| |sig|) 1) + (PLUS 1 (|#| |currentMms|)) + NIL)) + (SPADLET |newMm| + (CONS (CONS (QUOTE |local|) |sig|) (CONS |newName| (CONS NIL NIL)))) + (SPADLET |mms| (CONS |newMm| |currentMms|)) + (SPADLET |$e| (|putHist| |op| (QUOTE |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) + +(DEFUN |genMapCode| (|op| |body| |sig| |fnName| |parms| |isRecursive|) + (PROG (|lmm| |n| |op0| |locals| |lets|) + (RETURN + (SEQ + (PROGN + (COND + ((SPADLET |lmm| (|get| |op| (QUOTE |localModemap|) |$InteractiveFrame|)) + (|untraceMapSubNames| (CONS (CADAR |lmm|) NIL)))) + (SPADLET |op0| + (COND + ((SPADLET |n| (|isSharpVarWithNum| |op|)) + (STRCONC "")) + ((QUOTE T) |op|))) + (COND + ((|get| |op| (QUOTE |isInterpreterRule|) |$e|) + (|sayKeyedMsg| (QUOTE S2IM0014) + (CONS |op0| + (CONS + (COND + ((PAIRP |sig|) (|prefix2String| (CAR |sig|))) + ((QUOTE T) (MAKESTRING "?"))) NIL)))) + ((QUOTE T) + (|sayKeyedMsg| (QUOTE S2IM0015) + (CONS |op0| (CONS (|formatSignature| |sig|) NIL))))) + (SPADLET |$whereCacheList| (CONS |op| |$whereCacheList|)) + (SPADLET |locals| (SETDIFFERENCE (COPY |$localVars|) |parms|)) + (COND + (|locals| + (SPADLET |lets| + (PROG (#0=#:G167646) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167651 |locals| (CDR #1#)) (|l| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |l| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# + (CONS + (CONS + (QUOTE LET) + (CONS |l| + (CONS + (QUOTE (QUOTE UNINITIALIZED_VARIABLE)) + (CONS |op| NIL)))) + #0#)))))))) + (SPADLET |body| + (CONS (QUOTE PROGN) (APPEND |lets| (CONS |body| NIL)))))) + (|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) + +(DEFUN |compileBody| (|body| |target|) + (PROG (|$insideCompileBodyIfTrue| |$genValue| |$declaredMode| |$eval| |r|) + (DECLARE (SPECIAL |$insideCompileBodyIfTrue| |$genValue| |$declaredMode| + |$eval|)) + (RETURN + (PROGN + (SPADLET |$insideCompileBodyIfTrue| (QUOTE T)) + (SPADLET |$genValue| NIL) + (SPADLET |$declaredMode| |target|) + (SPADLET |$eval| (QUOTE T)) + (SPADLET |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 + +(DEFUN |compileCoerceMap| (|op| |argTypes| |mm|) + (PROG (|$insideCompileBodyIfTrue| |$genValue| |sig| |imp| |name| |argCode| + |parms| |minivectorName| |body|) + (DECLARE (SPECIAL |$insideCompileBodyIfTrue| |$genValue|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$insideCompileBodyIfTrue| (QUOTE T)) + (SPADLET |$genValue| NIL) + (SPADLET |sig| (CDAR |mm|)) + (SPADLET |imp| (CADR |mm|)) + (SPADLET |parms| + (PROG (#0=#:G167694) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167700 |$FormalMapVariableList| (CDR #1#)) + (|var| NIL) + (#2=#:G167701 (CDR |sig|) (CDR #2#)) + (|t| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |var| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |t| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) + (SPADLET |name| (|makeLocalModemap| |op| (CONS (CAR |sig|) |argTypes|))) + (SPADLET |argCode| + (PROG (#3=#:G167716) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G167723 |argTypes| (CDR #4#)) + (|t1| NIL) + (#5=#:G167724 (CDR |sig|) (CDR #5#)) + (|t2| NIL) + (#6=#:G167725 |parms| (CDR #6#)) + (|arg| NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ |t1| (CAR #4#)) NIL) + (ATOM #5#) + (PROGN (SETQ |t2| (CAR #5#)) NIL) + (ATOM #6#) + (PROGN (SETQ |arg| (CAR #6#)) NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (SETQ #3# + (CONS + (|objVal| + (OR + (|coerceInteractive| (|objNew| |arg| |t1|) |t2|) + (|throwKeyedMsg| (QUOTE S2IC0001) + (CONS |arg| (CONS |$mapName| (CONS |t1| (CONS |t2| NIL))))))) + #3#)))))))) + (SPADLET |$insideCompileBodyIfTrue| NIL) + (SPADLET |parms| (APPEND |parms| (CONS (QUOTE |envArg|) NIL))) + (SPADLET |body| + (CONS (QUOTE SPADCALL) + (APPEND |argCode| + (CONS + (CONS (QUOTE LIST) + (CONS (CONS (QUOTE |function|) (CONS |imp| NIL)) NIL)) + NIL)))) + (SPADLET |minivectorName| (|makeInternalMapMinivectorName| |name|)) + (SPADLET |$minivectorNames| + (CONS (CONS |op| |minivectorName|) |$minivectorNames|)) + (SPADLET |body| (MSUBST |minivectorName| (QUOTE $$$) |body|)) + (COND + (|$compilingInputFile| + (SPADLET |$minivectorCode| + (APPEND |$minivectorCode| (CONS |minivectorName| NIL))))) + (SET |minivectorName| (LIST2REFVEC |$minivector|)) + (|compileInteractive| + (CONS |name| + (CONS (CONS (QUOTE LAMBDA) (CONS |parms| (CONS |body| NIL))) NIL))) + (CAR |sig|)))))) + +;depthOfRecursion(opName,body) == +; -- returns the "depth" of recursive calls of opName in body +; mapRecurDepth(opName,nil,body) + +(DEFUN |depthOfRecursion| (|opName| |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"]) + +(DEFUN |mapRecurDepth| (|opName| |opList| |body|) + (PROG (|op| |argl| |argc| |obj| |ISTMP#1| |mapDef|) + (RETURN + (SEQ + (COND + ((ATOM |body|) 0) + ((AND (PAIRP |body|) + (PROGN + (SPADLET |op| (QCAR |body|)) + (SPADLET |argl| (QCDR |body|)) + (QUOTE T))) + (SPADLET |argc| + (COND + ((ATOM |argl|) 0) + (|argl| + (PROG (#0=#:G167773) + (SPADLET #0# -999999) + (RETURN + (DO ((#1=#:G167778 |argl| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (MAX #0# (|mapRecurDepth| |opName| |opList| |x|))))))))) + ((QUOTE T) 0))) + (COND + ((|member| |op| |opList|) |argc|) + ((BOOT-EQUAL |op| |opName|) (PLUS 1 |argc|)) + ((AND (SPADLET |obj| (|get| |op| (QUOTE |value|) |$e|)) + (PROGN + (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) + (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T))))) + (PLUS + (|mapRecurDepth| |opName| + (CONS |op| |opList|) + (|getMapBody| |op| |mapDef|)) + |argc|)) + ((QUOTE T) |argc|))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "mapRecurDepth" (CONS "unknown function form" NIL))))))))) + +;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) + +(DEFUN |analyzeUndeclaredMap| (|op| |argTypes| |mapDef| |$mapList|) + (DECLARE (SPECIAL |$mapList|)) + (PROG (|$freeVars| |$localVars| |$env| |parms| |body| |n|) + (DECLARE (SPECIAL |$freeVars| |$localVars| |$env|)) + (RETURN + (SEQ + (PROGN + (SPADLET |$freeVars| NIL) + (SPADLET |$localVars| NIL) + (SPADLET |$env| (CONS (CONS NIL NIL) NIL)) + (SPADLET |$mapList| (CONS |op| |$mapList|)) + (SPADLET |parms| + (PROG (#0=#:G167801) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167807 |$FormalMapVariableList| (CDR #1#)) + (|var| NIL) + (#2=#:G167808 |argTypes| (CDR #2#)) + (|m| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |var| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |m| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS |var| #0#)))))))) + (DO ((#3=#:G167823 |argTypes| (CDR #3#)) + (|m| NIL) + (#4=#:G167824 |parms| (CDR #4#)) + (|var| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |m| (CAR #3#)) NIL) + (ATOM #4#) + (PROGN (SETQ |var| (CAR #4#)) NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (|put| |var| (QUOTE |autoDeclare|) (QUOTE T) |$env|) + (|put| |var| (QUOTE |mode|) |m| |$env|))))) + (SPADLET |body| (|getMapBody| |op| |mapDef|)) + (DO ((#5=#:G167836 |parms| (CDR #5#)) (|lvar| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |lvar| (CAR #5#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (DO ((#6=#:G167845 (|getLocalVars| |op| |body|) (CDR #6#)) (|lvar| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |lvar| (CAR #6#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (COND + ((EQL (SPADLET |n| (|depthOfRecursion| |op| |body|)) 0) + (|analyzeNonRecursiveMap| |op| |argTypes| |body| |parms|)) + ((QUOTE T) + (|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) + +(DEFUN |analyzeNonRecursiveMap| (|op| |argTypes| |body| |parms|) + (PROG (|b| |t| T$ |sig| |name|) + (RETURN + (SEQ + (PROGN + (SPADLET T$ (|compileBody| |body| |$mapTarget|)) + (COND + ((> |$mapThrowCount| 0) + (SPADLET |t| (|objMode| T$)) + (SPADLET |b| + (PROG (#0=#:G167872) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G167878 NIL (NULL #0#)) + (#2=#:G167879 |$mapReturnTypes| (CDR #2#)) + (|rt| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |rt| (CAR #2#)) NIL)) + #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (BOOT-EQUAL |t| |rt|))))))))) + (COND + ((NULL |b|) + (PROGN + (SPADLET |t| (|resolveTypeListAny| (CONS |t| |$mapReturnTypes|))) + (COND ((NULL |$mapTarget|) (SPADLET |$mapTarget| |t|))) + (SPADLET T$ (|compileBody| |body| |$mapTarget|))))))) + (SPADLET |sig| (CONS (|objMode| T$) |argTypes|)) + (SPADLET |name| (|makeLocalModemap| |op| |sig|)) + (|putMapCode| |op| (|objVal| T$) |sig| |name| |parms| NIL) + (|genMapCode| |op| (|objVal| T$) |sig| |name| |parms| NIL) + (|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 + +(DEFUN |analyzeRecursiveMap| (|op| |argTypes| |body| |parms| |n|) + (PROG (|localMapInfo| |sig| |name| |code| |sigChanged| |tar|) + (RETURN + (SEQ + (PROGN + (SPADLET |localMapInfo| (|saveDependentMapInfo| |op| (CDR |$mapList|))) + (SPADLET |tar| + (CATCH (QUOTE |interpreter|) + (|analyzeNonRecur| |op| |body| |$localVars|))) + (DO ((|i| 0 (QSADD1 |i|)) (#0=#:G167912 NIL (NULL |sigChanged|))) + ((OR (QSGREATERP |i| |n|) #0#) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |sigChanged| NIL) + (SPADLET |name| + (|makeLocalModemap| |op| (SPADLET |sig| (CONS |tar| |argTypes|)))) + (SPADLET |code| (|compileBody| |body| |$mapTarget|)) + (COND + ((NEQUAL (|objMode| |code|) |tar|) + (PROGN + (SPADLET |sigChanged| (QUOTE T)) + (SPADLET |tar| (|objMode| |code|)) + (|restoreDependentMapInfo| |op| + (CDR |$mapList|) + |localMapInfo|)))))))) + (COND + (|sigChanged| (|throwKeyedMsg| (QUOTE S2IM0011) (CONS |op| NIL))) + ((QUOTE T) + (|putMapCode| |op| (|objVal| |code|) |sig| |name| |parms| (QUOTE T)) + (|genMapCode| |op| (|objVal| |code|) |sig| |name| |parms| (QUOTE T)) + |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 + +(DEFUN |saveDependentMapInfo| (|op| |opList|) + (PROG (|lmml| |dep1| |dep2| |LETTMP#1| |lmml'| |gcl'| |lmms| |gcl|) + (RETURN + (SEQ + (COND + ((NULL (|member| |op| |opList|)) + (SPADLET |lmml| + (CONS (CONS |op| (|get| |op| (QUOTE |localModemap|) |$e|)) NIL)) + (SPADLET |gcl| + (CONS (CONS |op| (|get| |op| (QUOTE |generatedCode|) |$e|)) NIL)) + (DO ((#0=#:G167952 (|getFlag| (QUOTE |$dependencies|)) (CDR #0#)) + (#1=#:G167936 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |dep1| (CAR #1#)) + (SPADLET |dep2| (CADR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |dep1| |op|) + (PROGN + (SPADLET |LETTMP#1| + (|saveDependentMapInfo| |dep2| (CONS |op| |opList|))) + (SPADLET |lmml'| (CAR |LETTMP#1|)) + (SPADLET |gcl'| (CDR |LETTMP#1|)) + (SPADLET |lmms| (NCONC |lmml'| |lmml|)) + (SPADLET |gcl| (NCONC |gcl'| |gcl|)))))))) + (CONS |lmms| |gcl|)) + ((QUOTE T) 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) + +(DEFUN |restoreDependentMapInfo| (|op| |opList| #0=#:G167980) + (PROG (|lmml| |gcl| |lmm| |gc|) + (RETURN + (SEQ + (PROGN + (SPADLET |lmml| (CAR #0#)) + (SPADLET |gcl| (CDR #0#)) + (COND + ((NULL (|member| |op| |opList|)) + (PROGN + (|clearDependentMaps| |op| |opList|) + (DO ((#1=#:G167999 |lmml| (CDR #1#)) (#2=#:G167971 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR #2#)) + (SPADLET |lmm| (CDR #2#)) + #2#) + NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |$e| (|putHist| |op| (QUOTE |localModemap|) |lmm| |$e|))))) + (DO ((#3=#:G168010 |gcl| (CDR #3#)) (#4=#:G167975 NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ #4# (CAR #3#)) NIL) + (PROGN + (PROGN (SPADLET |op| (CAR #4#)) (SPADLET |gc| (CDR #4#)) #4#) + NIL)) + NIL) + (SEQ + (EXIT + (SPADLET |$e| + (|putHist| |op| (QUOTE |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]) + +(DEFUN |clearDependentMaps| (|op| |opList|) + (PROG (|dep1| |dep2|) + (RETURN + (SEQ + (COND + ((NULL (|member| |op| |opList|)) + (EXIT + (PROGN + (SPADLET |$e| (|putHist| |op| (QUOTE |localModemap|) NIL |$e|)) + (SPADLET |$e| (|putHist| |op| (QUOTE |generatedCode|) NIL |$e|)) + (DO ((#0=#:G168038 (|getFlag| (QUOTE |$dependencies|)) (CDR #0#)) + (#1=#:G168028 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |dep1| (CAR #1#)) + (SPADLET |dep2| (CADR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |dep1| |op|) + (|clearDependentMaps| |dep2| (CONS |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)) + +(DEFUN |analyzeNonRecur| (|op| |body| |$localVars|) + (DECLARE (SPECIAL |$localVars|)) + (PROG (|nrp|) + (RETURN + (SEQ + (PROGN + (SPADLET |nrp| (|nonRecursivePart| |op| |body|)) + (DO ((#0=#:G168056 (|findLocalVars| |op| |nrp|) (CDR #0#)) (|lvar| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |lvar| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|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]) + +(DEFUN |nonRecursivePart| (|opName| |funBody|) + (PROG (|body| |nrp|) + (RETURN + (PROGN + (SPADLET |body| (|expandRecursiveBody| (CONS |opName| NIL) |funBody|)) + (COND + ((NEQUAL (SPADLET |nrp| (|nonRecursivePart1| |opName| |body|)) + (QUOTE |noMapVal|)) + |nrp|) + ((QUOTE T) (|throwKeyedMsg| (QUOTE S2IM0012) (CONS |opName| NIL)))))))) + +;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"]) + +(DEFUN |expandRecursiveBody| (|alreadyExpanded| |body|) + (PROG (|op| |argl| |obj| |ISTMP#1| |mapDef| |newBody|) + (RETURN + (SEQ + (COND + ((ATOM |body|) + (COND + ((AND + (SPADLET |obj| (|get| |body| (QUOTE |value|) |$e|)) + (PROGN + (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) + (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T)))) + (EQL (|numMapArgs| |mapDef|) 0)) + (|getMapBody| |body| |mapDef|)) + ((QUOTE T) |body|))) + ((AND (PAIRP |body|) + (PROGN + (SPADLET |op| (QCAR |body|)) + (SPADLET |argl| (QCDR |body|)) + (QUOTE T))) + (COND + ((NULL (|member| |op| |alreadyExpanded|)) + (COND + ((AND (SPADLET |obj| (|get| |op| (QUOTE |value|) |$e|)) + (PROGN + (SPADLET |ISTMP#1| (|objVal| |obj|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE MAP)) + (PROGN (SPADLET |mapDef| (QCDR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |newBody| (|getMapBody| |op| |mapDef|)) + (DO ((#0=#:G168093 |argl| (CDR #0#)) + (|arg| NIL) + (#1=#:G168094 |$FormalMapVariableList| (CDR #1#)) + (|var| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |arg| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |var| (CAR #1#)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |newBody| (MSUBST |arg| |var| |newBody|))))) + (|expandRecursiveBody| (CONS |op| |alreadyExpanded|) |newBody|)) + ((QUOTE T) + (CONS |op| + (PROG (#2=#:G168107) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G168112 |argl| (CDR #3#)) (|arg| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |arg| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (SETQ #2# + (CONS + (|expandRecursiveBody| |alreadyExpanded| |arg|) + #2#))))))))))) + ((QUOTE T) + (CONS |op| + (PROG (#4=#:G168122) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G168127 |argl| (CDR #5#)) (|arg| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |arg| (CAR #5#)) NIL)) + (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (|expandRecursiveBody| |alreadyExpanded| |arg|) + #4#))))))))))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "expandRecursiveBody" + (CONS "unknown form of function body" NIL))))))))) + +;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 + +(DEFUN |nonRecursivePart1| (|opName| |funBody|) + (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c| |nra| |nrb| |nrc| + |op| |argl| |args|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |funBody|) + (EQ (QCAR |funBody|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |funBody|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (SPADLET |nra| (|nonRecursivePart1| |opName| |a|)) + (COND + ((BOOT-EQUAL |nra| (QUOTE |noMapVal|)) (QUOTE |noMapVal|)) + ((QUOTE T) + (SPADLET |nrb| (|nonRecursivePart1| |opName| |b|)) + (SPADLET |nrc| (|nonRecursivePart1| |opName| |c|)) + (COND + ((NULL (|member| |nrb| (QUOTE (|noMapVal| |noBranch|)))) + (CONS (QUOTE IF) (CONS |nra| (CONS |nrb| (CONS |nrc| NIL))))) + ((NULL (|member| |nrc| (QUOTE (|noMapVal| |noBranch|)))) + (CONS + (QUOTE IF) + (CONS + (CONS (QUOTE |not|) (CONS |nra| NIL)) + (CONS |nrc| (CONS |nrb| NIL))))) + ((QUOTE T) (QUOTE |noMapVal|)))))) + ((NULL (|containsOp| |funBody| (QUOTE IF))) + (COND + ((|notCalled| |opName| |funBody|) |funBody|) + ((QUOTE T) (QUOTE |noMapVal|)))) + ((AND (PAIRP |funBody|) + (PROGN + (SPADLET |op| (QCAR |funBody|)) + (SPADLET |argl| (QCDR |funBody|)) + (QUOTE T))) + (COND + ((BOOT-EQUAL |op| |opName|) (QUOTE |noMapVal|)) + ((QUOTE T) + (SPADLET |args| + (PROG (#0=#:G168193) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168198 |argl| (CDR #1#)) (|arg| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |arg| (CAR #1#)) NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|nonRecursivePart1| |opName| |arg|) #0#)))))))) + (COND + ((MEMQ (QUOTE |noMapVal|) |args|) (QUOTE |noMapVal|)) + ((QUOTE T) (CONS |op| |args|)))))) + ((QUOTE T) |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 + +(DEFUN |containsOp| (|body| |op|) + (PROG (|argl|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |body|) (EQUAL (QCAR |body|) |op|)) (QUOTE T)) + ((AND (PAIRP |body|) (PROGN (SPADLET |argl| (QCDR |body|)) (QUOTE T))) + (PROG (#0=#:G168221) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168227 NIL #0#) + (#2=#:G168228 |argl| (CDR #2#)) + (|arg| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |arg| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (OR #0# (|containsOp| |arg| |op|))))))))) + ((QUOTE T) NIL)))))) + +;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"]) + +(DEFUN |notCalled| (|opName| |form|) + (PROG (|op| |argl|) + (RETURN + (SEQ + (COND + ((ATOM |form|) (QUOTE T)) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + (QUOTE T))) + (COND + ((BOOT-EQUAL |op| |opName|) NIL) + ((QUOTE T) + (PROG (#0=#:G168245) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G168251 NIL (NULL #0#)) + (#2=#:G168252 |argl| (CDR #2#)) + (|x| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|notCalled| |opName| |x|))))))))))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "notCalled" (CONS "unknown form of function body" NIL))))))))) + +;mapDefsWithCorrectArgCount(n, mapDef) == +; [def for def in mapDef | (numArgs CAR def) = n] + +(DEFUN |mapDefsWithCorrectArgCount| (|n| |mapDef|) + (PROG NIL + (RETURN + (SEQ + (PROG (#0=#:G168270) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168276 |mapDef| (CDR #1#)) (|def| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |def| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL (|numArgs| (CAR |def|)) |n|) + (SETQ #0# (CONS |def| #0#))))))))))))) + +;numMapArgs(mapDef is [[args,:.],:.]) == +; -- returns the number of arguemnts to the map whose body is mapDef +; numArgs args + +(DEFUN |numMapArgs| (|mapDef|) + (PROG (|args|) + (RETURN + (PROGN + (SPADLET |args| (CAAR |mapDef|)) (|numArgs| |args|))))) + +;numArgs args == +; args is ['_|,a,:.] => numArgs a +; args is ['Tuple,:argl] => #argl +; null args => 0 +; 1 + +(DEFUN |numArgs| (|args|) + (PROG (|ISTMP#1| |a| |argl|) + (RETURN + (COND + ((AND (PAIRP |args|) + (EQ (QCAR |args|) (QUOTE |\||)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |args|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|numArgs| |a|)) + ((AND (PAIRP |args|) + (EQ (QCAR |args|) (QUOTE |Tuple|)) + (PROGN (SPADLET |argl| (QCDR |args|)) (QUOTE T))) + (|#| |argl|)) + ((NULL |args|) 0) + ((QUOTE T) 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"]) + +(DEFUN |combineMapParts| (|mapTail|) + (PROG (|ISTMP#1| |cond| |part| |restMap| |args|) + (RETURN + (SEQ + (COND + ((NULL |mapTail|) (QUOTE |noMapVal|)) + ((AND (PAIRP |mapTail|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |mapTail|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + (SPADLET |part| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (PROGN (SPADLET |restMap| (QCDR |mapTail|)) (QUOTE T))) + (COND + ((OR + (|isSharpVarWithNum| |cond|) + (AND + (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |Tuple|)) + (PROGN (SPADLET |args| (QCDR |cond|)) (QUOTE T)) + (PROG (#0=#:G168317) + (SPADLET #0# (QUOTE T)) + (RETURN + (DO ((#1=#:G168323 NIL (NULL #0#)) + (#2=#:G168324 |args| (CDR #2#)) + (|arg| NIL)) + ((OR #1# (ATOM #2#) (PROGN (SETQ |arg| (CAR #2#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (AND #0# (|isSharpVarWithNum| |arg|))))))))) + (NULL |cond|)) + |part|) + ((QUOTE T) + (CONS + (QUOTE IF) + (CONS + (|mkMapPred| |cond|) + (CONS |part| (CONS (|combineMapParts| |restMap|) NIL))))))) + ((QUOTE T) + (|keyedSystemError| (QUOTE S2GE0016) + (CONS "combineMapParts" (CONS "unknown function form" NIL))))))))) + +;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) + +(DEFUN |mkMapPred| (|cond|) + (PROG (|ISTMP#1| |args| |ISTMP#2| |pred| |vals|) + (RETURN + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |\||)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |args| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |pred| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|mapPredTran| |pred|)) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |Tuple|)) + (PROGN (SPADLET |vals| (QCDR |cond|)) (QUOTE T))) + (|mkValueCheck| |vals| 1)) + ((QUOTE T) + (|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)] + +(DEFUN |mkValueCheck| (|vals| |i|) + (PROG (|val|) + (RETURN + (COND + ((AND (PAIRP |vals|) + (EQ (QCDR |vals|) NIL) + (PROGN (SPADLET |val| (QCAR |vals|)) (QUOTE T))) + (|mkValCheck| |val| |i|)) + ((QUOTE T) + (CONS + (QUOTE |and|) + (CONS + (|mkValCheck| (CAR |vals|) |i|) + (CONS (|mkValueCheck| (CDR |vals|) (PLUS |i| 1)) NIL)))))))) + +;mkValCheck(val,i) == +; -- create equality check for map predicates +; isSharpVarWithNum val => 'true +; ['_=,mkSharpVar i,val] + +(DEFUN |mkValCheck| (|val| |i|) + (COND + ((|isSharpVarWithNum| |val|) (QUOTE |true|)) + ((QUOTE T) (CONS (QUOTE =) (CONS (|mkSharpVar| |i|) (CONS |val| NIL)))))) + +;mkSharpVar i == +; -- create #i +; INTERN CONCAT('"#",STRINGIMAGE i) + +(DEFUN |mkSharpVar| (|i|) + (INTERN (CONCAT (MAKESTRING "#") (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 + +(DEFUN |mapPredTran| (|pred|) + (PROG (|ISTMP#1| |var| |ISTMP#2| |ISTMP#3| |ISTMP#4| |lb| |ISTMP#5| |ub|) + (RETURN + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |in|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) (QUOTE SEGMENT)) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN (SPADLET |lb| (QCAR |ISTMP#4|)) (QUOTE T))))))))))) + (|mkLessOrEqual| |lb| |var|)) + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |in|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCAR |ISTMP#3|) (QUOTE SEGMENT)) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) + (AND + (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |lb| (QCAR |ISTMP#4|)) + (SPADLET |ISTMP#5| (QCDR |ISTMP#4|)) + (AND + (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET |ub| (QCAR |ISTMP#5|)) + (QUOTE T))))))))))))) + (COND + ((NULL |ub|) (|mkLessOrEqual| |lb| |var|)) + ((QUOTE T) + (CONS + (QUOTE |and|) + (CONS + (|mkLessOrEqual| |lb| |var|) + (CONS (|mkLessOrEqual| |var| |ub|) NIL)))))) + ((QUOTE T) |pred|))))) + +;findLocalVars(op,form) == +; -- analyzes form for local and free variables, and returns the list +; -- of locals +; findLocalVars1(op,form) +; $localVars + +(DEFUN |findLocalVars| (|op| |form|) + (PROGN (|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]) + +(DEFUN |findLocalVars1| (|op| |form|) + (PROG (|b| |vars| |vals| |pat| |a| |l| |pattern| |oper| |ISTMP#1| |ISTMP#2| + |body| |itrl| |y| |argl|) + (RETURN + (SEQ + (COND + ((ATOM |form|) + (COND + ((OR (NULL (IDENTP |form|)) (|isSharpVarWithNum| |form|)) NIL) + ((OR (|isLocalVar| |form|) (|isFreeVar| |form|)) NIL) + ((QUOTE T) (|mkFreeVar| |$mapName| |form|)))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |local|)) + (PROGN (SPADLET |vars| (QCDR |form|)) (QUOTE T))) + (DO ((#0=#:G168587 |vars| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (COND ((ATOM |x|) (EXIT (|mkLocalVar| |op| |x|)))))))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |free|)) + (PROGN (SPADLET |vars| (QCDR |form|)) (QUOTE T))) + (DO ((#1=#:G168596 |vars| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) NIL) + (SEQ (EXIT (COND ((ATOM |x|) (EXIT (|mkFreeVar| |op| |x|)))))))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE LET)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (COND + ((AND (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |Tuple|)) + (PROGN + (SPADLET |vars| (QCDR |a|)) + (QUOTE T)) + (PAIRP |b|) + (EQ (QCAR |b|) (QUOTE |Tuple|)) + (PROGN (SPADLET |vals| (QCDR |b|)) (QUOTE T))) + (DO ((#2=#:G168606 |vars| (CDR #2#)) + (|var| NIL) + (#3=#:G168607 |vals| (CDR #3#)) + (|val| NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ |var| (CAR #2#)) NIL) + (ATOM #3#) + (PROGN (SETQ |val| (CAR #3#)) NIL)) + NIL) + (SEQ + (EXIT + (|findLocalVars1| |op| + (CONS (QUOTE LET) (CONS |var| (CONS |val| NIL)))))))) + ((AND (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |construct|)) + (PROGN (SPADLET |pat| (QCDR |a|)) (QUOTE T))) + (DO ((#4=#:G168619 (|listOfVariables| |pat|) (CDR #4#)) (|var| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |var| (CAR #4#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |op| |var|)))) (|findLocalVars1| |op| |b|)) + ((OR (ATOM |a|) + (AND + (PAIRP |a|) + (EQ (QCAR |a|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |a|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))))) + (|mkLocalVar| |op| |a|) (|findLocalVars1| |op| |b|)) + ((QUOTE T) + (|findLocalVars| |op| |b|) + (DO ((#5=#:G168628 |a| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) + (SEQ (EXIT (|findLocalVars1| |op| |x|))))))) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL)))))) + (|mkLocalVar| |op| |a|)) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) (QUOTE |is|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |l| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |pattern| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (PROGN + (|findLocalVars1| |op| |l|) + (DO ((#6=#:G168637 (|listOfVariables| (CDR |pattern|)) (CDR #6#)) + (|var| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |var| (CAR #6#)) NIL)) NIL) + (SEQ (EXIT (|mkLocalVar| |op| |var|)))))) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |oper| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) (QUOTE T)) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + (SPADLET |itrl| (QCDR |ISTMP#2|)) + (QUOTE T)) + (PROGN (SPADLET |itrl| (NREVERSE |itrl|)) (QUOTE T)))) + (MEMQ |oper| (QUOTE (REPEAT COLLECT)))) + (|findLocalsInLoop| |op| |itrl| |body|)) + ((AND + (PAIRP |form|) + (PROGN + (SPADLET |y| (QCAR |form|)) + (SPADLET |argl| (QCDR |form|)) + (QUOTE T))) + (COND + ((EQ |y| (QUOTE |Record|)) NIL) + ((QUOTE T) + (DO ((#7=#:G168646 |argl| (CDR #7#)) (|x| NIL)) + ((OR (ATOM #7#) (PROGN (SETQ |x| (CAR #7#)) NIL)) NIL) + (SEQ (EXIT (|findLocalVars1| |op| |x|))))))) + ((QUOTE T) (|keyedSystemError| (QUOTE S2IM0020) (CONS |op| NIL)))))))) + +;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) + +(DEFUN |findLocalsInLoop| (|op| |itrl| |body|) + (PROG (|lower| |ISTMP#3| |step| |upperList| |index| |ISTMP#2| |s| + |pred| |ISTMP#1| |b|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G168789 |itrl| (CDR #0#)) (|it| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |it| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |it|) + (EQ (QCAR |it|) (QUOTE STEP)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |lower| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |step| (QCAR |ISTMP#3|)) + (SPADLET |upperList| (QCDR |ISTMP#3|)) + (QUOTE T))))))))) + (|mkLocalVar| |op| |index|) + (|findLocalVars1| |op| |lower|) + (DO ((#1=#:G168798 |upperList| (CDR #1#)) (|up| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |up| (CAR #1#)) NIL)) NIL) + (SEQ (EXIT (|findLocalVars1| |op| |up|))))) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) (QUOTE IN)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |index| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |s| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (|mkLocalVar| |op| |index|)) + ((QUOTE T) + (|findLocalVars1| |op| |s|) + (COND + ((AND + (PAIRP |it|) + (EQ (QCAR |it|) (QUOTE WHILE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|findLocalVars1| |op| |b|)) + ((AND + (PAIRP |it|) + (EQ (QCAR |it|) (QUOTE |\||)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |pred| (QCAR |ISTMP#1|)) (QUOTE T))))) + (|findLocalVars1| |op| |pred|)))))))) + (|findLocalVars1| |op| |body|) + (SEQ + (DO ((#2=#:G168812 |itrl| (CDR #2#)) (|it| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |it| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |it|) + (PROGN + (SPADLET |op| (QCAR |it|)) + (SPADLET |ISTMP#1| (QCDR |it|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) (QUOTE T)))) + (|member| |op| (QUOTE (UNTIL)))) + (EXIT (|findLocalVars1| |op| |b|))))))))))))) + +;isLocalVar(var) == MEMBER(var,$localVars) + +(DEFUN |isLocalVar| (|var|) (|member| |var| |$localVars|)) + +;mkLocalVar(op,var) == +; -- add var to the local variable list +; isFreeVar(var) => $localVars +; $localVars:= insert(var,$localVars) + +(DEFUN |mkLocalVar| (|op| |var|) + (COND + ((|isFreeVar| |var|) |$localVars|) + ((QUOTE T) (SPADLET |$localVars| (|insert| |var| |$localVars|))))) + +;isFreeVar(var) == MEMBER(var,$freeVars) + +(DEFUN |isFreeVar| (|var|) (|member| |var| |$freeVars|)) + +;mkFreeVar(op,var) == +; -- op here for symmetry with mkLocalVar +; $freeVars:= insert(var,$freeVars) + +(DEFUN |mkFreeVar| (|op| |var|) + (SPADLET |$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 + +(DEFUN |listOfVariables| (|pat|) + (PROG (|ISTMP#1| |var|) + (RETURN + (SEQ + (COND + ((IDENTP |pat|) + (COND + ((BOOT-EQUAL |pat| (INTERN "." "BOOT")) NIL) + ((QUOTE T) (CONS |pat| NIL)))) + ((OR + (AND (PAIRP |pat|) + (EQ (QCAR |pat|) (QUOTE |:|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T))))) + (AND (PAIRP |pat|) + (EQ (QCAR |pat|) (QUOTE =)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |var| (QCAR |ISTMP#1|)) (QUOTE T)))))) + (COND + ((BOOT-EQUAL |var| (INTERN "." "BOOT")) NIL) + ((QUOTE T) (CONS |var| NIL)))) + ((PAIRP |pat|) + (REMDUP + (PROG (#0=#:G168865) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G168870 |pat| (CDR #1#)) (|p| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |p| (CAR #1#)) NIL)) #0#) + (SEQ (EXIT (SETQ #0# (APPEND #0# (|listOfVariables| |p|)))))))))) + ((QUOTE T) 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 + +(DEFUN |getMapBody| (|op| |mapDef|) + (OR (|get| |op| (QUOTE |mapBody|) |$e|) (|combineMapParts| |mapDef|))) + +;-- $e:= putHist(op,'mapBody,body:= combineMapParts mapDef,$e) +;-- body + +@ +\begin{verbatim} +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. +\end{verbatim} +<<*>>= +;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 + +(DEFUN |getLocalVars| (|op| |body|) + (PROG (|lv|) + (RETURN + (OR + (|get| |op| (QUOTE |localVars|) |$e|) + (PROGN + (SPADLET |$e| + (|putHist| |op| + (QUOTE |localVars|) + (SPADLET |lv| (|findLocalVars| |op| |body|)) |$e|)) + |lv|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}