diff --git a/changelog b/changelog index cb533bc..0000e38 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090822 tpd src/axiom-website/patches.html 20090822.05.tpd.patch +20090822 tpd src/interp/Makefile move i-spec2.boot to i-spec2.lisp +20090822 tpd src/interp/i-spec2.lisp added, rewritten from i-spec2.boot +20090822 tpd src/interp/i-spec2.boot removed, rewritten to i-spec2.lisp 20090822 tpd src/axiom-website/patches.html 20090822.04.tpd.patch 20090822 tpd src/interp/Makefile move i-spec1.boot to i-spec1.lisp 20090822 tpd src/interp/i-spec1.lisp added, rewritten from i-spec1.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index d166aca..52238a8 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1842,5 +1842,7 @@ i-output.lisp rewrite from boot to lisp
i-resolv.lisp rewrite from boot to lisp
20090822.04.tpd.patch i-spec1.lisp rewrite from boot to lisp
+20090822.05.tpd.patch +i-spec2.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 8f22799..4a7e784 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -431,7 +431,6 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/info.boot.dvi ${DOC}/interop.boot.dvi \ ${DOC}/intfile.boot.dvi \ ${DOC}/intint.lisp.dvi ${DOC}/int-top.boot.dvi \ - ${DOC}/i-spec2.boot.dvi \ ${DOC}/i-syscmd.boot.dvi ${DOC}/iterator.boot.dvi \ ${DOC}/i-toplev.boot.dvi ${DOC}/i-util.boot.dvi \ ${DOC}/lisplib.boot.dvi ${DOC}/macex.boot.dvi \ @@ -3342,46 +3341,27 @@ ${MID}/i-spec1.lisp: ${IN}/i-spec1.lisp.pamphlet @ -\subsection{i-spec2.boot} +\subsection{i-spec2.lisp} <>= -${OUT}/i-spec2.${O}: ${MID}/i-spec2.clisp - @ echo 315 making ${OUT}/i-spec2.${O} from ${MID}/i-spec2.clisp - @ (cd ${MID} ; \ +${OUT}/i-spec2.${O}: ${MID}/i-spec2.lisp + @ echo 136 making ${OUT}/i-spec2.${O} from ${MID}/i-spec2.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/i-spec2.clisp"' \ + echo '(progn (compile-file "${MID}/i-spec2.lisp"' \ ':output-file "${OUT}/i-spec2.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/i-spec2.clisp"' \ + echo '(progn (compile-file "${MID}/i-spec2.lisp"' \ ':output-file "${OUT}/i-spec2.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/i-spec2.clisp: ${IN}/i-spec2.boot.pamphlet - @ echo 316 making ${MID}/i-spec2.clisp from ${IN}/i-spec2.boot.pamphlet +<>= +${MID}/i-spec2.lisp: ${IN}/i-spec2.lisp.pamphlet + @ echo 137 making ${MID}/i-spec2.lisp from \ + ${IN}/i-spec2.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/i-spec2.boot.pamphlet >i-spec2.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "i-spec2.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "i-spec2.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm i-spec2.boot ) - -@ -<>= -${DOC}/i-spec2.boot.dvi: ${IN}/i-spec2.boot.pamphlet - @echo 317 making ${DOC}/i-spec2.boot.dvi \ - from ${IN}/i-spec2.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/i-spec2.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} i-spec2.boot ; \ - rm -f ${DOC}/i-spec2.boot.pamphlet ; \ - rm -f ${DOC}/i-spec2.boot.tex ; \ - rm -f ${DOC}/i-spec2.boot ) + ${TANGLE} ${IN}/i-spec2.lisp.pamphlet >i-spec2.lisp ) @ @@ -6480,8 +6460,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/i-spec2.boot.pamphlet b/src/interp/i-spec2.boot.pamphlet deleted file mode 100644 index 8b16f05..0000000 --- a/src/interp/i-spec2.boot.pamphlet +++ /dev/null @@ -1,1202 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp i-spec2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Handlers for Special Forms (2 of 2) - -This file contains the functions which do type analysis and -evaluation of special functions in the interpreter. -Special functions are ones which are not defined in the algebra -code, such as assignment, construct, COLLECT and declaration. - -Operators which require special handlers all have a LISP "up" -property which is the name of the special handler, which is -always the word "up" followed by the operator name. -If an operator has this "up" property the handler is called -automatically from bottomUp instead of general modemap selection. - -The up handlers are usually split into two pieces, the first is -the up function itself, which performs the type analysis, and an -"eval" function, which generates (and executes, if required) the -code for the function. -The up functions always take a single argument, which is the -entire attributed tree for the operation, and return the modeSet -of the node, which is a singleton list containing the type -computed for the node. -The eval functions can take any arguments deemed necessary. -Actual evaluation is done if $genValue is true, otherwise code is -generated. -(See the function analyzeMap for other things that may affect -what is generated in these functions.) - -These functions are required to do two things: - 1) do a putValue on the operator vector with the computed value - of the node, which is a triple. This is usually done in the - eval functions. - 2) do a putModeSet on the operator vector with a list of the - computed type of the node. This is usually done in the - up functions. - -There are several special modes used in these functions: - 1) Void is the mode that should be used for all statements - that do not otherwise return values, such as declarations, - loops, IF-THEN's without ELSE's, etc.. - 2) $NoValueMode and $ThrowAwayMode used to be used in situations - where Void is now used, and are being phased out completely. -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - --- Functions which require special handlers (also see end of file) - ---% Handlers for map definitions - -upDEF t == - -- performs map definitions. value is thrown away - t isnt [op,def,pred,.] => nil - v:=addDefMap(['DEF,:def],pred) - null(LISTP(def)) or null(def) => - keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) - mapOp := first def - if LISTP(mapOp) then - null mapOp => - keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) - mapOp := first mapOp - put(mapOp,'value,v,$e) - putValue(op,objNew(voidValue(), $Void)) - putModeSet(op,[$Void]) - ---% Handler for package calling and $ constants - -upDollar t == - -- Puts "dollar" property in atree node, and calls bottom up - t isnt [op,D,form] => nil - t2 := t - (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] => - keyedMsgCompFailure("S2IS0032",NIL) - EQ(D,'Lisp) => upLispCall(op,form) - if VECP D and (SIZE(D) > 0) then D := D.0 - t := evaluateType unabbrev D - categoryForm? t => - throwKeyedMsg("S2IE0012", [t]) - f := getUnname form - if f = $immediateDataSymbol then - f := objValUnwrap coerceInteractive(getValue form,$OutputForm) - if f = '(construct) then f := "nil" - ATOM(form) and (f ^= $immediateDataSymbol) and - (u := findUniqueOpInDomain(op,f,t)) => u - f in '(One Zero true false nil) and constantInDomain?([f],t) => - isPartialMode t => throwKeyedMsg("S2IS0020",NIL) - if $genValue then - val := wrap getConstantFromDomain([f],t) - else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t] - putValue(op,objNew(val,t)) - putModeSet(op,[t]) - - nargs := #rest form - - (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms - - f ^= 'construct and null isOpInDomain(f,t,nargs) => - throwKeyedMsg("S2IS0023",[f,t]) - if (sig := findCommonSigInDomain(f,t,nargs)) then - for x in sig for y in form repeat - if x then putTarget(y,x) - putAtree(first form,'dollar,t) - ms := bottomUp form - f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm => - throwKeyedMsg("S2IS0021",[f,t]) - putValue(op,getValue first form) - putModeSet(op,ms) - - -upDollarTuple(op, f, t, t2, args, nargs) == - -- this function tries to find a tuple function to use - nargs = 1 and getUnname first args = "Tuple" => NIL - nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL - null (singles := isOpInDomain(f,t,1)) => NIL - tuple := NIL - for [[.,arg], :.] in singles while null tuple repeat - if arg is ['Tuple,.] then tuple := arg - null tuple => NIL - [.,D,form] := t2 - newArg := [mkAtreeNode "Tuple",:args] - putTarget(newArg, tuple) - ms := bottomUp newArg - first ms ^= tuple => NIL - form := [first form, newArg] - putAtree(first form,'dollar,t) - ms := bottomUp form - putValue(op,getValue first form) - putModeSet(op,ms) - -upLispCall(op,t) == - -- process $Lisp calls - if atom t then code:=getUnname t else - [lispOp,:argl]:= t - null functionp lispOp.0 => - throwKeyedMsg("S2IS0024",[lispOp.0]) - for arg in argl repeat bottomUp arg - code:=[getUnname lispOp, - :[getArgValue(arg,computedMode arg) for arg in argl]] - code := - $genValue => wrap timedEVALFUN code - code - rt := '(SExpression) - putValue(op,objNew(code,rt)) - putModeSet(op,[rt]) - ---% Handlers for equation - -upequation tree == - -- only handle this if there is a target of Boolean - -- this should speed things up a bit - tree isnt [op,lhs,rhs] => NIL - $Boolean ^= getTarget(op) => NIL - null VECP op => NIL - -- change equation into '=' - op.0 := "=" - bottomUp tree - ---% Handler for error - -uperror t == - -- when compiling a function, this merely inserts another argument - -- which is the name of the function. - not $compilingMap => NIL - t isnt [op,msg] => NIL - msgMs := bottomUp msg - msgMs isnt [=$String] => NIL - RPLACD(t,[mkAtree object2String $mapName,msg]) - bottomUp t - ---% Handlers for free and local - -upfree t == - putValue(t,objNew('(voidValue),$Void)) - putModeSet(t,[$Void]) - -uplocal t == - putValue(t,objNew('(voidValue),$Void)) - putModeSet(t,[$Void]) - -upfreeWithType(var,type) == - sayKeyedMsg("S2IS0055",['"free",var]) - var - -uplocalWithType(var,type) == - sayKeyedMsg("S2IS0055",['"local",var]) - var - ---% Handlers for has - -uphas t == - t isnt [op,type,prop] => nil - -- handler for category and attribute queries - type := - isLocalVar(type) => ['unabbrev, type] - MKQ unabbrev type - catCode := - prop := unabbrev prop - evaluateType0 prop => ['evaluateType, MKQ prop] - MKQ prop - code:=['newHasTest,['evaluateType, type], catCode] - if $genValue then code := wrap timedEVALFUN code - putValue(op,objNew(code,$Boolean)) - putModeSet(op,[$Boolean]) - ---hasTest(a,b) == --- newHasTest(a,b) --see NRUNFAST BOOT - ---% Handlers for IF - -upIF t == - t isnt [op,cond,a,b] => nil - bottomUpPredicate(cond,'"if/when") - $genValue => interpIF(op,cond,a,b) - compileIF(op,cond,a,b,t) - -compileIF(op,cond,a,b,t) == - -- type analyzer for compiled case where types of both branches of - -- IF are resolved. - ms1 := bottomUp a - [m1] := ms1 - b = 'noBranch => - evalIF(op,rest t,$Void) - putModeSet(op,[$Void]) - b = 'noMapVal => - -- if this was a return statement, we take the mode to be that - -- of what is being returned. - if getUnname a = 'return then - ms1 := bottomUp CADR a - [m1] := ms1 - evalIF(op,rest t,m1) - putModeSet(op,ms1) - ms2 := bottomUp b - [m2] := ms2 - m:= - m2=m1 => m1 - m2 = $Exit => m1 - m1 = $Exit => m2 - if EQCAR(m1,'Symbol) then - m1:=getMinimalVarMode(getUnname a,$declaredMode) - if EQCAR(m2,'Symbol) then - m2:=getMinimalVarMode(getUnname b,$declaredMode) - (r := resolveTTAny(m2,m1)) => r - rempropI($mapName,'localModemap) - rempropI($mapName,'localVars) - rempropI($mapName,'mapBody) - throwKeyedMsg("S2IS0026",[m2,m1]) - evalIF(op,rest t,m) - putModeSet(op,[m]) - -evalIF(op,[cond,a,b],m) == - -- generate code form compiled IF - elseCode:= - b='noMapVal => - [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018", - ['CONS,MKQ object2Identifier $mapName,NIL]]]] - b='noBranch => - $lastLineInSEQ => [[MKQ true,['voidValue]]] - NIL - [[MKQ true,genIFvalCode(b,m)]] - code:=['COND,[getArgValue(cond,$Boolean), - genIFvalCode(a,m)],:elseCode] - triple:= objNew(code,m) - putValue(op,triple) - -genIFvalCode(t,m) == - -- passes type information down braches of IF statement - -- So that coercions can be performed on data at branches of IF. - m1 := computedMode t - m1=m => getArgValue(t,m) - code:=objVal getValue t - IFcodeTran(code,m,m1) - -IFcodeTran(code,m,m1) == - -- coerces values at branches of IF - null code => code - code is ['spadThrowBrightly,:.] => code - m1 = $Exit => code - code isnt ['COND,[p1,a1],[''T,a2]] => - m = $Void => code - code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => - wrapped2Quote objVal code' - throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) - a1:=IFcodeTran(a1,m,m1) - a2:=IFcodeTran(a2,m,m1) - ['COND,[p1,a1],[''T,a2]] - -interpIF(op,cond,a,b) == - -- non-compiled version of IF type analyzer. Doesn't resolve accross - -- branches of the IF. - val:= getValue cond - val:= coerceInteractive(val,$Boolean) => - objValUnwrap(val) => upIFgenValue(op,a) - EQ(b,'noBranch) => - putValue(op,objNew(voidValue(), $Void)) - putModeSet(op,[$Void]) - upIFgenValue(op,b) - throwKeyedMsg("S2IS0031",NIL) - -upIFgenValue(op,tree) == - -- evaluates tree and transfers the results to op - ms:=bottomUp tree - val:= getValue tree - putValue(op,val) - putModeSet(op,ms) - ---% Handlers for is - -upis t == - t isnt [op,a,pattern] => nil - $opIsIs : local := true - upisAndIsnt t - -upisnt t == - t isnt [op,a,pattern] => nil - $opIsIs : local := nil - upisAndIsnt t - -upisAndIsnt(t:=[op,a,pattern]) == - -- handler for "is" pattern matching - mS:= bottomUp a - mS isnt [m] => - keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) - putPvarModes(removeConstruct pattern,m) - evalis(op,rest t,m) - putModeSet(op,[$Boolean]) - -putPvarModes(pattern,m) == - -- Puts the modes for the pattern variables into $env - m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL) - for pvar in pattern repeat - IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) - pvar is ['_:,var] => - null (var=$quadSymbol) and put(var,'mode,m,$env) - pvar is ['_=,var] => - null (var=$quadSymbol) and put(var,'mode,um,$env) - putPvarModes(pvar,um) - -evalis(op,[a,pattern],mode) == - -- actually handles is and isnt - if $opIsIs - then fun := 'evalIsPredicate - else fun := 'evalIsntPredicate - if isLocalPred pattern then - code:= compileIs(a,pattern) - else code:=[fun,getArgValue(a,mode), - MKQ pattern,MKQ mode] - triple:= - $genValue => objNewWrap(timedEVALFUN code,$Boolean) - objNew(code,$Boolean) - putValue(op,triple) - -isLocalPred pattern == - -- returns true if the is predicate is to be compiled - for pat in pattern repeat - IDENTP pat and isLocalVar(pat) => return true - pat is ['_:,var] and isLocalVar(var) => return true - pat is ['_=,var] and isLocalVar(var) => return true - -compileIs(val,pattern) == - -- produce code for compiled "is" predicate. makes pattern variables - -- into local variables of the function - vars:= NIL - for pat in CDR pattern repeat - IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars] - pat is ['_:,var] => vars:= [var,:vars] - pat is ['_=,var] => vars:= [var,:vars] - predCode:=['LET,g:=GENSYM(),['isPatternMatch, - getArgValue(val,computedMode val),MKQ removeConstruct pattern]] - for var in REMDUP vars repeat - assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode] - null $opIsIs => - ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]] - ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]] - -evalIsPredicate(value,pattern,mode) == - --This function pattern matches value to pattern, and returns - --true if it matches, and false otherwise. As a side effect - --if the pattern matches then the bindings given in the pattern - --are made - pattern:= removeConstruct pattern - ^((valueAlist:=isPatternMatch(value,pattern))='failed) => - for [id,:value] in valueAlist repeat - evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) - true - false - -evalIsntPredicate(value,pattern,mode) == - evalIsPredicate(value,pattern,mode) => NIL - 'TRUE - -removeConstruct pat == - -- removes the "construct" from the beginning of patterns - if pat is ['construct,:p] then pat:=p - if pat is ['cons, a, b] then pat := [a, ['_:, b]] - atom pat => pat - RPLACA(pat,removeConstruct CAR pat) - RPLACD(pat,removeConstruct CDR pat) - pat - -isPatternMatch(l,pats) == - -- perform the actual pattern match - $subs: local := NIL - isPatMatch(l,pats) - $subs - -isPatMatch(l,pats) == - null pats => - null l => $subs - $subs:='failed - null l => - null pats => $subs - pats is [['_:,var]] => - $subs := [[var],:$subs] - $subs:='failed - pats is [pat,:restPats] => - IDENTP pat => - $subs:=[[pat,:first l],:$subs] - isPatMatch(rest l,restPats) - pat is ['_=,var] => - p:=ASSQ(var,$subs) => - CAR l = CDR p => isPatMatch(rest l, restPats) - $subs:='failed - $subs:='failed - pat is ['_:,var] => - n:=#restPats - m:=#l-n - m<0 => $subs:='failed - ZEROP n => $subs:=[[var,:l],:$subs] - $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] - isPatMatch(DROP(m,l),restPats) - isPatMatch(first l,pat) = 'failed => 'failed - isPatMatch(rest l,restPats) - keyedSystemError("S2GE0016",['"isPatMatch", - '"unknown form of is predicate"]) - ---% Handler for iterate - -upiterate t == - null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) - $iterateCount := $iterateCount + 1 - code := ['THROW,$repeatBodyLabel,'(voidValue)] - $genValue => THROW(eval $repeatBodyLabel,voidValue()) - putValue(t,objNew(code,$Void)) - putModeSet(t,[$Void]) - ---% Handler for break - -upbreak t == - t isnt [op,.] => nil - null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) - $breakCount := $breakCount + 1 - code := ['THROW,$repeatLabel,'(voidValue)] - $genValue => THROW(eval $repeatLabel,voidValue()) - putValue(op,objNew(code,$Void)) - putModeSet(op,[$Void]) - ---% Handlers for LET - -upLET t == - -- analyzes and evaluates the righthand side, and does the variable - -- binding - t isnt [op,lhs,rhs] => nil - $declaredMode: local := NIL - PAIRP lhs => - var:= getUnname first lhs - var = 'construct => upLETWithPatternOnLhs t - var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"]) - upLETWithFormOnLhs(op,lhs,rhs) - var:= getUnname lhs - var = $immediateDataSymbol => - -- following will be immediate data, so probably ok to not - -- specially format it - obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) - throwKeyedMsg("S2IS0027",[obj]) - var in '(% %%) => -- for history - throwKeyedMsg("S2IS0027",[var]) - (IDENTP var) and not (var in '(true false elt QUOTE)) => - var ^= (var' := unabbrev(var)) => -- constructor abbreviation - throwKeyedMsg("S2IS0028",[var,var']) - if get(var,'isInterpreterFunction,$e) then - putHist(var,'isInterpreterFunction,false,$e) - sayKeyedMsg("S2IS0049",['"Function",var]) - else if get(var,'isInterpreterRule,$e) then - putHist(var,'isInterpreterRule,false,$e) - sayKeyedMsg("S2IS0049",['"Rule",var]) - not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m) - transferPropsToNode(var,lhs) - if ( m:= getMode(lhs) ) then - $declaredMode := m - putTarget(rhs,m) - if (val := getValue lhs) and (objMode val = $Boolean) and - getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) - (rhsMs:= bottomUp rhs) = [$Void] => - throwKeyedMsg("S2IS0034",[var]) - val:=evalLET(lhs,rhs) - putValue(op,val) - putModeSet(op,[objMode(val)]) - throwKeyedMsg("S2IS0027",[var]) - -isTupleForm f == - -- have to do following since "Tuple" is an internal form name - getUnname f ^= "Tuple" => false - f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" => - #args ^= 1 => true - isTupleForm first args => true - isType first args => false - true - false - -evalLET(lhs,rhs) == - -- lhs is a vector for a variable, and rhs is the evaluated atree - -- for the value which is coerced to the mode of lhs - $useConvertForCoercions: local := true - v' := (v:= getValue rhs) - ((not getMode lhs) and (getModeSet rhs is [.])) or - get(getUnname lhs,'autoDeclare,$env) => - v:= - $genValue => v - objNew(wrapped2Quote objVal v,objMode v) - evalLETput(lhs,v) - t1:= objMode v - t2' := (t2 := getMode lhs) - value:= - t1 = t2 => - $genValue => v - objNew(wrapped2Quote objVal v,objMode v) - if isPartialMode t2 then - if EQCAR(t1,'Symbol) and $declaredMode then - t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) - t' := t2 - null (t2 := resolveTM(t1,t2)) => - if not t2 then t2 := t' - throwKeyedMsg("S2IS0035",[t1,t2]) - null (v := getArgValue(rhs,t2)) => - isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => - throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) - throwKeyedMsg("S2IS0037",[t2]) - t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2) - value => evalLETput(lhs,value) - throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) - -evalLETput(lhs,value) == - -- put value into the cell for lhs - name:= getUnname lhs - if not $genValue then - code:= - isLocalVar(name) => - om := objMode(value) - dm := get(name,'mode,$env) - dm and not ((om = dm) or isSubDomain(om,dm) or - isSubDomain(dm,om)) => - compFailure ['" The type of the local variable", - :bright name,'"has changed in the computation."] - if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) - ['LET,name,objVal value,$mapName] - -- $mapName is set in analyzeMap - om := objMode value - dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) - dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => - THROW('loopCompiler,'tryInterpOnly) - ['unwrap,['evalLETchangeValue,MKQ name, - objNewCode(['wrap,objVal value],objMode value)]] - value:= objNew(code,objMode value) - isLocalVar(name) => - if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) - put(name,'mode,objMode(value),$env) - put(name,'automode,objMode(value),$env) - $genValue and evalLETchangeValue(name,value) - putValue(lhs,value) - -upLETWithPatternOnLhs(t := [op,pattern,a]) == - $opIsIs : local := true - [m] := bottomUp a - putPvarModes(pattern,m) - object := evalis(op,[a,pattern],m) - -- have to change code to return value of a - failCode := - ['spadThrowBrightly,['concat, - '" Pattern",['QUOTE,bright form2String pattern], - '"is not matched in assignment to right-hand side."]] - if $genValue - then - null objValUnwrap object => eval failCode - putValue(op,getValue a) - else - code := ['COND,[objVal object,objVal getValue a],[''T,failCode]] - putValue(op,objNew(code,m)) - putModeSet(op,[m]) - -evalLETchangeValue(name,value) == - -- write the value of name into the environment, clearing dependent - -- maps if its type changes from its last value - localEnv := PAIRP $env - clearCompilationsFlag := - val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) - null val => - not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) - objMode val ^= objMode(value) - if clearCompilationsFlag then - clearDependencies(name,true) - if localEnv and isLocalVar(name) - then $env:= putHist(name,'value,value,$env) - else putIntSymTab(name,'value,value,$e) - objVal value - -upLETWithFormOnLhs(op,lhs,rhs) == - -- bottomUp for assignment to forms (setelt, table or tuple) - lhs' := getUnnameIfCan lhs - rhs' := getUnnameIfCan rhs - lhs' = 'Tuple => - rhs' ^= 'Tuple => throwKeyedMsg("S2IS0039",NIL) - #(lhs) ^= #(rhs) => throwKeyedMsg("S2IS0038",NIL) - -- generate a sequence of assignments, using local variables - -- to first hold the assignments so that things like - -- (t1,t2) := (t2,t1) will work. - seq := [] - temps := [GENSYM() for l in rest lhs] - for lvar in temps repeat mkLocalVar($mapName,lvar) - for l in reverse rest lhs for t in temps repeat - transferPropsToNode(getUnname l,l) - let := mkAtreeNode 'LET - t' := mkAtreeNode t - if m := getMode(l) then putMode(t',m) - seq := cons([let,l,t'],seq) - for t in temps for r in reverse rest rhs - for l in reverse rest lhs repeat - let := mkAtreeNode 'LET - t' := mkAtreeNode t - if m := getMode(l) then putMode(t',m) - seq := cons([let,t',r],seq) - seq := cons(mkAtreeNode 'SEQ,seq) - ms := bottomUp seq - putValue(op,getValue seq) - putModeSet(op,ms) - rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL) - tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) - throwKeyedMsg("S2IS0060", NIL) --- upTableSetelt(op,lhs,rhs) - -seteltable(lhs is [f,:argl],rhs) == - -- produces the setelt form for trees such as "l.2:= 3" - null (g := getUnnameIfCan f) => NIL - EQ(g,'elt) => altSeteltable [:argl, rhs] - get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL - transferPropsToNode(g,f) - getValue(lhs) or getMode(lhs) => - f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs] - altSeteltable [:lhs,rhs] - NIL - -altSeteltable args == - for x in args repeat bottomUp x - newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"] - form := NIL - - -- first look for exact matches for any of the possibilities - while ^form for newOp in newOps repeat - if selectMms(newOp, args, NIL) then form := [newOp, :args] - - -- now try retracting arguments after the first - while ^form and ( "and"/[retractAtree(a) for a in rest args] ) repeat - while ^form for newOp in newOps repeat - if selectMms(newOp, args, NIL) then form := [newOp, :args] - - form - - -upSetelt(op,lhs,tree) == - -- type analyzes implicit setelt forms - var:=opOf lhs - transferPropsToNode(getUnname var,var) - if (m1:=getMode var) then $declaredMode:= m1 - if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then - putModeSet(var,[m1]) - ms := bottomUp tree - putValue(op,getValue tree) - putModeSet(op,ms) - -upTableSetelt(op,lhs is [htOp,:args],rhs) == - -- called only for undeclared, uninitialized table setelts - ("*" = (PNAME getUnname htOp).0) and (1 ^= # args) => - throwKeyedMsg("S2IS0040",NIL) - # args ^= 1 => - throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", - getUnname first args, - ['",",getUnname arg for arg in rest args],'"]"]]) - keyMode := '(Any) - putMode (htOp,['Table,keyMode,'(Any)]) - -- if we are to use a new table, we must call the "table" - -- function to give it an initial value. - bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]] - tableCode := objVal getValue htOp - r := upSetelt(op, lhs, [mkAtreeNode 'setelt,:lhs,rhs]) - $genValue => r - -- construct code - t := getValue op - putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) - r - -isType t == - -- Returns the evaluated type if t is a tree representing a type, - -- and NIL otherwise - op:=opOf t - VECP op => - isMap(op:= getUnname op) => NIL - op = 'Mapping => - argTypes := [isType type for type in rest t] - "or"/[null type for type in argTypes] => nil - ['Mapping, :argTypes] - isLocalVar(op) => NIL - d := isDomainValuedVariable op => d - type:= - -- next line handles subscripted vars - (abbreviation?(op) or (op = 'typeOf) or - constructor?(op) or (op in '(Record Union Enumeration))) and - unabbrev unVectorize t - type and evaluateType type - d := isDomainValuedVariable op => d - NIL - -upLETtype(op,lhs,type) == - -- performs type assignment - opName:= getUnname lhs - (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] => - compFailure ['" Cannot compile type assignment to",:bright opName] - mode := - if isPartialMode type then '(Mode) - else if categoryForm?(type) then '(SubDomain (Domain)) - else '(Domain) - val:= objNew(type,mode) - if isLocalVar(opName) then put(opName,'value,val,$env) - else putHist(opName,'value,val,$e) - putValue(op,val) - -- have to fix the following - putModeSet(op,[mode]) - -assignSymbol(symbol, value, domain) == --- Special function for binding an interpreter variable from within algebra --- code. Does not do the assignment and returns nil, if the variable is --- already assigned - val := get(symbol, 'value, $e) => nil - obj := objNew(wrap value, devaluate domain) - put(symbol, 'value, obj, $e) - true - ---% Handler for Interpreter Macros - -getInterpMacroNames() == - names := [n for [n,:.] in $InterpreterMacroAlist] - if (e := CAAR $InteractiveFrame) and (m := ASSOC("--macros--",e)) then - names := append(names,[n for [n,:.] in CDR m]) - MSORT names - -isInterpMacro name == - -- look in local and then global environment for a macro - null IDENTP name => NIL - name in $specialOps => NIL - (m := get("--macros--",name,$env)) => m - (m := get("--macros--",name,$e)) => m - (m := get("--macros--",name,$InteractiveFrame)) => m - -- $InterpreterMacroAlist will probably be phased out soon - (sv := ASSOC(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv) - NIL - ---% Handlers for prefix QUOTE - -upQUOTE t == - t isnt [op,expr] => NIL - ms:= list - m:= getBasicMode expr => m - IDENTP expr => --- $useSymbolNotVariable => $Symbol - ['Variable,expr] - $OutputForm - evalQUOTE(op,[expr],ms) - putModeSet(op,ms) - -evalQUOTE(op,[expr],[m]) == - triple:= - $genValue => objNewWrap(expr,m) - objNew(['QUOTE,expr],m) - putValue(op,triple) - ---% Handler for pretend - -uppretend t == - t isnt [op,expr,type] => NIL - mode := evaluateType unabbrev type - not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) - bottomUp expr - putValue(op,objNew(objVal getValue expr,mode)) - putModeSet(op,[mode]) - ---% Handlers for REDUCE - -getReduceFunction(op,type,result, locale) == - -- return the function cell for operation with the signature - -- (type,type) -> type, possible from locale - if type is ['Variable,var] then - args := [arg := mkAtreeNode var,arg] - putValue(arg,objNewWrap(var,type)) - else - args := [arg := mkAtreeNode "%1",arg] - if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) - putModeSet(arg,[type]) - vecOp:=mkAtreeNode op - transferPropsToNode(op,vecOp) - if locale then putAtree(vecOp,'dollar,locale) - mmS:= selectMms(vecOp,args,result) - mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | - (isHomogeneousArgs sig) and and/[null c for c in cond]] - null mm => 'failed - [[dc,:sig],fun,:.]:=mm - dc='local => [MKQ [fun,:'local],:CAR sig] - dcVector := evalDomain dc - $compilingMap => - k := NRTgetMinivectorIndex( - NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) - ['ELT,"$$$",k] --$$$ denotes minivector - env:= - NRTcompiledLookup(op,sig,dcVector) - MKQ env - -isHomogeneous sig == - --return true if sig describes a homogeneous binary operation - sig.0=sig.1 and sig.1=sig.2 - -isHomogeneousArgs sig == - --return true if sig describes a homogeneous binary operation - sig.1=sig.2 - ---% Handlers for REPEAT - -transformREPEAT [:itrl,body] == - -- syntactic transformation of repeat iterators, called from mkAtree2 - iterList:=[:iterTran1 for it in itrl] where iterTran1 == - it is ['STEP,index,lower,step,:upperList] => - [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper - for upper in upperList]]] - it is ['IN,index,s] => - [['IN,index,mkAtree1 s]] - it is ['ON,index,s] => - [['IN,index,mkAtree1 ['tails,s]]] - it is ['WHILE,b] => - [['WHILE,mkAtree1 b]] - it is ['_|,pred] => - [['SUCHTHAT,mkAtree1 pred]] - it is [op,:.] and (op in '(VALUE UNTIL)) => nil - bodyTree:=mkAtree1 body - iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 == - it is ['STEP,:.] => nil - it is ['IN,:.] => nil - it is ['ON,:.] => nil - it is ['WHILE,:.] => nil - it is [op,b] and (op in '(UNTIL VALUE)) => - [[op,mkAtree1 b]] - it is ['_|,pred] => nil - keyedSystemError("S2GE0016", - ['"transformREPEAT",'"Unknown type of iterator"]) - [:iterList,bodyTree] - -upREPEAT t == - -- REPEATS always return void() of Void - -- assures throw to interpret-code mode goes to outermost loop - $repeatLabel : local := MKQ GENSYM() - $breakCount : local := 0 - $repeatBodyLabel : local := MKQ GENSYM() - $iterateCount : local := 0 - $compilingLoop => upREPEAT1 t - upREPEAT0 t - -upREPEAT0 t == - -- sets up catch point for interp-only mode - $compilingLoop: local := true - ms := CATCH('loopCompiler,upREPEAT1 t) - ms = 'tryInterpOnly => interpOnlyREPEAT t - ms - -upREPEAT1 t == - -- repeat loop handler with compiled body - -- see if it has the expected form - t isnt [op,:itrl,body] => NIL - -- determine the mode of the repeat loop. At the moment, if there - -- there are no iterators and there are no "break" statements, then - -- the return type is Exit, otherwise Void. - repeatMode := - null(itrl) and ($breakCount=0) => $Void - $Void - - -- if interpreting, go do that - $interpOnly => interpREPEAT(op,itrl,body,repeatMode) - - -- analyze iterators and loop body - upLoopIters itrl - bottomUpCompile body - - -- now that the body is analyzed, we should know everything that - -- is in the UNTIL clause - for itr in itrl repeat - itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") - - -- now go do it - evalREPEAT(op,rest t,repeatMode) - putModeSet(op,[repeatMode]) - -evalREPEAT(op,[:itrl,body],repeatMode) == - -- generate code for loop - bodyMode := computedMode body - bodyCode := getArgValue(body,bodyMode) - if $iterateCount > 0 then - bodyCode := ['CATCH,$repeatBodyLabel,bodyCode] - code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode] - if repeatMode = $Void then code := ['OR,code,'(voidValue)] - code := timedOptimization code - if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] - val:= - $genValue => - timedEVALFUN code - objNewWrap(voidValue(),repeatMode) - objNew(code,repeatMode) - putValue(op,val) - -interpOnlyREPEAT t == - -- interpret-code mode call to upREPEAT - $genValue: local := true - $interpOnly: local := true - upREPEAT1 t - -interpREPEAT(op,itrl,body,repeatMode) == - -- performs interpret-code repeat - $indexVars: local := NIL - $indexTypes: local := NIL - code := - -- we must insert a CATCH for the iterate clause - ['REPEAT,:[interpIter itr for itr in itrl], - ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars, - $indexTypes,nil)]] - SPADCATCH(eval $repeatLabel,timedEVALFUN code) - val:= objNewWrap(voidValue(),repeatMode) - putValue(op,val) - putModeSet(op,[repeatMode]) - -interpLoop(expr,indexList,indexTypes,requiredType) == - -- generates code for interp-only repeat body - ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList], - MKQ indexTypes, MKQ requiredType] - -interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == - -- call interpreter on exp with loop vars in indexList with given - -- values and types, requiredType is used from interpCOLLECT - -- to indicate the required type of the result - emptyAtree exp - for i in indexList for val in indexVals for type in indexTypes repeat - put(i,'value,objNewWrap(val,type),$env) - bottomUp exp - v:= getValue exp - val := - null requiredType => v - coerceInteractive(v,requiredType) - null val => - throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) - objValUnwrap val - ---% Handler for return - -upreturn t == - -- make sure we are in a user function - t isnt [op,val] => NIL - (null $compilingMap) and (null $interpOnly) => - throwKeyedMsg("S2IS0047",NIL) - if $mapTarget then putTarget(val,$mapTarget) - bottomUp val - if $mapTarget - then - val' := getArgValue(val, $mapTarget) - m := $mapTarget - else - val' := wrapped2Quote objVal getValue val - m := computedMode val - cn := mapCatchName $mapName - $mapReturnTypes := insert(m, $mapReturnTypes) - $mapThrowCount := $mapThrowCount + 1 - -- if $genValue then we are interpreting the map - $genValue => THROW(cn,objNewWrap(removeQuote val',m)) - putValue(op,objNew(['THROW,MKQ cn,val'],m)) - putModeSet(op,[$Exit]) - ---% Handler for SEQ - -upSEQ u == - -- assumes that exits were translated into if-then-elses - -- handles flat SEQs and embedded returns - u isnt [op,:args] => NIL - if (target := getTarget(op)) then putTarget(last args, target) - for x in args repeat bottomUp x - null (m := computedMode last args) => - keyedSystemError("S2GE0016",['"upSEQ", - '"last line of SEQ has no mode"]) - evalSEQ(op,args,m) - putModeSet(op,[m]) - -evalSEQ(op,args,m) == - -- generate code for SEQ - [:argl,last] := args - val:= - $genValue => getValue last - bodyCode := nil - for x in args repeat - (m1 := computedMode x) and (m1 ^= '$ThrowAwayMode) => - (av := getArgValue(x,m1)) ^= voidValue() => - bodyCode := [av,:bodyCode] - code:= - bodyCode is [c] => c - ['PROGN,:reverse bodyCode] - objNew(code,m) - putValue(op,val) - ---% Handlers for Tuple - -upTuple t == - --Computes the common mode set of the construct by resolving across - --the argument list, and evaluating - t isnt [op,:l] => nil - dol := getAtree(op,'dollar) - tar := getTarget(op) or dol - null l => upNullTuple(op,l,tar) - isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) - aggs := '(List) - if tar and PAIRP(tar) and ^isPartialMode(tar) then - CAR(tar) in aggs => - ud := CADR tar - for x in l repeat if not getTarget(x) then putTarget(x,ud) - CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => - vec := ['List,underDomainOf tar] - for x in l repeat if not getTarget(x) then putTarget(x,vec) - argModeSetList:= [bottomUp x for x in l] - eltTypes := replaceSymbols([first x for x in argModeSetList],l) - if not isPartialMode(tar) and tar is ['Tuple,ud] then - mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)] - else mode := ['Tuple, resolveTypeListAny eltTypes] - if isPartialMode tar then tar:=resolveTM(mode,tar) - evalTuple(op,l,mode,tar) - -evalTuple(op,l,m,tar) == - [agg,:.,underMode]:= m - code := asTupleNewCode(#l, - [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) - val := - $genValue => objNewWrap(timedEVALFUN code,m) - objNew(code,m) - if tar then val1 := coerceInteractive(val,tar) else val1 := val - - val1 => - putValue(op,val1) - putModeSet(op,[tar or m]) - putValue(op,val) - putModeSet(op,[m]) - -upNullTuple(op,l,tar) == - -- handler for the empty tuple - defMode := - tar and tar is [a,b] and (a in '(Stream Vector List)) and - not isPartialMode(b) => ['Tuple,b] - '(Tuple (None)) - val := objNewWrap(asTupleNew(0,NIL), defMode) - tar and not isPartialMode(tar) => - null (val' := coerceInteractive(val,tar)) => - throwKeyedMsg("S2IS0013",[tar]) - putValue(op,val') - putModeSet(op,[tar]) - putValue(op,val) - putModeSet(op,[defMode]) - ---% Handler for typeOf - -uptypeOf form == - form isnt [op, arg] => NIL - if VECP arg then transferPropsToNode(getUnname arg,arg) - if m := isType(arg) then - m := - categoryForm?(m) => '(SubDomain (Domain)) - isPartialMode m => '(Mode) - '(Domain) - else if not (m := getMode arg) then [m] := bottomUp arg - t := typeOfType m - putValue(op, objNew(m,t)) - putModeSet(op,[t]) - -typeOfType type == - type in '((Mode) (Domain)) => '(SubDomain (Domain)) - '(Domain) - ---% Handler for where - -upwhere t == - -- upwhere does the puts in where into a local environment - t isnt [op,tree,clause] => NIL - -- since the "clause" might be a local macro, we now call mkAtree - -- on the "tree" part (it is not yet a vat) - not $genValue => - compFailure [:bright '" where", - '"for compiled code is not yet implemented."] - $whereCacheList : local := nil - [env,:e] := upwhereClause(clause,$env,$e) - tree := upwhereMkAtree(tree,env,e) - if x := getAtree(op,'dollar) then - atom tree => throwKeyedMsg("S2IS0048",NIL) - putAtree(CAR tree,'dollar,x) - upwhereMain(tree,env,e) - val := getValue tree - putValue(op,val) - result := putModeSet(op,getModeSet tree) - wcl := [op for op in $whereCacheList] - for op in wcl repeat clearDependencies(op,'T) - result - -upwhereClause(tree,env,e) == - -- uses the variable bindings from env and e and returns an environment - -- of its own bindings - $env: local := copyHack env - $e: local := copyHack e - bottomUp tree - [$env,:$e] - -upwhereMkAtree(tree,$env,$e) == mkAtree tree - -upwhereMain(tree,$env,$e) == - -- uses local copies of $env and $e while evaluating tree - bottomUp tree - -copyHack(env) == - -- makes a copy of an environment with the exception of pairs - -- (localModemap . something) - c:= CAAR env - d:= [fn p for p in c] where fn(p) == - CONS(CAR p,[(EQCAR(q,'localModemap) => q; copy q) for q in CDR p]) - [[d]] - --- Creates the function names of the special function handlers and puts --- them on the property list of the function name - -EVALANDFILEACTQ - ( - for name in $specialOps repeat - ( - functionName:=INTERNL('up,name) ; - MAKEPROP(name,'up,functionName) ; - CREATE_-SBC functionName - ) - ) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/i-spec2.lisp.pamphlet b/src/interp/i-spec2.lisp.pamphlet new file mode 100644 index 0000000..7309231 --- /dev/null +++ b/src/interp/i-spec2.lisp.pamphlet @@ -0,0 +1,4052 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-spec2.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\begin{verbatim} +Handlers for Special Forms (2 of 2) + +This file contains the functions which do type analysis and +evaluation of special functions in the interpreter. +Special functions are ones which are not defined in the algebra +code, such as assignment, construct, COLLECT and declaration. + +Operators which require special handlers all have a LISP "up" +property which is the name of the special handler, which is +always the word "up" followed by the operator name. +If an operator has this "up" property the handler is called +automatically from bottomUp instead of general modemap selection. + +The up handlers are usually split into two pieces, the first is +the up function itself, which performs the type analysis, and an +"eval" function, which generates (and executes, if required) the +code for the function. +The up functions always take a single argument, which is the +entire attributed tree for the operation, and return the modeSet +of the node, which is a singleton list containing the type +computed for the node. +The eval functions can take any arguments deemed necessary. +Actual evaluation is done if $genValue is true, otherwise code is +generated. +(See the function analyzeMap for other things that may affect +what is generated in these functions.) + +These functions are required to do two things: + 1) do a putValue on the operator vector with the computed value + of the node, which is a triple. This is usually done in the + eval functions. + 2) do a putModeSet on the operator vector with a list of the + computed type of the node. This is usually done in the + up functions. + +There are several special modes used in these functions: + 1) Void is the mode that should be used for all statements + that do not otherwise return values, such as declarations, + loops, IF-THEN's without ELSE's, etc.. + 2) $NoValueMode and $ThrowAwayMode used to be used in situations + where Void is now used, and are being phased out completely. +\end{verbatim} +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;-- Functions which require special handlers (also see end of file) +;--% Handlers for map definitions +;upDEF t == +; -- performs map definitions. value is thrown away +; t isnt [op,def,pred,.] => nil +; v:=addDefMap(['DEF,:def],pred) +; null(LISTP(def)) or null(def) => +; keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) +; mapOp := first def +; if LISTP(mapOp) then +; null mapOp => +; keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"]) +; mapOp := first mapOp +; put(mapOp,'value,v,$e) +; putValue(op,objNew(voidValue(), $Void)) +; putModeSet(op,[$Void]) + +(DEFUN |upDEF| (|t|) + (PROG (|op| |ISTMP#1| |def| |ISTMP#2| |pred| |ISTMP#3| |v| |mapOp|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |def| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |pred| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL))))))))) + NIL) + ('T (SPADLET |v| (|addDefMap| (CONS 'DEF |def|) |pred|)) + (COND + ((OR (NULL (LISTP |def|)) (NULL |def|)) + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "upDEF") + (CONS (MAKESTRING "bad map definition") NIL)))) + ('T (SPADLET |mapOp| (CAR |def|)) + (COND + ((LISTP |mapOp|) + (COND + ((NULL |mapOp|) + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "upDEF") + (CONS (MAKESTRING "bad map definition") + NIL)))) + ('T (SPADLET |mapOp| (CAR |mapOp|)))))) + (|put| |mapOp| '|value| |v| |$e|) + (|putValue| |op| (|objNew| (|voidValue|) |$Void|)) + (|putModeSet| |op| (CONS |$Void| NIL))))))))) + +;--% Handler for package calling and $ constants +;upDollar t == +; -- Puts "dollar" property in atree node, and calls bottom up +; t isnt [op,D,form] => nil +; t2 := t +; (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] => +; keyedMsgCompFailure("S2IS0032",NIL) +; EQ(D,'Lisp) => upLispCall(op,form) +; if VECP D and (SIZE(D) > 0) then D := D.0 +; t := evaluateType unabbrev D +; categoryForm? t => +; throwKeyedMsg("S2IE0012", [t]) +; f := getUnname form +; if f = $immediateDataSymbol then +; f := objValUnwrap coerceInteractive(getValue form,$OutputForm) +; if f = '(construct) then f := "nil" +; ATOM(form) and (f ^= $immediateDataSymbol) and +; (u := findUniqueOpInDomain(op,f,t)) => u +; f in '(One Zero true false nil) and constantInDomain?([f],t) => +; isPartialMode t => throwKeyedMsg("S2IS0020",NIL) +; if $genValue then +; val := wrap getConstantFromDomain([f],t) +; else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t] +; putValue(op,objNew(val,t)) +; putModeSet(op,[t]) +; nargs := #rest form +; (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms +; f ^= 'construct and null isOpInDomain(f,t,nargs) => +; throwKeyedMsg("S2IS0023",[f,t]) +; if (sig := findCommonSigInDomain(f,t,nargs)) then +; for x in sig for y in form repeat +; if x then putTarget(y,x) +; putAtree(first form,'dollar,t) +; ms := bottomUp form +; f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm => +; throwKeyedMsg("S2IS0021",[f,t]) +; putValue(op,getValue first form) +; putModeSet(op,ms) + +(DEFUN |upDollar| (|t|) + (PROG (|op| |ISTMP#1| |ISTMP#2| |form| |t2| D |f| |u| |val| |nargs| + |sig| |ms|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET D (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |form| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (SPADLET |t2| |t|) + (COND + ((AND (NULL |$genValue|) + (PROG (G166131) + (SPADLET G166131 NIL) + (RETURN + (DO ((G166137 NIL G166131) + (G166138 |$localVars| (CDR G166138)) + (|var| NIL)) + ((OR G166137 (ATOM G166138) + (PROGN + (SETQ |var| (CAR G166138)) + NIL)) + G166131) + (SEQ (EXIT (SETQ G166131 + (OR G166131 + (CONTAINED |var| D))))))))) + (|keyedMsgCompFailure| 'S2IS0032 NIL)) + ((EQ D '|Lisp|) (|upLispCall| |op| |form|)) + ('T + (COND + ((AND (VECP D) (> (SIZE D) 0)) + (SPADLET D (ELT D 0)))) + (SPADLET |t| (|evaluateType| (|unabbrev| D))) + (COND + ((|categoryForm?| |t|) + (|throwKeyedMsg| 'S2IE0012 (CONS |t| NIL))) + ('T (SPADLET |f| (|getUnname| |form|)) + (COND + ((BOOT-EQUAL |f| |$immediateDataSymbol|) + (SPADLET |f| + (|objValUnwrap| + (|coerceInteractive| + (|getValue| |form|) |$OutputForm|))) + (COND + ((BOOT-EQUAL |f| '(|construct|)) + (SPADLET |f| '|nil|)) + ('T NIL)))) + (COND + ((AND (ATOM |form|) + (NEQUAL |f| |$immediateDataSymbol|) + (SPADLET |u| + (|findUniqueOpInDomain| |op| |f| + |t|))) + |u|) + ((AND (|member| |f| + '(|One| |Zero| |true| |false| |nil|)) + (|constantInDomain?| (CONS |f| NIL) |t|)) + (COND + ((|isPartialMode| |t|) + (|throwKeyedMsg| 'S2IS0020 NIL)) + ('T + (COND + (|$genValue| + (SPADLET |val| + (|wrap| + (|getConstantFromDomain| + (CONS |f| NIL) |t|)))) + ('T + (SPADLET |val| + (CONS '|getConstantFromDomain| + (CONS + (CONS 'LIST + (CONS (MKQ |f|) NIL)) + (CONS (MKQ |t|) NIL)))))) + (|putValue| |op| (|objNew| |val| |t|)) + (|putModeSet| |op| (CONS |t| NIL))))) + ('T (SPADLET |nargs| (|#| (CDR |form|))) + (COND + ((SPADLET |ms| + (|upDollarTuple| |op| |f| |t| |t2| + (CDR |form|) |nargs|)) + |ms|) + ((AND (NEQUAL |f| '|construct|) + (NULL (|isOpInDomain| |f| |t| |nargs|))) + (|throwKeyedMsg| 'S2IS0023 + (CONS |f| (CONS |t| NIL)))) + ('T + (COND + ((SPADLET |sig| + (|findCommonSigInDomain| |f| |t| + |nargs|)) + (DO ((G166149 |sig| (CDR G166149)) + (|x| NIL) + (G166150 |form| (CDR G166150)) + (|y| NIL)) + ((OR (ATOM G166149) + (PROGN + (SETQ |x| (CAR G166149)) + NIL) + (ATOM G166150) + (PROGN + (SETQ |y| (CAR G166150)) + NIL)) + NIL) + (SEQ (EXIT + (COND + (|x| (|putTarget| |y| |x|)) + ('T NIL))))))) + (|putAtree| (CAR |form|) '|dollar| |t|) + (SPADLET |ms| (|bottomUp| |form|)) + (COND + ((AND (|member| |f| '(|One| |Zero|)) + (PAIRP |ms|) + (BOOT-EQUAL (CAR |ms|) |$OutputForm|)) + (|throwKeyedMsg| 'S2IS0021 + (CONS |f| (CONS |t| NIL)))) + ('T + (|putValue| |op| + (|getValue| (CAR |form|))) + (|putModeSet| |op| |ms|))))))))))))))))) + +;upDollarTuple(op, f, t, t2, args, nargs) == +; -- this function tries to find a tuple function to use +; nargs = 1 and getUnname first args = "Tuple" => NIL +; nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL +; null (singles := isOpInDomain(f,t,1)) => NIL +; tuple := NIL +; for [[.,arg], :.] in singles while null tuple repeat +; if arg is ['Tuple,.] then tuple := arg +; null tuple => NIL +; [.,D,form] := t2 +; newArg := [mkAtreeNode "Tuple",:args] +; putTarget(newArg, tuple) +; ms := bottomUp newArg +; first ms ^= tuple => NIL +; form := [first form, newArg] +; putAtree(first form,'dollar,t) +; ms := bottomUp form +; putValue(op,getValue first form) +; putModeSet(op,ms) + +(DEFUN |upDollarTuple| (|op| |f| |t| |t2| |args| |nargs|) + (PROG (|ISTMP#2| |singles| |arg| |ISTMP#1| |tuple| D |newArg| |form| + |ms|) + (RETURN + (SEQ (COND + ((AND (EQL |nargs| 1) + (BOOT-EQUAL (|getUnname| (CAR |args|)) '|Tuple|)) + NIL) + ((AND (EQL |nargs| 1) + (SPADLET |ms| (|bottomUp| (CAR |args|))) + (PAIRP |ms|) (EQ (QCDR |ms|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |ms|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + NIL) + ((NULL (SPADLET |singles| (|isOpInDomain| |f| |t| 1))) + NIL) + ('T (SPADLET |tuple| NIL) + (DO ((G166203 |singles| (CDR G166203)) + (G166189 NIL)) + ((OR (ATOM G166203) + (PROGN (SETQ G166189 (CAR G166203)) NIL) + (PROGN + (PROGN + (SPADLET |arg| (CADAR G166189)) + G166189) + NIL) + (NULL (NULL |tuple|))) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |arg|) + (EQ (QCAR |arg|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |arg|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL)))) + (SPADLET |tuple| |arg|)) + ('T NIL))))) + (COND + ((NULL |tuple|) NIL) + ('T (SPADLET D (CADR |t2|)) + (SPADLET |form| (CADDR |t2|)) + (SPADLET |newArg| + (CONS (|mkAtreeNode| '|Tuple|) |args|)) + (|putTarget| |newArg| |tuple|) + (SPADLET |ms| (|bottomUp| |newArg|)) + (COND + ((NEQUAL (CAR |ms|) |tuple|) NIL) + ('T + (SPADLET |form| + (CONS (CAR |form|) (CONS |newArg| NIL))) + (|putAtree| (CAR |form|) '|dollar| |t|) + (SPADLET |ms| (|bottomUp| |form|)) + (|putValue| |op| (|getValue| (CAR |form|))) + (|putModeSet| |op| |ms|))))))))))) + +;upLispCall(op,t) == +; -- process $Lisp calls +; if atom t then code:=getUnname t else +; [lispOp,:argl]:= t +; null functionp lispOp.0 => +; throwKeyedMsg("S2IS0024",[lispOp.0]) +; for arg in argl repeat bottomUp arg +; code:=[getUnname lispOp, +; :[getArgValue(arg,computedMode arg) for arg in argl]] +; code := +; $genValue => wrap timedEVALFUN code +; code +; rt := '(SExpression) +; putValue(op,objNew(code,rt)) +; putModeSet(op,[rt]) + +(DEFUN |upLispCall| (|op| |t|) + (PROG (|lispOp| |argl| |code| |rt|) + (RETURN + (SEQ (PROGN + (COND + ((ATOM |t|) (SPADLET |code| (|getUnname| |t|))) + ('T (SPADLET |lispOp| (CAR |t|)) + (SPADLET |argl| (CDR |t|)) + (COND + ((NULL (|functionp| (ELT |lispOp| 0))) + (|throwKeyedMsg| 'S2IS0024 + (CONS (ELT |lispOp| 0) NIL))) + ('T + (DO ((G166237 |argl| (CDR G166237)) (|arg| NIL)) + ((OR (ATOM G166237) + (PROGN (SETQ |arg| (CAR G166237)) NIL)) + NIL) + (SEQ (EXIT (|bottomUp| |arg|)))) + (SPADLET |code| + (CONS (|getUnname| |lispOp|) + (PROG (G166247) + (SPADLET G166247 NIL) + (RETURN + (DO + ((G166252 |argl| + (CDR G166252)) + (|arg| NIL)) + ((OR (ATOM G166252) + (PROGN + (SETQ |arg| (CAR G166252)) + NIL)) + (NREVERSE0 G166247)) + (SEQ + (EXIT + (SETQ G166247 + (CONS + (|getArgValue| |arg| + (|computedMode| |arg|)) + G166247))))))))))))) + (SPADLET |code| + (COND + (|$genValue| (|wrap| (|timedEVALFUN| |code|))) + ('T |code|))) + (SPADLET |rt| '(|SExpression|)) + (|putValue| |op| (|objNew| |code| |rt|)) + (|putModeSet| |op| (CONS |rt| NIL))))))) + +;--% Handlers for equation +;upequation tree == +; -- only handle this if there is a target of Boolean +; -- this should speed things up a bit +; tree isnt [op,lhs,rhs] => NIL +; $Boolean ^= getTarget(op) => NIL +; null VECP op => NIL +; -- change equation into '=' +; op.0 := "=" +; bottomUp tree + +(DEFUN |upequation| (|tree|) + (PROG (|op| |ISTMP#1| |lhs| |ISTMP#2| |rhs|) + (RETURN + (COND + ((NULL (AND (PAIRP |tree|) + (PROGN + (SPADLET |op| (QCAR |tree|)) + (SPADLET |ISTMP#1| (QCDR |tree|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ((NEQUAL |$Boolean| (|getTarget| |op|)) NIL) + ((NULL (VECP |op|)) NIL) + ('T (SETELT |op| 0 '=) (|bottomUp| |tree|)))))) + +;--% Handler for error +;uperror t == +; -- when compiling a function, this merely inserts another argument +; -- which is the name of the function. +; not $compilingMap => NIL +; t isnt [op,msg] => NIL +; msgMs := bottomUp msg +; msgMs isnt [=$String] => NIL +; RPLACD(t,[mkAtree object2String $mapName,msg]) +; bottomUp t + +(DEFUN |uperror| (|t|) + (PROG (|op| |ISTMP#1| |msg| |msgMs|) + (RETURN + (COND + ((NULL |$compilingMap|) NIL) + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |msg| (QCAR |ISTMP#1|)) 'T))))) + NIL) + ('T (SPADLET |msgMs| (|bottomUp| |msg|)) + (COND + ((NULL (AND (PAIRP |msgMs|) (EQ (QCDR |msgMs|) NIL) + (EQUAL (QCAR |msgMs|) |$String|))) + NIL) + ('T + (RPLACD |t| + (CONS (|mkAtree| (|object2String| |$mapName|)) + (CONS |msg| NIL))) + (|bottomUp| |t|)))))))) + +;--% Handlers for free and local +;upfree t == +; putValue(t,objNew('(voidValue),$Void)) +; putModeSet(t,[$Void]) + +(DEFUN |upfree| (|t|) + (PROGN + (|putValue| |t| (|objNew| '(|voidValue|) |$Void|)) + (|putModeSet| |t| (CONS |$Void| NIL)))) + +;uplocal t == +; putValue(t,objNew('(voidValue),$Void)) +; putModeSet(t,[$Void]) + +(DEFUN |uplocal| (|t|) + (PROGN + (|putValue| |t| (|objNew| '(|voidValue|) |$Void|)) + (|putModeSet| |t| (CONS |$Void| NIL)))) + +;upfreeWithType(var,type) == +; sayKeyedMsg("S2IS0055",['"free",var]) +; var + +(DEFUN |upfreeWithType| (|var| |type|) + (PROGN + (|sayKeyedMsg| 'S2IS0055 + (CONS (MAKESTRING "free") (CONS |var| NIL))) + |var|)) + +;uplocalWithType(var,type) == +; sayKeyedMsg("S2IS0055",['"local",var]) +; var + +(DEFUN |uplocalWithType| (|var| |type|) + (PROGN + (|sayKeyedMsg| 'S2IS0055 + (CONS (MAKESTRING "local") (CONS |var| NIL))) + |var|)) + +;--% Handlers for has +;uphas t == +; t isnt [op,type,prop] => nil +; -- handler for category and attribute queries +; type := +; isLocalVar(type) => ['unabbrev, type] +; MKQ unabbrev type +; catCode := +; prop := unabbrev prop +; evaluateType0 prop => ['evaluateType, MKQ prop] +; MKQ prop +; code:=['newHasTest,['evaluateType, type], catCode] +; if $genValue then code := wrap timedEVALFUN code +; putValue(op,objNew(code,$Boolean)) +; putModeSet(op,[$Boolean]) + +(DEFUN |uphas| (|t|) + (PROG (|op| |ISTMP#1| |ISTMP#2| |type| |prop| |catCode| |code|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |type| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |prop| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T + (SPADLET |type| + (COND + ((|isLocalVar| |type|) + (CONS '|unabbrev| (CONS |type| NIL))) + ('T (MKQ (|unabbrev| |type|))))) + (SPADLET |catCode| + (PROGN + (SPADLET |prop| (|unabbrev| |prop|)) + (COND + ((|evaluateType0| |prop|) + (CONS '|evaluateType| (CONS (MKQ |prop|) NIL))) + ('T (MKQ |prop|))))) + (SPADLET |code| + (CONS '|newHasTest| + (CONS (CONS '|evaluateType| (CONS |type| NIL)) + (CONS |catCode| NIL)))) + (COND + (|$genValue| + (SPADLET |code| (|wrap| (|timedEVALFUN| |code|))))) + (|putValue| |op| (|objNew| |code| |$Boolean|)) + (|putModeSet| |op| (CONS |$Boolean| NIL))))))) + +;--hasTest(a,b) == +;-- newHasTest(a,b) --see NRUNFAST BOOT +;--% Handlers for IF +;upIF t == +; t isnt [op,cond,a,b] => nil +; bottomUpPredicate(cond,'"if/when") +; $genValue => interpIF(op,cond,a,b) +; compileIF(op,cond,a,b,t) + +(DEFUN |upIF| (|t|) + (PROG (|op| |ISTMP#1| |cond| |ISTMP#2| |a| |ISTMP#3| |b|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#3|)) + 'T))))))))) + NIL) + ('T (|bottomUpPredicate| |cond| (MAKESTRING "if/when")) + (COND + (|$genValue| (|interpIF| |op| |cond| |a| |b|)) + ('T (|compileIF| |op| |cond| |a| |b| |t|)))))))) + +;compileIF(op,cond,a,b,t) == +; -- type analyzer for compiled case where types of both branches of +; -- IF are resolved. +; ms1 := bottomUp a +; [m1] := ms1 +; b = 'noBranch => +; evalIF(op,rest t,$Void) +; putModeSet(op,[$Void]) +; b = 'noMapVal => +; -- if this was a return statement, we take the mode to be that +; -- of what is being returned. +; if getUnname a = 'return then +; ms1 := bottomUp CADR a +; [m1] := ms1 +; evalIF(op,rest t,m1) +; putModeSet(op,ms1) +; ms2 := bottomUp b +; [m2] := ms2 +; m:= +; m2=m1 => m1 +; m2 = $Exit => m1 +; m1 = $Exit => m2 +; if EQCAR(m1,'Symbol) then +; m1:=getMinimalVarMode(getUnname a,$declaredMode) +; if EQCAR(m2,'Symbol) then +; m2:=getMinimalVarMode(getUnname b,$declaredMode) +; (r := resolveTTAny(m2,m1)) => r +; rempropI($mapName,'localModemap) +; rempropI($mapName,'localVars) +; rempropI($mapName,'mapBody) +; throwKeyedMsg("S2IS0026",[m2,m1]) +; evalIF(op,rest t,m) +; putModeSet(op,[m]) + +(DEFUN |compileIF| (|op| |cond| |a| |b| |t|) + (PROG (|ms1| |ms2| |m1| |m2| |r| |m|) + (RETURN + (PROGN + (SPADLET |ms1| (|bottomUp| |a|)) + (SPADLET |m1| (CAR |ms1|)) + (COND + ((BOOT-EQUAL |b| '|noBranch|) + (|evalIF| |op| (CDR |t|) |$Void|) + (|putModeSet| |op| (CONS |$Void| NIL))) + ((BOOT-EQUAL |b| '|noMapVal|) + (COND + ((BOOT-EQUAL (|getUnname| |a|) '|return|) + (SPADLET |ms1| (|bottomUp| (CADR |a|))) + (SPADLET |m1| (CAR |ms1|)) |ms1|)) + (|evalIF| |op| (CDR |t|) |m1|) (|putModeSet| |op| |ms1|)) + ('T (SPADLET |ms2| (|bottomUp| |b|)) + (SPADLET |m2| (CAR |ms2|)) + (SPADLET |m| + (COND + ((BOOT-EQUAL |m2| |m1|) |m1|) + ((BOOT-EQUAL |m2| |$Exit|) |m1|) + ((BOOT-EQUAL |m1| |$Exit|) |m2|) + ('T + (COND + ((EQCAR |m1| '|Symbol|) + (SPADLET |m1| + (|getMinimalVarMode| + (|getUnname| |a|) |$declaredMode|)))) + (COND + ((EQCAR |m2| '|Symbol|) + (SPADLET |m2| + (|getMinimalVarMode| + (|getUnname| |b|) |$declaredMode|)))) + (COND + ((SPADLET |r| (|resolveTTAny| |m2| |m1|)) |r|) + ('T (|rempropI| |$mapName| '|localModemap|) + (|rempropI| |$mapName| '|localVars|) + (|rempropI| |$mapName| '|mapBody|) + (|throwKeyedMsg| 'S2IS0026 + (CONS |m2| (CONS |m1| NIL)))))))) + (|evalIF| |op| (CDR |t|) |m|) + (|putModeSet| |op| (CONS |m| NIL)))))))) + +;evalIF(op,[cond,a,b],m) == +; -- generate code form compiled IF +; elseCode:= +; b='noMapVal => +; [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018", +; ['CONS,MKQ object2Identifier $mapName,NIL]]]] +; b='noBranch => +; $lastLineInSEQ => [[MKQ true,['voidValue]]] +; NIL +; [[MKQ true,genIFvalCode(b,m)]] +; code:=['COND,[getArgValue(cond,$Boolean), +; genIFvalCode(a,m)],:elseCode] +; triple:= objNew(code,m) +; putValue(op,triple) + +(DEFUN |evalIF| (|op| G166457 |m|) + (PROG (|cond| |a| |b| |elseCode| |code| |triple|) + (RETURN + (PROGN + (SPADLET |cond| (CAR G166457)) + (SPADLET |a| (CADR G166457)) + (SPADLET |b| (CADDR G166457)) + (SPADLET |elseCode| + (COND + ((BOOT-EQUAL |b| '|noMapVal|) + (CONS (CONS (MKQ 'T) + (CONS (CONS '|throwKeyedMsg| + (CONS (MKQ 'S2IM0018) + (CONS + (CONS 'CONS + (CONS + (MKQ + (|object2Identifier| + |$mapName|)) + (CONS NIL NIL))) + NIL))) + NIL)) + NIL)) + ((BOOT-EQUAL |b| '|noBranch|) + (COND + (|$lastLineInSEQ| + (CONS (CONS (MKQ 'T) + (CONS (CONS '|voidValue| NIL) + NIL)) + NIL)) + ('T NIL))) + ('T + (CONS (CONS (MKQ 'T) + (CONS (|genIFvalCode| |b| |m|) NIL)) + NIL)))) + (SPADLET |code| + (CONS 'COND + (CONS (CONS (|getArgValue| |cond| |$Boolean|) + (CONS (|genIFvalCode| |a| |m|) NIL)) + |elseCode|))) + (SPADLET |triple| (|objNew| |code| |m|)) + (|putValue| |op| |triple|))))) + +;genIFvalCode(t,m) == +; -- passes type information down braches of IF statement +; -- So that coercions can be performed on data at branches of IF. +; m1 := computedMode t +; m1=m => getArgValue(t,m) +; code:=objVal getValue t +; IFcodeTran(code,m,m1) + +(DEFUN |genIFvalCode| (|t| |m|) + (PROG (|m1| |code|) + (RETURN + (PROGN + (SPADLET |m1| (|computedMode| |t|)) + (COND + ((BOOT-EQUAL |m1| |m|) (|getArgValue| |t| |m|)) + ('T (SPADLET |code| (|objVal| (|getValue| |t|))) + (|IFcodeTran| |code| |m| |m1|))))))) + +;IFcodeTran(code,m,m1) == +; -- coerces values at branches of IF +; null code => code +; code is ['spadThrowBrightly,:.] => code +; m1 = $Exit => code +; code isnt ['COND,[p1,a1],[''T,a2]] => +; m = $Void => code +; code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) => +; wrapped2Quote objVal code' +; throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m) +; a1:=IFcodeTran(a1,m,m1) +; a2:=IFcodeTran(a2,m,m1) +; ['COND,[p1,a1],[''T,a2]] + +(DEFUN |IFcodeTran| (|code| |m| |m1|) + (PROG (|ISTMP#1| |ISTMP#2| |p1| |ISTMP#3| |ISTMP#4| |ISTMP#5| + |ISTMP#6| |code'| |a1| |a2|) + (RETURN + (COND + ((NULL |code|) |code|) + ((AND (PAIRP |code|) (EQ (QCAR |code|) '|spadThrowBrightly|)) + |code|) + ((BOOT-EQUAL |m1| |$Exit|) |code|) + ((NULL (AND (PAIRP |code|) (EQ (QCAR |code|) 'COND) + (PROGN + (SPADLET |ISTMP#1| (QCDR |code|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |p1| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |a1| (QCAR |ISTMP#3|)) + 'T))))) + (PROGN + (SPADLET |ISTMP#4| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (PROGN + (SPADLET |ISTMP#5| + (QCAR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQUAL (QCAR |ISTMP#5|) ''T) + (PROGN + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCDR |ISTMP#6|) NIL) + (PROGN + (SPADLET |a2| + (QCAR |ISTMP#6|)) + 'T))))))))))) + (COND + ((BOOT-EQUAL |m| |$Void|) |code|) + ((SPADLET |code'| + (|coerceInteractive| + (|objNew| (|quote2Wrapped| |code|) |m1|) |m|)) + (|wrapped2Quote| (|objVal| |code'|))) + ('T + (|throwKeyedMsgCannotCoerceWithValue| + (|quote2Wrapped| |code|) |m1| |m|)))) + ('T (SPADLET |a1| (|IFcodeTran| |a1| |m| |m1|)) + (SPADLET |a2| (|IFcodeTran| |a2| |m| |m1|)) + (CONS 'COND + (CONS (CONS |p1| (CONS |a1| NIL)) + (CONS (CONS ''T (CONS |a2| NIL)) NIL)))))))) + +;interpIF(op,cond,a,b) == +; -- non-compiled version of IF type analyzer. Doesn't resolve accross +; -- branches of the IF. +; val:= getValue cond +; val:= coerceInteractive(val,$Boolean) => +; objValUnwrap(val) => upIFgenValue(op,a) +; EQ(b,'noBranch) => +; putValue(op,objNew(voidValue(), $Void)) +; putModeSet(op,[$Void]) +; upIFgenValue(op,b) +; throwKeyedMsg("S2IS0031",NIL) + +(DEFUN |interpIF| (|op| |cond| |a| |b|) + (PROG (|val|) + (RETURN + (PROGN + (SPADLET |val| (|getValue| |cond|)) + (COND + ((SPADLET |val| (|coerceInteractive| |val| |$Boolean|)) + (COND + ((|objValUnwrap| |val|) (|upIFgenValue| |op| |a|)) + ((EQ |b| '|noBranch|) + (|putValue| |op| (|objNew| (|voidValue|) |$Void|)) + (|putModeSet| |op| (CONS |$Void| NIL))) + ('T (|upIFgenValue| |op| |b|)))) + ('T (|throwKeyedMsg| 'S2IS0031 NIL))))))) + +;upIFgenValue(op,tree) == +; -- evaluates tree and transfers the results to op +; ms:=bottomUp tree +; val:= getValue tree +; putValue(op,val) +; putModeSet(op,ms) + +(DEFUN |upIFgenValue| (|op| |tree|) + (PROG (|ms| |val|) + (RETURN + (PROGN + (SPADLET |ms| (|bottomUp| |tree|)) + (SPADLET |val| (|getValue| |tree|)) + (|putValue| |op| |val|) + (|putModeSet| |op| |ms|))))) + +;--% Handlers for is +;upis t == +; t isnt [op,a,pattern] => nil +; $opIsIs : local := true +; upisAndIsnt t + +(DEFUN |upis| (|t|) + (PROG (|$opIsIs| |op| |ISTMP#1| |a| |ISTMP#2| |pattern|) + (DECLARE (SPECIAL |$opIsIs|)) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (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 |pattern| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (SPADLET |$opIsIs| 'T) (|upisAndIsnt| |t|)))))) + +;upisnt t == +; t isnt [op,a,pattern] => nil +; $opIsIs : local := nil +; upisAndIsnt t + +(DEFUN |upisnt| (|t|) + (PROG (|$opIsIs| |op| |ISTMP#1| |a| |ISTMP#2| |pattern|) + (DECLARE (SPECIAL |$opIsIs|)) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (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 |pattern| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (SPADLET |$opIsIs| NIL) (|upisAndIsnt| |t|)))))) + +;upisAndIsnt(t:=[op,a,pattern]) == +; -- handler for "is" pattern matching +; mS:= bottomUp a +; mS isnt [m] => +; keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"]) +; putPvarModes(removeConstruct pattern,m) +; evalis(op,rest t,m) +; putModeSet(op,[$Boolean]) + +(DEFUN |upisAndIsnt| (|t|) + (PROG (|op| |a| |pattern| |mS| |m|) + (RETURN + (PROGN + (SPADLET |op| (CAR |t|)) + (SPADLET |a| (CADR |t|)) + (SPADLET |pattern| (CADDR |t|)) + (SPADLET |mS| (|bottomUp| |a|)) + (COND + ((NULL (AND (PAIRP |mS|) (EQ (QCDR |mS|) NIL) + (PROGN (SPADLET |m| (QCAR |mS|)) 'T))) + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "upisAndIsnt") + (CONS (MAKESTRING "non-unique modeset") NIL)))) + ('T (|putPvarModes| (|removeConstruct| |pattern|) |m|) + (|evalis| |op| (CDR |t|) |m|) + (|putModeSet| |op| (CONS |$Boolean| NIL)))))))) + +;putPvarModes(pattern,m) == +; -- Puts the modes for the pattern variables into $env +; m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL) +; for pvar in pattern repeat +; IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env) +; pvar is ['_:,var] => +; null (var=$quadSymbol) and put(var,'mode,m,$env) +; pvar is ['_=,var] => +; null (var=$quadSymbol) and put(var,'mode,um,$env) +; putPvarModes(pvar,um) + +(DEFUN |putPvarModes| (|pattern| |m|) + (PROG (|um| |ISTMP#1| |var|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |m|) (EQ (QCAR |m|) '|List|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |m|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |um| (QCAR |ISTMP#1|)) + 'T))))) + (|throwKeyedMsg| 'S2IS0030 NIL)) + ('T + (DO ((G166683 |pattern| (CDR G166683)) (|pvar| NIL)) + ((OR (ATOM G166683) + (PROGN (SETQ |pvar| (CAR G166683)) NIL)) + NIL) + (SEQ (EXIT (COND + ((IDENTP |pvar|) + (AND (NULL + (BOOT-EQUAL |pvar| |$quadSymbol|)) + (|put| |pvar| '|mode| |um| |$env|))) + ((AND (PAIRP |pvar|) + (EQ (QCAR |pvar|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pvar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| + (QCAR |ISTMP#1|)) + 'T)))) + (AND (NULL + (BOOT-EQUAL |var| |$quadSymbol|)) + (|put| |var| '|mode| |m| |$env|))) + ((AND (PAIRP |pvar|) (EQ (QCAR |pvar|) '=) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pvar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| + (QCAR |ISTMP#1|)) + 'T)))) + (AND (NULL + (BOOT-EQUAL |var| |$quadSymbol|)) + (|put| |var| '|mode| |um| |$env|))) + ('T (|putPvarModes| |pvar| |um|)))))))))))) + +;evalis(op,[a,pattern],mode) == +; -- actually handles is and isnt +; if $opIsIs +; then fun := 'evalIsPredicate +; else fun := 'evalIsntPredicate +; if isLocalPred pattern then +; code:= compileIs(a,pattern) +; else code:=[fun,getArgValue(a,mode), +; MKQ pattern,MKQ mode] +; triple:= +; $genValue => objNewWrap(timedEVALFUN code,$Boolean) +; objNew(code,$Boolean) +; putValue(op,triple) + +(DEFUN |evalis| (|op| G166700 |mode|) + (PROG (|a| |pattern| |fun| |code| |triple|) + (RETURN + (PROGN + (SPADLET |a| (CAR G166700)) + (SPADLET |pattern| (CADR G166700)) + (COND + (|$opIsIs| (SPADLET |fun| '|evalIsPredicate|)) + ('T (SPADLET |fun| '|evalIsntPredicate|))) + (COND + ((|isLocalPred| |pattern|) + (SPADLET |code| (|compileIs| |a| |pattern|))) + ('T + (SPADLET |code| + (CONS |fun| + (CONS (|getArgValue| |a| |mode|) + (CONS (MKQ |pattern|) + (CONS (MKQ |mode|) NIL))))))) + (SPADLET |triple| + (COND + (|$genValue| + (|objNewWrap| (|timedEVALFUN| |code|) + |$Boolean|)) + ('T (|objNew| |code| |$Boolean|)))) + (|putValue| |op| |triple|))))) + +;isLocalPred pattern == +; -- returns true if the is predicate is to be compiled +; for pat in pattern repeat +; IDENTP pat and isLocalVar(pat) => return true +; pat is ['_:,var] and isLocalVar(var) => return true +; pat is ['_=,var] and isLocalVar(var) => return true + +(DEFUN |isLocalPred| (|pattern|) + (PROG (|ISTMP#1| |var|) + (RETURN + (SEQ (DO ((G166739 |pattern| (CDR G166739)) (|pat| NIL)) + ((OR (ATOM G166739) + (PROGN (SETQ |pat| (CAR G166739)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (IDENTP |pat|) (|isLocalVar| |pat|)) + (RETURN 'T)) + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| + (QCAR |ISTMP#1|)) + 'T))) + (|isLocalVar| |var|)) + (RETURN 'T)) + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '=) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| + (QCAR |ISTMP#1|)) + 'T))) + (|isLocalVar| |var|)) + (RETURN 'T)))))))))) + +;compileIs(val,pattern) == +; -- produce code for compiled "is" predicate. makes pattern variables +; -- into local variables of the function +; vars:= NIL +; for pat in CDR pattern repeat +; IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars] +; pat is ['_:,var] => vars:= [var,:vars] +; pat is ['_=,var] => vars:= [var,:vars] +; predCode:=['LET,g:=GENSYM(),['isPatternMatch, +; getArgValue(val,computedMode val),MKQ removeConstruct pattern]] +; for var in REMDUP vars repeat +; assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode] +; null $opIsIs => +; ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]] +; ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]] + +(DEFUN |compileIs| (|val| |pattern|) + (PROG (|ISTMP#1| |var| |vars| |g| |predCode| |assignCode|) + (RETURN + (SEQ (PROGN + (SPADLET |vars| NIL) + (DO ((G166773 (CDR |pattern|) (CDR G166773)) + (|pat| NIL)) + ((OR (ATOM G166773) + (PROGN (SETQ |pat| (CAR G166773)) NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (IDENTP |pat|) (|isLocalVar| |pat|)) + (SPADLET |vars| (CONS |pat| |vars|))) + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |vars| (CONS |var| |vars|))) + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '=) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |vars| (CONS |var| |vars|))))))) + (SPADLET |predCode| + (CONS 'LET + (CONS (SPADLET |g| (GENSYM)) + (CONS (CONS '|isPatternMatch| + (CONS + (|getArgValue| |val| + (|computedMode| |val|)) + (CONS + (MKQ + (|removeConstruct| + |pattern|)) + NIL))) + NIL)))) + (DO ((G166782 (REMDUP |vars|) (CDR G166782)) + (|var| NIL)) + ((OR (ATOM G166782) + (PROGN (SETQ |var| (CAR G166782)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |assignCode| + (CONS + (CONS 'LET + (CONS |var| + (CONS + (CONS 'CDR + (CONS + (CONS 'ASSQ + (CONS (MKQ |var|) + (CONS |g| NIL))) + NIL)) + NIL))) + |assignCode|))))) + (COND + ((NULL |$opIsIs|) + (CONS 'COND + (CONS (CONS (CONS 'EQ + (CONS |predCode| + (CONS (MKQ '|failed|) NIL))) + (CONS (CONS 'SEQ + (APPEND |assignCode| + (CONS (MKQ 'T) NIL))) + NIL)) + NIL))) + ('T + (CONS 'COND + (CONS (CONS (CONS 'NOT + (CONS + (CONS 'EQ + (CONS |predCode| + (CONS (MKQ '|failed|) NIL))) + NIL)) + (CONS (CONS 'SEQ + (APPEND |assignCode| + (CONS (MKQ 'T) NIL))) + NIL)) + NIL))))))))) + +;evalIsPredicate(value,pattern,mode) == +; --This function pattern matches value to pattern, and returns +; --true if it matches, and false otherwise. As a side effect +; --if the pattern matches then the bindings given in the pattern +; --are made +; pattern:= removeConstruct pattern +; ^((valueAlist:=isPatternMatch(value,pattern))='failed) => +; for [id,:value] in valueAlist repeat +; evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env))) +; true +; false + +(DEFUN |evalIsPredicate| (|value| |pattern| |mode|) + (PROG (|valueAlist| |id|) + (RETURN + (SEQ (PROGN + (SPADLET |pattern| (|removeConstruct| |pattern|)) + (COND + ((NULL (BOOT-EQUAL + (SPADLET |valueAlist| + (|isPatternMatch| |value| |pattern|)) + '|failed|)) + (DO ((G166812 |valueAlist| (CDR G166812)) + (G166802 NIL)) + ((OR (ATOM G166812) + (PROGN (SETQ G166802 (CAR G166812)) NIL) + (PROGN + (PROGN + (SPADLET |id| (CAR G166802)) + (SPADLET |value| (CDR G166802)) + G166802) + NIL)) + NIL) + (SEQ (EXIT (|evalLETchangeValue| |id| + (|objNewWrap| |value| + (|get| |id| '|mode| |$env|)))))) + 'T) + ('T NIL))))))) + +;evalIsntPredicate(value,pattern,mode) == +; evalIsPredicate(value,pattern,mode) => NIL +; 'TRUE + +(DEFUN |evalIsntPredicate| (|value| |pattern| |mode|) + (COND ((|evalIsPredicate| |value| |pattern| |mode|) NIL) ('T 'TRUE))) + +;removeConstruct pat == +; -- removes the "construct" from the beginning of patterns +; if pat is ['construct,:p] then pat:=p +; if pat is ['cons, a, b] then pat := [a, ['_:, b]] +; atom pat => pat +; RPLACA(pat,removeConstruct CAR pat) +; RPLACD(pat,removeConstruct CDR pat) +; pat + +(DEFUN |removeConstruct| (|pat|) + (PROG (|p| |ISTMP#1| |a| |ISTMP#2| |b|) + (RETURN + (PROGN + (COND + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '|construct|) + (PROGN (SPADLET |p| (QCDR |pat|)) 'T)) + (SPADLET |pat| |p|))) + (COND + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '|cons|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (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|)) + 'T)))))) + (SPADLET |pat| + (CONS |a| (CONS (CONS '|:| (CONS |b| NIL)) NIL))))) + (COND + ((ATOM |pat|) |pat|) + ('T (RPLACA |pat| (|removeConstruct| (CAR |pat|))) + (RPLACD |pat| (|removeConstruct| (CDR |pat|))) |pat|)))))) + +;isPatternMatch(l,pats) == +; -- perform the actual pattern match +; $subs: local := NIL +; isPatMatch(l,pats) +; $subs + +(DEFUN |isPatternMatch| (|l| |pats|) + (PROG (|$subs|) + (DECLARE (SPECIAL |$subs|)) + (RETURN + (PROGN (SPADLET |$subs| NIL) (|isPatMatch| |l| |pats|) |$subs|)))) + +;isPatMatch(l,pats) == +; null pats => +; null l => $subs +; $subs:='failed +; null l => +; null pats => $subs +; pats is [['_:,var]] => +; $subs := [[var],:$subs] +; $subs:='failed +; pats is [pat,:restPats] => +; IDENTP pat => +; $subs:=[[pat,:first l],:$subs] +; isPatMatch(rest l,restPats) +; pat is ['_=,var] => +; p:=ASSQ(var,$subs) => +; CAR l = CDR p => isPatMatch(rest l, restPats) +; $subs:='failed +; $subs:='failed +; pat is ['_:,var] => +; n:=#restPats +; m:=#l-n +; m<0 => $subs:='failed +; ZEROP n => $subs:=[[var,:l],:$subs] +; $subs:=[[var,:[x for x in l for i in 1..m]],:$subs] +; isPatMatch(DROP(m,l),restPats) +; isPatMatch(first l,pat) = 'failed => 'failed +; isPatMatch(rest l,restPats) +; keyedSystemError("S2GE0016",['"isPatMatch", +; '"unknown form of is predicate"]) + +(DEFUN |isPatMatch| (|l| |pats|) + (PROG (|ISTMP#2| |pat| |restPats| |p| |ISTMP#1| |var| |n| |m|) + (RETURN + (SEQ (COND + ((NULL |pats|) + (COND + ((NULL |l|) |$subs|) + ('T (SPADLET |$subs| '|failed|)))) + ((NULL |l|) + (COND + ((NULL |pats|) |$subs|) + ((AND (PAIRP |pats|) (EQ (QCDR |pats|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |pats|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|:|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |$subs| (CONS (CONS |var| NIL) |$subs|))) + ('T (SPADLET |$subs| '|failed|)))) + ((AND (PAIRP |pats|) + (PROGN + (SPADLET |pat| (QCAR |pats|)) + (SPADLET |restPats| (QCDR |pats|)) + 'T)) + (COND + ((IDENTP |pat|) + (SPADLET |$subs| + (CONS (CONS |pat| (CAR |l|)) |$subs|)) + (|isPatMatch| (CDR |l|) |restPats|)) + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '=) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (COND + ((SPADLET |p| (ASSQ |var| |$subs|)) + (COND + ((BOOT-EQUAL (CAR |l|) (CDR |p|)) + (|isPatMatch| (CDR |l|) |restPats|)) + ('T (SPADLET |$subs| '|failed|)))) + ('T (SPADLET |$subs| '|failed|)))) + ((AND (PAIRP |pat|) (EQ (QCAR |pat|) '|:|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pat|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |n| (|#| |restPats|)) + (SPADLET |m| (SPADDIFFERENCE (|#| |l|) |n|)) + (COND + ((MINUSP |m|) (SPADLET |$subs| '|failed|)) + ((ZEROP |n|) + (SPADLET |$subs| (CONS (CONS |var| |l|) |$subs|))) + ('T + (SPADLET |$subs| + (CONS (CONS |var| + (PROG (G166898) + (SPADLET G166898 NIL) + (RETURN + (DO + ((G166904 |l| + (CDR G166904)) + (|x| NIL) + (|i| 1 (QSADD1 |i|))) + ((OR (ATOM G166904) + (PROGN + (SETQ |x| (CAR G166904)) + NIL) + (QSGREATERP |i| |m|)) + (NREVERSE0 G166898)) + (SEQ + (EXIT + (SETQ G166898 + (CONS |x| G166898)))))))) + |$subs|)) + (|isPatMatch| (DROP |m| |l|) |restPats|)))) + ((BOOT-EQUAL (|isPatMatch| (CAR |l|) |pat|) '|failed|) + '|failed|) + ('T (|isPatMatch| (CDR |l|) |restPats|)))) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "isPatMatch") + (CONS (MAKESTRING + "unknown form of is predicate") + NIL))))))))) + +;--% Handler for iterate +;upiterate t == +; null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"]) +; $iterateCount := $iterateCount + 1 +; code := ['THROW,$repeatBodyLabel,'(voidValue)] +; $genValue => THROW(eval $repeatBodyLabel,voidValue()) +; putValue(t,objNew(code,$Void)) +; putModeSet(t,[$Void]) + +(DEFUN |upiterate| (|t|) + (PROG (|code|) + (RETURN + (COND + ((NULL |$repeatBodyLabel|) + (|throwKeyedMsg| 'S2IS0029 (CONS (MAKESTRING "iterate") NIL))) + ('T (SPADLET |$iterateCount| (PLUS |$iterateCount| 1)) + (SPADLET |code| + (CONS 'THROW + (CONS |$repeatBodyLabel| + (CONS '(|voidValue|) NIL)))) + (COND + (|$genValue| + (THROW (|eval| |$repeatBodyLabel|) (|voidValue|))) + ('T (|putValue| |t| (|objNew| |code| |$Void|)) + (|putModeSet| |t| (CONS |$Void| NIL))))))))) + +;--% Handler for break +;upbreak t == +; t isnt [op,.] => nil +; null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"]) +; $breakCount := $breakCount + 1 +; code := ['THROW,$repeatLabel,'(voidValue)] +; $genValue => THROW(eval $repeatLabel,voidValue()) +; putValue(op,objNew(code,$Void)) +; putModeSet(op,[$Void]) + +(DEFUN |upbreak| (|t|) + (PROG (|op| |ISTMP#1| |code|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))))) + NIL) + ((NULL |$repeatLabel|) + (|throwKeyedMsg| 'S2IS0029 (CONS (MAKESTRING "break") NIL))) + ('T (SPADLET |$breakCount| (PLUS |$breakCount| 1)) + (SPADLET |code| + (CONS 'THROW + (CONS |$repeatLabel| (CONS '(|voidValue|) NIL)))) + (COND + (|$genValue| (THROW (|eval| |$repeatLabel|) (|voidValue|))) + ('T (|putValue| |op| (|objNew| |code| |$Void|)) + (|putModeSet| |op| (CONS |$Void| NIL))))))))) + +;--% Handlers for LET +;upLET t == +; -- analyzes and evaluates the righthand side, and does the variable +; -- binding +; t isnt [op,lhs,rhs] => nil +; $declaredMode: local := NIL +; PAIRP lhs => +; var:= getUnname first lhs +; var = 'construct => upLETWithPatternOnLhs t +; var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"]) +; upLETWithFormOnLhs(op,lhs,rhs) +; var:= getUnname lhs +; var = $immediateDataSymbol => +; -- following will be immediate data, so probably ok to not +; -- specially format it +; obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm) +; throwKeyedMsg("S2IS0027",[obj]) +; var in '(% %%) => -- for history +; throwKeyedMsg("S2IS0027",[var]) +; (IDENTP var) and not (var in '(true false elt QUOTE)) => +; var ^= (var' := unabbrev(var)) => -- constructor abbreviation +; throwKeyedMsg("S2IS0028",[var,var']) +; if get(var,'isInterpreterFunction,$e) then +; putHist(var,'isInterpreterFunction,false,$e) +; sayKeyedMsg("S2IS0049",['"Function",var]) +; else if get(var,'isInterpreterRule,$e) then +; putHist(var,'isInterpreterRule,false,$e) +; sayKeyedMsg("S2IS0049",['"Rule",var]) +; not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m) +; transferPropsToNode(var,lhs) +; if ( m:= getMode(lhs) ) then +; $declaredMode := m +; putTarget(rhs,m) +; if (val := getValue lhs) and (objMode val = $Boolean) and +; getUnname(rhs) = 'equation then putTarget(rhs,$Boolean) +; (rhsMs:= bottomUp rhs) = [$Void] => +; throwKeyedMsg("S2IS0034",[var]) +; val:=evalLET(lhs,rhs) +; putValue(op,val) +; putModeSet(op,[objMode(val)]) +; throwKeyedMsg("S2IS0027",[var]) + +(DEFUN |upLET| (|t|) + (PROG (|$declaredMode| |op| |ISTMP#1| |lhs| |ISTMP#2| |rhs| |var| + |obj| |var'| |m| |rhsMs| |val|) + (DECLARE (SPECIAL |$declaredMode|)) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |lhs| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |rhs| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (SPADLET |$declaredMode| NIL) + (COND + ((PAIRP |lhs|) (SPADLET |var| (|getUnname| (CAR |lhs|))) + (COND + ((BOOT-EQUAL |var| '|construct|) + (|upLETWithPatternOnLhs| |t|)) + ((BOOT-EQUAL |var| 'QUOTE) + (|throwKeyedMsg| 'S2IS0027 + (CONS (MAKESTRING "A quoted form") NIL))) + ('T (|upLETWithFormOnLhs| |op| |lhs| |rhs|)))) + ('T (SPADLET |var| (|getUnname| |lhs|)) + (COND + ((BOOT-EQUAL |var| |$immediateDataSymbol|) + (SPADLET |obj| + (|objValUnwrap| + (|coerceInteractive| (|getValue| |lhs|) + |$OutputForm|))) + (|throwKeyedMsg| 'S2IS0027 (CONS |obj| NIL))) + ((|member| |var| '(% %%)) + (|throwKeyedMsg| 'S2IS0027 (CONS |var| NIL))) + ((AND (IDENTP |var|) + (NULL (|member| |var| + '(|true| |false| |elt| QUOTE)))) + (COND + ((NEQUAL |var| (SPADLET |var'| (|unabbrev| |var|))) + (|throwKeyedMsg| 'S2IS0028 + (CONS |var| (CONS |var'| NIL)))) + ('T + (COND + ((|get| |var| '|isInterpreterFunction| |$e|) + (|putHist| |var| '|isInterpreterFunction| NIL + |$e|) + (|sayKeyedMsg| 'S2IS0049 + (CONS (MAKESTRING "Function") + (CONS |var| NIL)))) + ((|get| |var| '|isInterpreterRule| |$e|) + (|putHist| |var| '|isInterpreterRule| NIL |$e|) + (|sayKeyedMsg| 'S2IS0049 + (CONS (MAKESTRING "Rule") (CONS |var| NIL)))) + ('T NIL)) + (COND + ((AND (NULL (|isTupleForm| |rhs|)) + (SPADLET |m| (|isType| |rhs|))) + (|upLETtype| |op| |lhs| |m|)) + ('T (|transferPropsToNode| |var| |lhs|) + (COND + ((SPADLET |m| (|getMode| |lhs|)) + (SPADLET |$declaredMode| |m|) + (|putTarget| |rhs| |m|))) + (COND + ((AND (SPADLET |val| (|getValue| |lhs|)) + (BOOT-EQUAL (|objMode| |val|) |$Boolean|) + (BOOT-EQUAL (|getUnname| |rhs|) + '|equation|)) + (|putTarget| |rhs| |$Boolean|))) + (COND + ((BOOT-EQUAL + (SPADLET |rhsMs| (|bottomUp| |rhs|)) + (CONS |$Void| NIL)) + (|throwKeyedMsg| 'S2IS0034 (CONS |var| NIL))) + ('T (SPADLET |val| (|evalLET| |lhs| |rhs|)) + (|putValue| |op| |val|) + (|putModeSet| |op| + (CONS (|objMode| |val|) NIL))))))))) + ('T (|throwKeyedMsg| 'S2IS0027 (CONS |var| NIL))))))))))) + +;isTupleForm f == +; -- have to do following since "Tuple" is an internal form name +; getUnname f ^= "Tuple" => false +; f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" => +; #args ^= 1 => true +; isTupleForm first args => true +; isType first args => false +; true +; false + +(DEFUN |isTupleForm| (|f|) + (PROG (|op| |args|) + (RETURN + (COND + ((NEQUAL (|getUnname| |f|) '|Tuple|) NIL) + ((AND (PAIRP |f|) + (PROGN + (SPADLET |op| (QCAR |f|)) + (SPADLET |args| (QCDR |f|)) + 'T) + (VECP |op|) (BOOT-EQUAL (|getUnname| |op|) '|Tuple|)) + (COND + ((NEQUAL (|#| |args|) 1) 'T) + ((|isTupleForm| (CAR |args|)) 'T) + ((|isType| (CAR |args|)) NIL) + ('T 'T))) + ('T NIL))))) + +;evalLET(lhs,rhs) == +; -- lhs is a vector for a variable, and rhs is the evaluated atree +; -- for the value which is coerced to the mode of lhs +; $useConvertForCoercions: local := true +; v' := (v:= getValue rhs) +; ((not getMode lhs) and (getModeSet rhs is [.])) or +; get(getUnname lhs,'autoDeclare,$env) => +; v:= +; $genValue => v +; objNew(wrapped2Quote objVal v,objMode v) +; evalLETput(lhs,v) +; t1:= objMode v +; t2' := (t2 := getMode lhs) +; value:= +; t1 = t2 => +; $genValue => v +; objNew(wrapped2Quote objVal v,objMode v) +; if isPartialMode t2 then +; if EQCAR(t1,'Symbol) and $declaredMode then +; t1:= getMinimalVarMode(objValUnwrap v,$declaredMode) +; t' := t2 +; null (t2 := resolveTM(t1,t2)) => +; if not t2 then t2 := t' +; throwKeyedMsg("S2IS0035",[t1,t2]) +; null (v := getArgValue(rhs,t2)) => +; isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) => +; throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2]) +; throwKeyedMsg("S2IS0037",[t2]) +; t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2) +; value => evalLETput(lhs,value) +; throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs) + +(DEFUN |evalLET| (|lhs| |rhs|) + (PROG (|$useConvertForCoercions| |v'| |ISTMP#1| |t2'| |t1| |t'| |t2| + |v| |v2| |value|) + (DECLARE (SPECIAL |$useConvertForCoercions|)) + (RETURN + (PROGN + (SPADLET |$useConvertForCoercions| 'T) + (SPADLET |v'| (SPADLET |v| (|getValue| |rhs|))) + (COND + ((OR (AND (NULL (|getMode| |lhs|)) + (PROGN + (SPADLET |ISTMP#1| (|getModeSet| |rhs|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) + (|get| (|getUnname| |lhs|) '|autoDeclare| |$env|)) + (SPADLET |v| + (COND + (|$genValue| |v|) + ('T + (|objNew| (|wrapped2Quote| (|objVal| |v|)) + (|objMode| |v|))))) + (|evalLETput| |lhs| |v|)) + ('T (SPADLET |t1| (|objMode| |v|)) + (SPADLET |t2'| (SPADLET |t2| (|getMode| |lhs|))) + (SPADLET |value| + (COND + ((BOOT-EQUAL |t1| |t2|) + (COND + (|$genValue| |v|) + ('T + (|objNew| (|wrapped2Quote| (|objVal| |v|)) + (|objMode| |v|))))) + ('T + (COND + ((|isPartialMode| |t2|) + (COND + ((AND (EQCAR |t1| '|Symbol|) + |$declaredMode|) + (SPADLET |t1| + (|getMinimalVarMode| + (|objValUnwrap| |v|) + |$declaredMode|)))) + (SPADLET |t'| |t2|) + (COND + ((NULL (SPADLET |t2| + (|resolveTM| |t1| |t2|))) + (PROGN + (COND + ((NULL |t2|) (SPADLET |t2| |t'|))) + (|throwKeyedMsg| 'S2IS0035 + (CONS |t1| (CONS |t2| NIL)))))))) + (COND + ((NULL (SPADLET |v| + (|getArgValue| |rhs| |t2|))) + (COND + ((AND (|isWrapped| (|objVal| |v'|)) + (SPADLET |v2| + (|coerceInteractive| |v'| + |$OutputForm|))) + (|throwKeyedMsg| 'S2IS0036 + (CONS (|objValUnwrap| |v2|) + (CONS |t2| NIL)))) + ('T + (|throwKeyedMsg| 'S2IS0037 + (CONS |t2| NIL))))) + ('T + (AND |t2| + (|objNew| + (COND + (|$genValue| + (|wrap| (|timedEVALFUN| |v|))) + ('T |v|)) + |t2|))))))) + (COND + (|value| (|evalLETput| |lhs| |value|)) + ('T + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |v|) |t1| + (|getMode| |lhs|)))))))))) + +;evalLETput(lhs,value) == +; -- put value into the cell for lhs +; name:= getUnname lhs +; if not $genValue then +; code:= +; isLocalVar(name) => +; om := objMode(value) +; dm := get(name,'mode,$env) +; dm and not ((om = dm) or isSubDomain(om,dm) or +; isSubDomain(dm,om)) => +; compFailure ['" The type of the local variable", +; :bright name,'"has changed in the computation."] +; if dm and isSubDomain(dm,om) then put(name,'mode,om,$env) +; ['LET,name,objVal value,$mapName] +; -- $mapName is set in analyzeMap +; om := objMode value +; dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e)) +; dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) => +; THROW('loopCompiler,'tryInterpOnly) +; ['unwrap,['evalLETchangeValue,MKQ name, +; objNewCode(['wrap,objVal value],objMode value)]] +; value:= objNew(code,objMode value) +; isLocalVar(name) => +; if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env) +; put(name,'mode,objMode(value),$env) +; put(name,'automode,objMode(value),$env) +; $genValue and evalLETchangeValue(name,value) +; putValue(lhs,value) + +(DEFUN |evalLETput| (|lhs| |value|) + (PROG (|name| |om| |dm| |code|) + (RETURN + (PROGN + (SPADLET |name| (|getUnname| |lhs|)) + (COND + ((NULL |$genValue|) + (SPADLET |code| + (COND + ((|isLocalVar| |name|) + (SPADLET |om| (|objMode| |value|)) + (SPADLET |dm| (|get| |name| '|mode| |$env|)) + (COND + ((AND |dm| + (NULL (OR (BOOT-EQUAL |om| |dm|) + (|isSubDomain| |om| |dm|) + (|isSubDomain| |dm| |om|)))) + (|compFailure| + (CONS (MAKESTRING + " The type of the local variable") + (APPEND (|bright| |name|) + (CONS + (MAKESTRING + "has changed in the computation.") + NIL))))) + ('T + (COND + ((AND |dm| (|isSubDomain| |dm| |om|)) + (|put| |name| '|mode| |om| |$env|))) + (CONS 'LET + (CONS |name| + (CONS (|objVal| |value|) + (CONS |$mapName| NIL))))))) + ('T (SPADLET |om| (|objMode| |value|)) + (SPADLET |dm| + (OR (|get| |name| '|mode| |$env|) + (|objMode| + (|get| |name| '|value| |$e|)))) + (COND + ((AND |dm| (NULL |$compilingMap|) + (NULL (BOOT-EQUAL |om| |dm|)) + (NULL (|isSubDomain| |om| |dm|))) + (THROW '|loopCompiler| '|tryInterpOnly|)) + ('T + (CONS '|unwrap| + (CONS (CONS '|evalLETchangeValue| + (CONS (MKQ |name|) + (CONS + (|objNewCode| + (CONS '|wrap| + (CONS (|objVal| |value|) + NIL)) + (|objMode| |value|)) + NIL))) + NIL))))))) + (SPADLET |value| (|objNew| |code| (|objMode| |value|))) + (COND + ((|isLocalVar| |name|) + (COND + ((NULL (|get| |name| '|mode| |$env|)) + (|put| |name| '|autoDeclare| 'T |$env|))) + (|put| |name| '|mode| (|objMode| |value|) |$env|)) + ('T (|put| |name| '|automode| (|objMode| |value|) |$env|))))) + (AND |$genValue| (|evalLETchangeValue| |name| |value|)) + (|putValue| |lhs| |value|))))) + +;upLETWithPatternOnLhs(t := [op,pattern,a]) == +; $opIsIs : local := true +; [m] := bottomUp a +; putPvarModes(pattern,m) +; object := evalis(op,[a,pattern],m) +; -- have to change code to return value of a +; failCode := +; ['spadThrowBrightly,['concat, +; '" Pattern",['QUOTE,bright form2String pattern], +; '"is not matched in assignment to right-hand side."]] +; if $genValue +; then +; null objValUnwrap object => eval failCode +; putValue(op,getValue a) +; else +; code := ['COND,[objVal object,objVal getValue a],[''T,failCode]] +; putValue(op,objNew(code,m)) +; putModeSet(op,[m]) + +(DEFUN |upLETWithPatternOnLhs| (|t|) + (PROG (|$opIsIs| |op| |pattern| |a| |LETTMP#1| |m| |object| + |failCode| |code|) + (DECLARE (SPECIAL |$opIsIs|)) + (RETURN + (PROGN + (SPADLET |op| (CAR |t|)) + (SPADLET |pattern| (CADR |t|)) + (SPADLET |a| (CADDR |t|)) + (SPADLET |$opIsIs| 'T) + (SPADLET |LETTMP#1| (|bottomUp| |a|)) + (SPADLET |m| (CAR |LETTMP#1|)) + (|putPvarModes| |pattern| |m|) + (SPADLET |object| + (|evalis| |op| (CONS |a| (CONS |pattern| NIL)) |m|)) + (SPADLET |failCode| + (CONS '|spadThrowBrightly| + (CONS (CONS '|concat| + (CONS (MAKESTRING " Pattern") + (CONS + (CONS 'QUOTE + (CONS + (|bright| + (|form2String| |pattern|)) + NIL)) + (CONS + (MAKESTRING + "is not matched in assignment to right-hand side.") + NIL)))) + NIL))) + (COND + (|$genValue| + (COND + ((NULL (|objValUnwrap| |object|)) (|eval| |failCode|)) + ('T (|putValue| |op| (|getValue| |a|))))) + ('T + (SPADLET |code| + (CONS 'COND + (CONS (CONS (|objVal| |object|) + (CONS (|objVal| (|getValue| |a|)) + NIL)) + (CONS (CONS ''T (CONS |failCode| NIL)) + NIL)))) + (|putValue| |op| (|objNew| |code| |m|)))) + (|putModeSet| |op| (CONS |m| NIL)))))) + +;evalLETchangeValue(name,value) == +; -- write the value of name into the environment, clearing dependent +; -- maps if its type changes from its last value +; localEnv := PAIRP $env +; clearCompilationsFlag := +; val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e) +; null val => +; not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e)) +; objMode val ^= objMode(value) +; if clearCompilationsFlag then +; clearDependencies(name,true) +; if localEnv and isLocalVar(name) +; then $env:= putHist(name,'value,value,$env) +; else putIntSymTab(name,'value,value,$e) +; objVal value + +(DEFUN |evalLETchangeValue| (|name| |value|) + (PROG (|localEnv| |val| |clearCompilationsFlag|) + (RETURN + (PROGN + (SPADLET |localEnv| (PAIRP |$env|)) + (SPADLET |clearCompilationsFlag| + (PROGN + (SPADLET |val| + (OR (AND |localEnv| + (|get| |name| '|value| |$env|)) + (|get| |name| '|value| |$e|))) + (COND + ((NULL |val|) + (NULL (OR (AND |localEnv| + (|get| |name| '|mode| |$env|)) + (|get| |name| '|mode| |$e|)))) + ('T + (NEQUAL (|objMode| |val|) (|objMode| |value|)))))) + (COND + (|clearCompilationsFlag| (|clearDependencies| |name| 'T))) + (COND + ((AND |localEnv| (|isLocalVar| |name|)) + (SPADLET |$env| (|putHist| |name| '|value| |value| |$env|))) + ('T (|putIntSymTab| |name| '|value| |value| |$e|))) + (|objVal| |value|))))) + +;upLETWithFormOnLhs(op,lhs,rhs) == +; -- bottomUp for assignment to forms (setelt, table or tuple) +; lhs' := getUnnameIfCan lhs +; rhs' := getUnnameIfCan rhs +; lhs' = 'Tuple => +; rhs' ^= 'Tuple => throwKeyedMsg("S2IS0039",NIL) +; #(lhs) ^= #(rhs) => throwKeyedMsg("S2IS0038",NIL) +; -- generate a sequence of assignments, using local variables +; -- to first hold the assignments so that things like +; -- (t1,t2) := (t2,t1) will work. +; seq := [] +; temps := [GENSYM() for l in rest lhs] +; for lvar in temps repeat mkLocalVar($mapName,lvar) +; for l in reverse rest lhs for t in temps repeat +; transferPropsToNode(getUnname l,l) +; let := mkAtreeNode 'LET +; t' := mkAtreeNode t +; if m := getMode(l) then putMode(t',m) +; seq := cons([let,l,t'],seq) +; for t in temps for r in reverse rest rhs +; for l in reverse rest lhs repeat +; let := mkAtreeNode 'LET +; t' := mkAtreeNode t +; if m := getMode(l) then putMode(t',m) +; seq := cons([let,t',r],seq) +; seq := cons(mkAtreeNode 'SEQ,seq) +; ms := bottomUp seq +; putValue(op,getValue seq) +; putModeSet(op,ms) +; rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL) +; tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree) +; throwKeyedMsg("S2IS0060", NIL) + +(DEFUN |upLETWithFormOnLhs| (|op| |lhs| |rhs|) + (PROG (|lhs'| |rhs'| |temps| |let| |t'| |m| |seq| |ms| |tree|) + (RETURN + (SEQ (PROGN + (SPADLET |lhs'| (|getUnnameIfCan| |lhs|)) + (SPADLET |rhs'| (|getUnnameIfCan| |rhs|)) + (COND + ((BOOT-EQUAL |lhs'| '|Tuple|) + (COND + ((NEQUAL |rhs'| '|Tuple|) + (|throwKeyedMsg| 'S2IS0039 NIL)) + ((NEQUAL (|#| |lhs|) (|#| |rhs|)) + (|throwKeyedMsg| 'S2IS0038 NIL)) + ('T (SPADLET |seq| NIL) + (SPADLET |temps| + (PROG (G167115) + (SPADLET G167115 NIL) + (RETURN + (DO ((G167120 (CDR |lhs|) + (CDR G167120)) + (|l| NIL)) + ((OR (ATOM G167120) + (PROGN + (SETQ |l| (CAR G167120)) + NIL)) + (NREVERSE0 G167115)) + (SEQ (EXIT + (SETQ G167115 + (CONS (GENSYM) G167115)))))))) + (DO ((G167129 |temps| (CDR G167129)) + (|lvar| NIL)) + ((OR (ATOM G167129) + (PROGN (SETQ |lvar| (CAR G167129)) NIL)) + NIL) + (SEQ (EXIT (|mkLocalVar| |$mapName| |lvar|)))) + (DO ((G167144 (REVERSE (CDR |lhs|)) + (CDR G167144)) + (|l| NIL) (G167145 |temps| (CDR G167145)) + (|t| NIL)) + ((OR (ATOM G167144) + (PROGN (SETQ |l| (CAR G167144)) NIL) + (ATOM G167145) + (PROGN (SETQ |t| (CAR G167145)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|transferPropsToNode| + (|getUnname| |l|) |l|) + (SPADLET |let| (|mkAtreeNode| 'LET)) + (SPADLET |t'| (|mkAtreeNode| |t|)) + (COND + ((SPADLET |m| (|getMode| |l|)) + (|putMode| |t'| |m|))) + (SPADLET |seq| + (CONS + (CONS |let| + (CONS |l| (CONS |t'| NIL))) + |seq|)))))) + (DO ((G167163 |temps| (CDR G167163)) (|t| NIL) + (G167164 (REVERSE (CDR |rhs|)) + (CDR G167164)) + (|r| NIL) + (G167165 (REVERSE (CDR |lhs|)) + (CDR G167165)) + (|l| NIL)) + ((OR (ATOM G167163) + (PROGN (SETQ |t| (CAR G167163)) NIL) + (ATOM G167164) + (PROGN (SETQ |r| (CAR G167164)) NIL) + (ATOM G167165) + (PROGN (SETQ |l| (CAR G167165)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |let| (|mkAtreeNode| 'LET)) + (SPADLET |t'| (|mkAtreeNode| |t|)) + (COND + ((SPADLET |m| (|getMode| |l|)) + (|putMode| |t'| |m|))) + (SPADLET |seq| + (CONS + (CONS |let| + (CONS |t'| (CONS |r| NIL))) + |seq|)))))) + (SPADLET |seq| (CONS (|mkAtreeNode| 'SEQ) |seq|)) + (SPADLET |ms| (|bottomUp| |seq|)) + (|putValue| |op| (|getValue| |seq|)) + (|putModeSet| |op| |ms|)))) + ((BOOT-EQUAL |rhs'| '|Tuple|) + (|throwKeyedMsg| 'S2IS0039 NIL)) + ((SPADLET |tree| (|seteltable| |lhs| |rhs|)) + (|upSetelt| |op| |lhs| |tree|)) + ('T (|throwKeyedMsg| 'S2IS0060 NIL)))))))) + +;-- upTableSetelt(op,lhs,rhs) +;seteltable(lhs is [f,:argl],rhs) == +; -- produces the setelt form for trees such as "l.2:= 3" +; null (g := getUnnameIfCan f) => NIL +; EQ(g,'elt) => altSeteltable [:argl, rhs] +; get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL +; transferPropsToNode(g,f) +; getValue(lhs) or getMode(lhs) => +; f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs] +; altSeteltable [:lhs,rhs] +; NIL + +(DEFUN |seteltable| (|lhs| |rhs|) + (PROG (|f| |argl| |g| |ISTMP#1| |expr| |f'| |argl'|) + (RETURN + (PROGN + (SPADLET |f| (CAR |lhs|)) + (SPADLET |argl| (CDR |lhs|)) + (COND + ((NULL (SPADLET |g| (|getUnnameIfCan| |f|))) NIL) + ((EQ |g| '|elt|) + (|altSeteltable| (APPEND |argl| (CONS |rhs| NIL)))) + ((AND (PROGN + (SPADLET |ISTMP#1| (|get| |g| '|value| |$e|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |expr| (QCAR |ISTMP#1|)) 'T))) + (|isMapExpr| |expr|)) + NIL) + ('T (|transferPropsToNode| |g| |f|) + (COND + ((OR (|getValue| |lhs|) (|getMode| |lhs|)) + (COND + ((AND (PAIRP |f|) + (PROGN + (SPADLET |f'| (QCAR |f|)) + (SPADLET |argl'| (QCDR |f|)) + 'T)) + (|altSeteltable| + (CONS |f'| + (APPEND |argl'| + (APPEND |argl| (CONS |rhs| NIL)))))) + ('T (|altSeteltable| (APPEND |lhs| (CONS |rhs| NIL)))))) + ('T NIL)))))))) + +;altSeteltable args == +; for x in args repeat bottomUp x +; newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"] +; form := NIL +; -- first look for exact matches for any of the possibilities +; while ^form for newOp in newOps repeat +; if selectMms(newOp, args, NIL) then form := [newOp, :args] +; -- now try retracting arguments after the first +; while ^form and ( "and"/[retractAtree(a) for a in rest args] ) repeat +; while ^form for newOp in newOps repeat +; if selectMms(newOp, args, NIL) then form := [newOp, :args] +; form + +(DEFUN |altSeteltable| (|args|) + (PROG (|newOps| |form|) + (RETURN + (SEQ (PROGN + (DO ((G167234 |args| (CDR G167234)) (|x| NIL)) + ((OR (ATOM G167234) + (PROGN (SETQ |x| (CAR G167234)) NIL)) + NIL) + (SEQ (EXIT (|bottomUp| |x|)))) + (SPADLET |newOps| + (CONS (|mkAtreeNode| '|setelt|) + (CONS (|mkAtreeNode| '|set!|) NIL))) + (SPADLET |form| NIL) + (DO ((G167244 |newOps| (CDR G167244)) (|newOp| NIL)) + ((OR (NULL (NULL |form|)) (ATOM G167244) + (PROGN (SETQ |newOp| (CAR G167244)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|selectMms| |newOp| |args| NIL) + (SPADLET |form| (CONS |newOp| |args|))) + ('T NIL))))) + (DO () + ((NULL (AND (NULL |form|) + (PROG (G167257) + (SPADLET G167257 'T) + (RETURN + (DO ((G167263 NIL (NULL G167257)) + (G167264 (CDR |args|) + (CDR G167264)) + (|a| NIL)) + ((OR G167263 (ATOM G167264) + (PROGN + (SETQ |a| (CAR G167264)) + NIL)) + G167257) + (SEQ + (EXIT + (SETQ G167257 + (AND G167257 + (|retractAtree| |a|)))))))))) + NIL) + (SEQ (EXIT (DO ((G167275 |newOps| (CDR G167275)) + (|newOp| NIL)) + ((OR (NULL (NULL |form|)) + (ATOM G167275) + (PROGN + (SETQ |newOp| (CAR G167275)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((|selectMms| |newOp| |args| + NIL) + (SPADLET |form| + (CONS |newOp| |args|))) + ('T NIL)))))))) + |form|))))) + +;upSetelt(op,lhs,tree) == +; -- type analyzes implicit setelt forms +; var:=opOf lhs +; transferPropsToNode(getUnname var,var) +; if (m1:=getMode var) then $declaredMode:= m1 +; if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then +; putModeSet(var,[m1]) +; ms := bottomUp tree +; putValue(op,getValue tree) +; putModeSet(op,ms) + +(DEFUN |upSetelt| (|op| |lhs| |tree|) + (PROG (|var| |v1| |m1| |ms|) + (RETURN + (PROGN + (SPADLET |var| (|opOf| |lhs|)) + (|transferPropsToNode| (|getUnname| |var|) |var|) + (COND + ((SPADLET |m1| (|getMode| |var|)) + (SPADLET |$declaredMode| |m1|))) + (COND + ((OR |m1| + (AND (SPADLET |v1| (|getValue| |var|)) + (SPADLET |m1| (|objMode| |v1|)))) + (|putModeSet| |var| (CONS |m1| NIL)))) + (SPADLET |ms| (|bottomUp| |tree|)) + (|putValue| |op| (|getValue| |tree|)) + (|putModeSet| |op| |ms|))))) + +;upTableSetelt(op,lhs is [htOp,:args],rhs) == +; -- called only for undeclared, uninitialized table setelts +; ("*" = (PNAME getUnname htOp).0) and (1 ^= # args) => +; throwKeyedMsg("S2IS0040",NIL) +; # args ^= 1 => +; throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[", +; getUnname first args, +; ['",",getUnname arg for arg in rest args],'"]"]]) +; keyMode := '(Any) +; putMode (htOp,['Table,keyMode,'(Any)]) +; -- if we are to use a new table, we must call the "table" +; -- function to give it an initial value. +; bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]] +; tableCode := objVal getValue htOp +; r := upSetelt(op, lhs, [mkAtreeNode 'setelt,:lhs,rhs]) +; $genValue => r +; -- construct code +; t := getValue op +; putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t)) +; r + +(DEFUN |upTableSetelt| (|op| |lhs| |rhs|) + (PROG (|htOp| |args| |keyMode| |tableCode| |r| |t|) + (RETURN + (SEQ (PROGN + (SPADLET |htOp| (CAR |lhs|)) + (SPADLET |args| (CDR |lhs|)) + (COND + ((AND (BOOT-EQUAL '* + (ELT (PNAME (|getUnname| |htOp|)) 0)) + (NEQUAL 1 (|#| |args|))) + (|throwKeyedMsg| 'S2IS0040 NIL)) + ((NEQUAL (|#| |args|) 1) + (|throwKeyedMsg| 'S2IS0041 + (CONS (CONS (|getUnname| |htOp|) + (CONS (MAKESTRING ".[") + (CONS (|getUnname| (CAR |args|)) + (CONS + (PROG (G167309) + (SPADLET G167309 NIL) + (RETURN + (DO + ((G167314 (CDR |args|) + (CDR G167314)) + (|arg| NIL)) + ((OR (ATOM G167314) + (PROGN + (SETQ |arg| + (CAR G167314)) + NIL)) + G167309) + (SEQ + (EXIT + (SETQ G167309 + (APPEND G167309 + (CONS + (MAKESTRING ",") + (CONS + (|getUnname| |arg|) + NIL))))))))) + (CONS (MAKESTRING "]") NIL))))) + NIL))) + ('T (SPADLET |keyMode| '(|Any|)) + (|putMode| |htOp| + (CONS '|Table| + (CONS |keyMode| (CONS '(|Any|) NIL)))) + (|bottomUp| + (CONS (|mkAtreeNode| 'LET) + (CONS |htOp| + (CONS (CONS (|mkAtreeNode| '|table|) + NIL) + NIL)))) + (SPADLET |tableCode| (|objVal| (|getValue| |htOp|))) + (SPADLET |r| + (|upSetelt| |op| |lhs| + (CONS (|mkAtreeNode| '|setelt|) + (APPEND |lhs| (CONS |rhs| NIL))))) + (COND + (|$genValue| |r|) + ('T (SPADLET |t| (|getValue| |op|)) + (|putValue| |op| + (|objNew| + (CONS 'PROGN + (CONS |tableCode| + (CONS (|objVal| |t|) NIL))) + (|objMode| |t|))) + |r|))))))))) + +;isType t == +; -- Returns the evaluated type if t is a tree representing a type, +; -- and NIL otherwise +; op:=opOf t +; VECP op => +; isMap(op:= getUnname op) => NIL +; op = 'Mapping => +; argTypes := [isType type for type in rest t] +; "or"/[null type for type in argTypes] => nil +; ['Mapping, :argTypes] +; isLocalVar(op) => NIL +; d := isDomainValuedVariable op => d +; type:= +; -- next line handles subscripted vars +; (abbreviation?(op) or (op = 'typeOf) or +; constructor?(op) or (op in '(Record Union Enumeration))) and +; unabbrev unVectorize t +; type and evaluateType type +; d := isDomainValuedVariable op => d +; NIL + +(DEFUN |isType| (|t|) + (PROG (|op| |argTypes| |type| |d|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (|opOf| |t|)) + (COND + ((VECP |op|) + (COND + ((|isMap| (SPADLET |op| (|getUnname| |op|))) NIL) + ((BOOT-EQUAL |op| '|Mapping|) + (SPADLET |argTypes| + (PROG (G167337) + (SPADLET G167337 NIL) + (RETURN + (DO ((G167342 (CDR |t|) + (CDR G167342)) + (|type| NIL)) + ((OR (ATOM G167342) + (PROGN + (SETQ |type| (CAR G167342)) + NIL)) + (NREVERSE0 G167337)) + (SEQ (EXIT + (SETQ G167337 + (CONS (|isType| |type|) + G167337)))))))) + (COND + ((PROG (G167348) + (SPADLET G167348 NIL) + (RETURN + (DO ((G167354 NIL G167348) + (G167355 |argTypes| (CDR G167355)) + (|type| NIL)) + ((OR G167354 (ATOM G167355) + (PROGN + (SETQ |type| (CAR G167355)) + NIL)) + G167348) + (SEQ (EXIT (SETQ G167348 + (OR G167348 (NULL |type|)))))))) + NIL) + ('T (CONS '|Mapping| |argTypes|)))) + ((|isLocalVar| |op|) NIL) + ((SPADLET |d| (|isDomainValuedVariable| |op|)) |d|) + ('T + (SPADLET |type| + (AND (OR (|abbreviation?| |op|) + (BOOT-EQUAL |op| '|typeOf|) + (|constructor?| |op|) + (|member| |op| + '(|Record| |Union| |Enumeration|))) + (|unabbrev| (|unVectorize| |t|)))) + (AND |type| (|evaluateType| |type|))))) + ((SPADLET |d| (|isDomainValuedVariable| |op|)) |d|) + ('T NIL))))))) + +;upLETtype(op,lhs,type) == +; -- performs type assignment +; opName:= getUnname lhs +; (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] => +; compFailure ['" Cannot compile type assignment to",:bright opName] +; mode := +; if isPartialMode type then '(Mode) +; else if categoryForm?(type) then '(SubDomain (Domain)) +; else '(Domain) +; val:= objNew(type,mode) +; if isLocalVar(opName) then put(opName,'value,val,$env) +; else putHist(opName,'value,val,$e) +; putValue(op,val) +; -- have to fix the following +; putModeSet(op,[mode]) + +(DEFUN |upLETtype| (|op| |lhs| |type|) + (PROG (|opName| |mode| |val|) + (RETURN + (SEQ (PROGN + (SPADLET |opName| (|getUnname| |lhs|)) + (COND + ((AND (NULL |$genValue|) + (PROG (G167374) + (SPADLET G167374 NIL) + (RETURN + (DO ((G167380 NIL G167374) + (G167381 |$localVars| (CDR G167381)) + (|var| NIL)) + ((OR G167380 (ATOM G167381) + (PROGN + (SETQ |var| (CAR G167381)) + NIL)) + G167374) + (SEQ (EXIT (SETQ G167374 + (OR G167374 + (CONTAINED |var| |type|))))))))) + (|compFailure| + (CONS (MAKESTRING + " Cannot compile type assignment to") + (|bright| |opName|)))) + ('T + (SPADLET |mode| + (COND + ((|isPartialMode| |type|) '(|Mode|)) + ((|categoryForm?| |type|) + '(|SubDomain| (|Domain|))) + ('T '(|Domain|)))) + (SPADLET |val| (|objNew| |type| |mode|)) + (COND + ((|isLocalVar| |opName|) + (|put| |opName| '|value| |val| |$env|)) + ('T (|putHist| |opName| '|value| |val| |$e|))) + (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |mode| NIL))))))))) + +;assignSymbol(symbol, value, domain) == +;-- Special function for binding an interpreter variable from within algebra +;-- code. Does not do the assignment and returns nil, if the variable is +;-- already assigned +; val := get(symbol, 'value, $e) => nil +; obj := objNew(wrap value, devaluate domain) +; put(symbol, 'value, obj, $e) +; true + +(DEFUN |assignSymbol| (|symbol| |value| |domain|) + (PROG (|val| |obj|) + (RETURN + (COND + ((SPADLET |val| (|get| |symbol| '|value| |$e|)) NIL) + ('T + (SPADLET |obj| + (|objNew| (|wrap| |value|) (|devaluate| |domain|))) + (|put| |symbol| '|value| |obj| |$e|) 'T))))) + +;--% Handler for Interpreter Macros +;getInterpMacroNames() == +; names := [n for [n,:.] in $InterpreterMacroAlist] +; if (e := CAAR $InteractiveFrame) and (m := ASSOC("--macros--",e)) then +; names := append(names,[n for [n,:.] in CDR m]) +; MSORT names + +(DEFUN |getInterpMacroNames| () + (PROG (|e| |m| |n| |names|) + (RETURN + (SEQ (PROGN + (SPADLET |names| + (PROG (G167413) + (SPADLET G167413 NIL) + (RETURN + (DO ((G167419 |$InterpreterMacroAlist| + (CDR G167419)) + (G167401 NIL)) + ((OR (ATOM G167419) + (PROGN + (SETQ G167401 (CAR G167419)) + NIL) + (PROGN + (PROGN + (SPADLET |n| (CAR G167401)) + G167401) + NIL)) + (NREVERSE0 G167413)) + (SEQ (EXIT (SETQ G167413 + (CONS |n| G167413)))))))) + (COND + ((AND (SPADLET |e| (CAAR |$InteractiveFrame|)) + (SPADLET |m| (|assoc| '|--macros--| |e|))) + (SPADLET |names| + (APPEND |names| + (PROG (G167431) + (SPADLET G167431 NIL) + (RETURN + (DO + ((G167437 (CDR |m|) + (CDR G167437)) + (G167404 NIL)) + ((OR (ATOM G167437) + (PROGN + (SETQ G167404 + (CAR G167437)) + NIL) + (PROGN + (PROGN + (SPADLET |n| + (CAR G167404)) + G167404) + NIL)) + (NREVERSE0 G167431)) + (SEQ + (EXIT + (SETQ G167431 + (CONS |n| G167431))))))))))) + (MSORT |names|)))))) + +;isInterpMacro name == +; -- look in local and then global environment for a macro +; null IDENTP name => NIL +; name in $specialOps => NIL +; (m := get("--macros--",name,$env)) => m +; (m := get("--macros--",name,$e)) => m +; (m := get("--macros--",name,$InteractiveFrame)) => m +; -- $InterpreterMacroAlist will probably be phased out soon +; (sv := ASSOC(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv) +; NIL + +(DEFUN |isInterpMacro| (|name|) + (PROG (|m| |sv|) + (RETURN + (COND + ((NULL (IDENTP |name|)) NIL) + ((|member| |name| |$specialOps|) NIL) + ((SPADLET |m| (|get| '|--macros--| |name| |$env|)) |m|) + ((SPADLET |m| (|get| '|--macros--| |name| |$e|)) |m|) + ((SPADLET |m| (|get| '|--macros--| |name| |$InteractiveFrame|)) + |m|) + ((SPADLET |sv| (|assoc| |name| |$InterpreterMacroAlist|)) + (CONS NIL (CDR |sv|))) + ('T NIL))))) + +;--% Handlers for prefix QUOTE +;upQUOTE t == +; t isnt [op,expr] => NIL +; ms:= list +; m:= getBasicMode expr => m +; IDENTP expr => +;-- $useSymbolNotVariable => $Symbol +; ['Variable,expr] +; $OutputForm +; evalQUOTE(op,[expr],ms) +; putModeSet(op,ms) + +(DEFUN |upQUOTE| (|t|) + (PROG (|op| |ISTMP#1| |expr| |m| |ms|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |expr| (QCAR |ISTMP#1|)) + 'T))))) + NIL) + ('T + (SPADLET |ms| + (LIST (COND + ((SPADLET |m| (|getBasicMode| |expr|)) |m|) + ((IDENTP |expr|) + (CONS '|Variable| (CONS |expr| NIL))) + ('T |$OutputForm|)))) + (|evalQUOTE| |op| (CONS |expr| NIL) |ms|) + (|putModeSet| |op| |ms|)))))) + +;evalQUOTE(op,[expr],[m]) == +; triple:= +; $genValue => objNewWrap(expr,m) +; objNew(['QUOTE,expr],m) +; putValue(op,triple) + +(DEFUN |evalQUOTE| (|op| G167484 G167491) + (PROG (|m| |expr| |triple|) + (RETURN + (PROGN + (SPADLET |m| (CAR G167491)) + (SPADLET |expr| (CAR G167484)) + (SPADLET |triple| + (COND + (|$genValue| (|objNewWrap| |expr| |m|)) + ('T (|objNew| (CONS 'QUOTE (CONS |expr| NIL)) |m|)))) + (|putValue| |op| |triple|))))) + +;--% Handler for pretend +;uppretend t == +; t isnt [op,expr,type] => NIL +; mode := evaluateType unabbrev type +; not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode]) +; bottomUp expr +; putValue(op,objNew(objVal getValue expr,mode)) +; putModeSet(op,[mode]) + +(DEFUN |uppretend| (|t|) + (PROG (|op| |ISTMP#1| |expr| |ISTMP#2| |type| |mode|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |expr| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |type| (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ('T (SPADLET |mode| (|evaluateType| (|unabbrev| |type|))) + (COND + ((NULL (|isValidType| |mode|)) + (|throwKeyedMsg| 'S2IE0004 (CONS |mode| NIL))) + ('T (|bottomUp| |expr|) + (|putValue| |op| + (|objNew| (|objVal| (|getValue| |expr|)) |mode|)) + (|putModeSet| |op| (CONS |mode| NIL))))))))) + +;--% Handlers for REDUCE +;getReduceFunction(op,type,result, locale) == +; -- return the function cell for operation with the signature +; -- (type,type) -> type, possible from locale +; if type is ['Variable,var] then +; args := [arg := mkAtreeNode var,arg] +; putValue(arg,objNewWrap(var,type)) +; else +; args := [arg := mkAtreeNode "%1",arg] +; if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol)) +; putModeSet(arg,[type]) +; vecOp:=mkAtreeNode op +; transferPropsToNode(op,vecOp) +; if locale then putAtree(vecOp,'dollar,locale) +; mmS:= selectMms(vecOp,args,result) +; mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS | +; (isHomogeneousArgs sig) and and/[null c for c in cond]] +; null mm => 'failed +; [[dc,:sig],fun,:.]:=mm +; dc='local => [MKQ [fun,:'local],:CAR sig] +; dcVector := evalDomain dc +; $compilingMap => +; k := NRTgetMinivectorIndex( +; NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector) +; ['ELT,"$$$",k] --$$$ denotes minivector +; env:= +; NRTcompiledLookup(op,sig,dcVector) +; MKQ env + +(DEFUN |getReduceFunction| (|op| |type| |result| |locale|) + (PROG (|ISTMP#1| |var| |arg| |args| |vecOp| |mmS| |cond| |mm| |dc| + |sig| |fun| |dcVector| |k| |env|) + (RETURN + (SEQ (PROGN + (COND + ((AND (PAIRP |type|) (EQ (QCAR |type|) '|Variable|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |type|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |var| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |args| + (CONS (SPADLET |arg| (|mkAtreeNode| |var|)) + (CONS |arg| NIL))) + (|putValue| |arg| (|objNewWrap| |var| |type|))) + ('T + (SPADLET |args| + (CONS (SPADLET |arg| (|mkAtreeNode| '%1)) + (CONS |arg| NIL))) + (COND + ((BOOT-EQUAL |type| |$Symbol|) + (|putValue| |arg| (|objNewWrap| '%1 |$Symbol|))) + ('T NIL)))) + (|putModeSet| |arg| (CONS |type| NIL)) + (SPADLET |vecOp| (|mkAtreeNode| |op|)) + (|transferPropsToNode| |op| |vecOp|) + (COND (|locale| (|putAtree| |vecOp| '|dollar| |locale|))) + (SPADLET |mmS| (|selectMms| |vecOp| |args| |result|)) + (SPADLET |mm| + (PROG (G167557) + (SPADLET G167557 NIL) + (RETURN + (DO ((G167565 NIL G167557) + (G167566 |mmS| (CDR G167566)) + (|mm| NIL)) + ((OR G167565 (ATOM G167566) + (PROGN + (SETQ |mm| (CAR G167566)) + NIL) + (PROGN + (PROGN + (SPADLET |sig| (CDAR |mm|)) + (SPADLET |fun| (CADR |mm|)) + (SPADLET |cond| (CADDR |mm|)) + |mm|) + NIL)) + G167557) + (SEQ (EXIT (COND + ((AND + (|isHomogeneousArgs| |sig|) + (PROG (G167574) + (SPADLET G167574 'T) + (RETURN + (DO + ((G167580 NIL + (NULL G167574)) + (G167581 |cond| + (CDR G167581)) + (|c| NIL)) + ((OR G167580 + (ATOM G167581) + (PROGN + (SETQ |c| + (CAR G167581)) + NIL)) + G167574) + (SEQ + (EXIT + (SETQ G167574 + (AND G167574 + (NULL |c|))))))))) + (SETQ G167557 + (OR G167557 |mm|)))))))))) + (COND + ((NULL |mm|) '|failed|) + ('T (SPADLET |dc| (CAAR |mm|)) + (SPADLET |sig| (CDAR |mm|)) (SPADLET |fun| (CADR |mm|)) + (COND + ((BOOT-EQUAL |dc| '|local|) + (CONS (MKQ (CONS |fun| '|local|)) (CAR |sig|))) + ('T (SPADLET |dcVector| (|evalDomain| |dc|)) + (COND + (|$compilingMap| + (SPADLET |k| + (|NRTgetMinivectorIndex| + (|NRTcompiledLookup| |op| |sig| + |dcVector|) + |op| |sig| |dcVector|)) + (CONS 'ELT (CONS '$$$ (CONS |k| NIL)))) + ('T + (SPADLET |env| + (|NRTcompiledLookup| |op| |sig| + |dcVector|)) + (MKQ |env|)))))))))))) + +;isHomogeneous sig == +; --return true if sig describes a homogeneous binary operation +; sig.0=sig.1 and sig.1=sig.2 + +(DEFUN |isHomogeneous| (|sig|) + (AND (BOOT-EQUAL (ELT |sig| 0) (ELT |sig| 1)) + (BOOT-EQUAL (ELT |sig| 1) (ELT |sig| 2)))) + +;isHomogeneousArgs sig == +; --return true if sig describes a homogeneous binary operation +; sig.1=sig.2 + +(DEFUN |isHomogeneousArgs| (|sig|) (BOOT-EQUAL (ELT |sig| 1) (ELT |sig| 2))) + +;--% Handlers for REPEAT +;transformREPEAT [:itrl,body] == +; -- syntactic transformation of repeat iterators, called from mkAtree2 +; iterList:=[:iterTran1 for it in itrl] where iterTran1 == +; it is ['STEP,index,lower,step,:upperList] => +; [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper +; for upper in upperList]]] +; it is ['IN,index,s] => +; [['IN,index,mkAtree1 s]] +; it is ['ON,index,s] => +; [['IN,index,mkAtree1 ['tails,s]]] +; it is ['WHILE,b] => +; [['WHILE,mkAtree1 b]] +; it is ['_|,pred] => +; [['SUCHTHAT,mkAtree1 pred]] +; it is [op,:.] and (op in '(VALUE UNTIL)) => nil +; bodyTree:=mkAtree1 body +; iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 == +; it is ['STEP,:.] => nil +; it is ['IN,:.] => nil +; it is ['ON,:.] => nil +; it is ['WHILE,:.] => nil +; it is [op,b] and (op in '(UNTIL VALUE)) => +; [[op,mkAtree1 b]] +; it is ['_|,pred] => nil +; keyedSystemError("S2GE0016", +; ['"transformREPEAT",'"Unknown type of iterator"]) +; [:iterList,bodyTree] + +(DEFUN |transformREPEAT| (G167761) + (PROG (|LETTMP#1| |body| |itrl| |lower| |ISTMP#3| |step| |upperList| + |index| |ISTMP#2| |s| |bodyTree| |op| |b| |ISTMP#1| |pred| + |iterList|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE G167761)) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itrl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |iterList| + (PROG (G167816) + (SPADLET G167816 NIL) + (RETURN + (DO ((G167856 |itrl| (CDR G167856)) + (|it| NIL)) + ((OR (ATOM G167856) + (PROGN + (SETQ |it| (CAR G167856)) + NIL)) + G167816) + (SEQ (EXIT (SETQ G167816 + (APPEND G167816 + (COND + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '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|)) + 'T)))))))) + (CONS + (CONS 'STEP + (CONS |index| + (CONS + (|mkAtree1| |lower|) + (CONS + (|mkAtree1| |step|) + (PROG (G167866) + (SPADLET G167866 + NIL) + (RETURN + (DO + ((G167871 + |upperList| + (CDR G167871)) + (|upper| NIL)) + ((OR + (ATOM + G167871) + (PROGN + (SETQ |upper| + (CAR + G167871)) + NIL)) + (NREVERSE0 + G167866)) + (SEQ + (EXIT + (SETQ + G167866 + (CONS + (|mkAtree1| + |upper|) + G167866))))))))))) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '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|)) + 'T)))))) + (CONS + (CONS 'IN + (CONS |index| + (CONS (|mkAtree1| |s|) + NIL))) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'ON) + (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|)) + 'T)))))) + (CONS + (CONS 'IN + (CONS |index| + (CONS + (|mkAtree1| + (CONS '|tails| + (CONS |s| NIL))) + NIL))) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'WHILE) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |b| + (QCAR |ISTMP#1|)) + 'T)))) + (CONS + (CONS 'WHILE + (CONS (|mkAtree1| |b|) + NIL)) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) + NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (CONS + (CONS 'SUCHTHAT + (CONS (|mkAtree1| |pred|) + NIL)) + NIL)) + ((AND (PAIRP |it|) + (PROGN + (SPADLET |op| + (QCAR |it|)) + 'T) + (|member| |op| + '(VALUE UNTIL))) + NIL)))))))))) + (SPADLET |bodyTree| (|mkAtree1| |body|)) + (SPADLET |iterList| + (NCONC |iterList| + (PROG (G167877) + (SPADLET G167877 NIL) + (RETURN + (DO ((G167891 |itrl| + (CDR G167891)) + (|it| NIL)) + ((OR (ATOM G167891) + (PROGN + (SETQ |it| (CAR G167891)) + NIL)) + G167877) + (SEQ + (EXIT + (SETQ G167877 + (APPEND G167877 + (COND + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'STEP)) + NIL) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'IN)) + NIL) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'ON)) + NIL) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) 'WHILE)) + NIL) + ((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|)) + 'T))) + (|member| |op| + '(UNTIL VALUE))) + (CONS + (CONS |op| + (CONS (|mkAtree1| |b|) NIL)) + NIL)) + ((AND (PAIRP |it|) + (EQ (QCAR |it|) '|\||) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |it|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + NIL) + ('T + (|keyedSystemError| 'S2GE0016 + (CONS + (MAKESTRING + "transformREPEAT") + (CONS + (MAKESTRING + "Unknown type of iterator") + NIL)))))))))))))) + (APPEND |iterList| (CONS |bodyTree| NIL))))))) + +;upREPEAT t == +; -- REPEATS always return void() of Void +; -- assures throw to interpret-code mode goes to outermost loop +; $repeatLabel : local := MKQ GENSYM() +; $breakCount : local := 0 +; $repeatBodyLabel : local := MKQ GENSYM() +; $iterateCount : local := 0 +; $compilingLoop => upREPEAT1 t +; upREPEAT0 t + +(DEFUN |upREPEAT| (|t|) + (PROG (|$repeatLabel| |$breakCount| |$repeatBodyLabel| + |$iterateCount|) + (DECLARE (SPECIAL |$repeatLabel| |$breakCount| |$repeatBodyLabel| + |$iterateCount|)) + (RETURN + (PROGN + (SPADLET |$repeatLabel| (MKQ (GENSYM))) + (SPADLET |$breakCount| 0) + (SPADLET |$repeatBodyLabel| (MKQ (GENSYM))) + (SPADLET |$iterateCount| 0) + (COND + (|$compilingLoop| (|upREPEAT1| |t|)) + ('T (|upREPEAT0| |t|))))))) + +;upREPEAT0 t == +; -- sets up catch point for interp-only mode +; $compilingLoop: local := true +; ms := CATCH('loopCompiler,upREPEAT1 t) +; ms = 'tryInterpOnly => interpOnlyREPEAT t +; ms + +(DEFUN |upREPEAT0| (|t|) + (PROG (|$compilingLoop| |ms|) + (DECLARE (SPECIAL |$compilingLoop|)) + (RETURN + (PROGN + (SPADLET |$compilingLoop| 'T) + (SPADLET |ms| (CATCH '|loopCompiler| (|upREPEAT1| |t|))) + (COND + ((BOOT-EQUAL |ms| '|tryInterpOnly|) (|interpOnlyREPEAT| |t|)) + ('T |ms|)))))) + +;upREPEAT1 t == +; -- repeat loop handler with compiled body +; -- see if it has the expected form +; t isnt [op,:itrl,body] => NIL +; -- determine the mode of the repeat loop. At the moment, if there +; -- there are no iterators and there are no "break" statements, then +; -- the return type is Exit, otherwise Void. +; repeatMode := +; null(itrl) and ($breakCount=0) => $Void +; $Void +; -- if interpreting, go do that +; $interpOnly => interpREPEAT(op,itrl,body,repeatMode) +; -- analyze iterators and loop body +; upLoopIters itrl +; bottomUpCompile body +; -- now that the body is analyzed, we should know everything that +; -- is in the UNTIL clause +; for itr in itrl repeat +; itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until") +; -- now go do it +; evalREPEAT(op,rest t,repeatMode) +; putModeSet(op,[repeatMode]) + +(DEFUN |upREPEAT1| (|t|) + (PROG (|op| |ISTMP#2| |body| |itrl| |repeatMode| |ISTMP#1| |pred|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + (SPADLET |itrl| (QCDR |ISTMP#2|)) + 'T) + (PROGN + (SPADLET |itrl| (NREVERSE |itrl|)) + 'T))))) + NIL) + ('T + (SPADLET |repeatMode| + (COND + ((AND (NULL |itrl|) (EQL |$breakCount| 0)) + |$Void|) + ('T |$Void|))) + (COND + (|$interpOnly| + (|interpREPEAT| |op| |itrl| |body| |repeatMode|)) + ('T (|upLoopIters| |itrl|) (|bottomUpCompile| |body|) + (SEQ (DO ((G167993 |itrl| (CDR G167993)) + (|itr| NIL)) + ((OR (ATOM G167993) + (PROGN + (SETQ |itr| (CAR G167993)) + NIL)) + NIL) + (SEQ (EXIT (COND + ((AND (PAIRP |itr|) + (EQ (QCAR |itr|) 'UNTIL) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |itr|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |pred| + (QCAR |ISTMP#1|)) + 'T)))) + (EXIT + (|bottomUpCompilePredicate| + |pred| (MAKESTRING "until")))))))) + (|evalREPEAT| |op| (CDR |t|) |repeatMode|) + (|putModeSet| |op| (CONS |repeatMode| NIL))))))))))) + +;evalREPEAT(op,[:itrl,body],repeatMode) == +; -- generate code for loop +; bodyMode := computedMode body +; bodyCode := getArgValue(body,bodyMode) +; if $iterateCount > 0 then +; bodyCode := ['CATCH,$repeatBodyLabel,bodyCode] +; code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode] +; if repeatMode = $Void then code := ['OR,code,'(voidValue)] +; code := timedOptimization code +; if $breakCount > 0 then code := ['CATCH,$repeatLabel,code] +; val:= +; $genValue => +; timedEVALFUN code +; objNewWrap(voidValue(),repeatMode) +; objNew(code,repeatMode) +; putValue(op,val) + +(DEFUN |evalREPEAT| (|op| G168014 |repeatMode|) + (PROG (|LETTMP#1| |body| |itrl| |bodyMode| |bodyCode| |code| |val|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE G168014)) + (SPADLET |body| (CAR |LETTMP#1|)) + (SPADLET |itrl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |bodyMode| (|computedMode| |body|)) + (SPADLET |bodyCode| (|getArgValue| |body| |bodyMode|)) + (COND + ((> |$iterateCount| 0) + (SPADLET |bodyCode| + (CONS 'CATCH + (CONS |$repeatBodyLabel| + (CONS |bodyCode| NIL)))))) + (SPADLET |code| + (CONS 'REPEAT + (APPEND (PROG (G168029) + (SPADLET G168029 NIL) + (RETURN + (DO + ((G168034 |itrl| + (CDR G168034)) + (|itr| NIL)) + ((OR (ATOM G168034) + (PROGN + (SETQ |itr| + (CAR G168034)) + NIL)) + (NREVERSE0 G168029)) + (SEQ + (EXIT + (SETQ G168029 + (CONS + (|evalLoopIter| |itr|) + G168029))))))) + (CONS |bodyCode| NIL)))) + (COND + ((BOOT-EQUAL |repeatMode| |$Void|) + (SPADLET |code| + (CONS 'OR + (CONS |code| (CONS '(|voidValue|) NIL)))))) + (SPADLET |code| (|timedOptimization| |code|)) + (COND + ((> |$breakCount| 0) + (SPADLET |code| + (CONS 'CATCH + (CONS |$repeatLabel| (CONS |code| NIL)))))) + (SPADLET |val| + (COND + (|$genValue| (|timedEVALFUN| |code|) + (|objNewWrap| (|voidValue|) |repeatMode|)) + ('T (|objNew| |code| |repeatMode|)))) + (|putValue| |op| |val|)))))) + +;interpOnlyREPEAT t == +; -- interpret-code mode call to upREPEAT +; $genValue: local := true +; $interpOnly: local := true +; upREPEAT1 t + +(DEFUN |interpOnlyREPEAT| (|t|) + (PROG (|$genValue| |$interpOnly|) + (DECLARE (SPECIAL |$genValue| |$interpOnly|)) + (RETURN + (PROGN + (SPADLET |$genValue| 'T) + (SPADLET |$interpOnly| 'T) + (|upREPEAT1| |t|))))) + +;interpREPEAT(op,itrl,body,repeatMode) == +; -- performs interpret-code repeat +; $indexVars: local := NIL +; $indexTypes: local := NIL +; code := +; -- we must insert a CATCH for the iterate clause +; ['REPEAT,:[interpIter itr for itr in itrl], +; ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars, +; $indexTypes,nil)]] +; SPADCATCH(eval $repeatLabel,timedEVALFUN code) +; val:= objNewWrap(voidValue(),repeatMode) +; putValue(op,val) +; putModeSet(op,[repeatMode]) + +(DEFUN |interpREPEAT| (|op| |itrl| |body| |repeatMode|) + (PROG (|$indexVars| |$indexTypes| |code| |val|) + (DECLARE (SPECIAL |$indexVars| |$indexTypes|)) + (RETURN + (SEQ (PROGN + (SPADLET |$indexVars| NIL) + (SPADLET |$indexTypes| NIL) + (SPADLET |code| + (CONS 'REPEAT + (APPEND (PROG (G168070) + (SPADLET G168070 NIL) + (RETURN + (DO + ((G168075 |itrl| + (CDR G168075)) + (|itr| NIL)) + ((OR (ATOM G168075) + (PROGN + (SETQ |itr| + (CAR G168075)) + NIL)) + (NREVERSE0 G168070)) + (SEQ + (EXIT + (SETQ G168070 + (CONS (|interpIter| |itr|) + G168070))))))) + (CONS + (CONS 'CATCH + (CONS |$repeatBodyLabel| + (CONS + (|interpLoop| |body| + |$indexVars| |$indexTypes| + NIL) + NIL))) + NIL)))) + (SPADCATCH (|eval| |$repeatLabel|) + (|timedEVALFUN| |code|)) + (SPADLET |val| (|objNewWrap| (|voidValue|) |repeatMode|)) + (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |repeatMode| NIL))))))) + +;interpLoop(expr,indexList,indexTypes,requiredType) == +; -- generates code for interp-only repeat body +; ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList], +; MKQ indexTypes, MKQ requiredType] + +(DEFUN |interpLoop| (|expr| |indexList| |indexTypes| |requiredType|) + (CONS '|interpLoopIter| + (CONS (MKQ |expr|) + (CONS (MKQ |indexList|) + (CONS (CONS 'LIST |indexList|) + (CONS (MKQ |indexTypes|) + (CONS (MKQ |requiredType|) NIL))))))) + +;interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) == +; -- call interpreter on exp with loop vars in indexList with given +; -- values and types, requiredType is used from interpCOLLECT +; -- to indicate the required type of the result +; emptyAtree exp +; for i in indexList for val in indexVals for type in indexTypes repeat +; put(i,'value,objNewWrap(val,type),$env) +; bottomUp exp +; v:= getValue exp +; val := +; null requiredType => v +; coerceInteractive(v,requiredType) +; null val => +; throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType) +; objValUnwrap val + +(DEFUN |interpLoopIter| + (|exp| |indexList| |indexVals| |indexTypes| |requiredType|) + (PROG (|v| |val|) + (RETURN + (SEQ (PROGN + (|emptyAtree| |exp|) + (DO ((G168103 |indexList| (CDR G168103)) (|i| NIL) + (G168104 |indexVals| (CDR G168104)) (|val| NIL) + (G168105 |indexTypes| (CDR G168105)) + (|type| NIL)) + ((OR (ATOM G168103) + (PROGN (SETQ |i| (CAR G168103)) NIL) + (ATOM G168104) + (PROGN (SETQ |val| (CAR G168104)) NIL) + (ATOM G168105) + (PROGN (SETQ |type| (CAR G168105)) NIL)) + NIL) + (SEQ (EXIT (|put| |i| '|value| + (|objNewWrap| |val| |type|) |$env|)))) + (|bottomUp| |exp|) + (SPADLET |v| (|getValue| |exp|)) + (SPADLET |val| + (COND + ((NULL |requiredType|) |v|) + ('T (|coerceInteractive| |v| |requiredType|)))) + (COND + ((NULL |val|) + (|throwKeyedMsgCannotCoerceWithValue| (|objVal| |v|) + (|objMode| |v|) |requiredType|)) + ('T (|objValUnwrap| |val|)))))))) + +;--% Handler for return +;upreturn t == +; -- make sure we are in a user function +; t isnt [op,val] => NIL +; (null $compilingMap) and (null $interpOnly) => +; throwKeyedMsg("S2IS0047",NIL) +; if $mapTarget then putTarget(val,$mapTarget) +; bottomUp val +; if $mapTarget +; then +; val' := getArgValue(val, $mapTarget) +; m := $mapTarget +; else +; val' := wrapped2Quote objVal getValue val +; m := computedMode val +; cn := mapCatchName $mapName +; $mapReturnTypes := insert(m, $mapReturnTypes) +; $mapThrowCount := $mapThrowCount + 1 +; -- if $genValue then we are interpreting the map +; $genValue => THROW(cn,objNewWrap(removeQuote val',m)) +; putValue(op,objNew(['THROW,MKQ cn,val'],m)) +; putModeSet(op,[$Exit]) + +(DEFUN |upreturn| (|t|) + (PROG (|op| |ISTMP#1| |val| |val'| |m| |cn|) + (RETURN + (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |val| (QCAR |ISTMP#1|)) 'T))))) + NIL) + ((AND (NULL |$compilingMap|) (NULL |$interpOnly|)) + (|throwKeyedMsg| 'S2IS0047 NIL)) + ('T (COND (|$mapTarget| (|putTarget| |val| |$mapTarget|))) + (|bottomUp| |val|) + (COND + (|$mapTarget| + (SPADLET |val'| (|getArgValue| |val| |$mapTarget|)) + (SPADLET |m| |$mapTarget|)) + ('T + (SPADLET |val'| + (|wrapped2Quote| (|objVal| (|getValue| |val|)))) + (SPADLET |m| (|computedMode| |val|)))) + (SPADLET |cn| (|mapCatchName| |$mapName|)) + (SPADLET |$mapReturnTypes| (|insert| |m| |$mapReturnTypes|)) + (SPADLET |$mapThrowCount| (PLUS |$mapThrowCount| 1)) + (COND + (|$genValue| + (THROW |cn| (|objNewWrap| (|removeQuote| |val'|) |m|))) + ('T + (|putValue| |op| + (|objNew| + (CONS 'THROW (CONS (MKQ |cn|) (CONS |val'| NIL))) + |m|)) + (|putModeSet| |op| (CONS |$Exit| NIL))))))))) + +;--% Handler for SEQ +;upSEQ u == +; -- assumes that exits were translated into if-then-elses +; -- handles flat SEQs and embedded returns +; u isnt [op,:args] => NIL +; if (target := getTarget(op)) then putTarget(last args, target) +; for x in args repeat bottomUp x +; null (m := computedMode last args) => +; keyedSystemError("S2GE0016",['"upSEQ", +; '"last line of SEQ has no mode"]) +; evalSEQ(op,args,m) +; putModeSet(op,[m]) + +(DEFUN |upSEQ| (|u|) + (PROG (|op| |args| |target| |m|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |args| (QCDR |u|)) + 'T))) + NIL) + ('T + (COND + ((SPADLET |target| (|getTarget| |op|)) + (|putTarget| (|last| |args|) |target|))) + (DO ((G168154 |args| (CDR G168154)) (|x| NIL)) + ((OR (ATOM G168154) + (PROGN (SETQ |x| (CAR G168154)) NIL)) + NIL) + (SEQ (EXIT (|bottomUp| |x|)))) + (COND + ((NULL (SPADLET |m| (|computedMode| (|last| |args|)))) + (|keyedSystemError| 'S2GE0016 + (CONS (MAKESTRING "upSEQ") + (CONS (MAKESTRING + "last line of SEQ has no mode") + NIL)))) + ('T (|evalSEQ| |op| |args| |m|) + (|putModeSet| |op| (CONS |m| NIL)))))))))) + +;evalSEQ(op,args,m) == +; -- generate code for SEQ +; [:argl,last] := args +; val:= +; $genValue => getValue last +; bodyCode := nil +; for x in args repeat +; (m1 := computedMode x) and (m1 ^= '$ThrowAwayMode) => +; (av := getArgValue(x,m1)) ^= voidValue() => +; bodyCode := [av,:bodyCode] +; code:= +; bodyCode is [c] => c +; ['PROGN,:reverse bodyCode] +; objNew(code,m) +; putValue(op,val) + +(DEFUN |evalSEQ| (|op| |args| |m|) + (PROG (|LETTMP#1| |last| |argl| |m1| |av| |bodyCode| |c| |code| + |val|) + (RETURN + (SEQ (PROGN + (SPADLET |LETTMP#1| (REVERSE |args|)) + (SPADLET |last| (CAR |LETTMP#1|)) + (SPADLET |argl| (NREVERSE (CDR |LETTMP#1|))) + (SPADLET |val| + (COND + (|$genValue| (|getValue| |last|)) + ('T (SPADLET |bodyCode| NIL) + (SEQ (DO ((G168177 |args| (CDR G168177)) + (|x| NIL)) + ((OR (ATOM G168177) + (PROGN + (SETQ |x| (CAR G168177)) + NIL)) + NIL) + (SEQ (EXIT + (COND + ((AND + (SPADLET |m1| + (|computedMode| |x|)) + (NEQUAL |m1| + '|$ThrowAwayMode|)) + (EXIT + (COND + ((NEQUAL + (SPADLET |av| + (|getArgValue| |x| |m1|)) + (|voidValue|)) + (EXIT + (SPADLET |bodyCode| + (CONS |av| |bodyCode|))))))))))) + (SPADLET |code| + (COND + ((AND (PAIRP |bodyCode|) + (EQ (QCDR |bodyCode|) NIL) + (PROGN + (SPADLET |c| + (QCAR |bodyCode|)) + 'T)) + |c|) + ('T + (CONS 'PROGN + (REVERSE |bodyCode|))))) + (|objNew| |code| |m|))))) + (|putValue| |op| |val|)))))) + +;--% Handlers for Tuple +;upTuple t == +; --Computes the common mode set of the construct by resolving across +; --the argument list, and evaluating +; t isnt [op,:l] => nil +; dol := getAtree(op,'dollar) +; tar := getTarget(op) or dol +; null l => upNullTuple(op,l,tar) +; isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar) +; aggs := '(List) +; if tar and PAIRP(tar) and ^isPartialMode(tar) then +; CAR(tar) in aggs => +; ud := CADR tar +; for x in l repeat if not getTarget(x) then putTarget(x,ud) +; CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) => +; vec := ['List,underDomainOf tar] +; for x in l repeat if not getTarget(x) then putTarget(x,vec) +; argModeSetList:= [bottomUp x for x in l] +; eltTypes := replaceSymbols([first x for x in argModeSetList],l) +; if not isPartialMode(tar) and tar is ['Tuple,ud] then +; mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)] +; else mode := ['Tuple, resolveTypeListAny eltTypes] +; if isPartialMode tar then tar:=resolveTM(mode,tar) +; evalTuple(op,l,mode,tar) + +(DEFUN |upTuple| (|t|) + (PROG (|op| |l| |dol| |aggs| |vec| |argModeSetList| |eltTypes| + |ISTMP#1| |ud| |mode| |tar|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |l| (QCDR |t|)) + 'T))) + NIL) + ('T (SPADLET |dol| (|getAtree| |op| '|dollar|)) + (SPADLET |tar| (OR (|getTarget| |op|) |dol|)) + (COND + ((NULL |l|) (|upNullTuple| |op| |l| |tar|)) + ((|isTaggedUnion| |tar|) + (|upTaggedUnionConstruct| |op| |l| |tar|)) + ('T (SPADLET |aggs| '(|List|)) + (COND + ((AND |tar| (PAIRP |tar|) + (NULL (|isPartialMode| |tar|))) + (COND + ((|member| (CAR |tar|) |aggs|) + (SPADLET |ud| (CADR |tar|)) + (DO ((G168210 |l| (CDR G168210)) (|x| NIL)) + ((OR (ATOM G168210) + (PROGN (SETQ |x| (CAR G168210)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |ud|)) + ('T NIL)))))) + ((|member| (CAR |tar|) + '(|Matrix| |SquareMatrix| + |RectangularMatrix|)) + (SPADLET |vec| + (CONS '|List| + (CONS (|underDomainOf| |tar|) + NIL))) + (DO ((G168219 |l| (CDR G168219)) (|x| NIL)) + ((OR (ATOM G168219) + (PROGN (SETQ |x| (CAR G168219)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (|getTarget| |x|)) + (|putTarget| |x| |vec|)) + ('T NIL))))))))) + (SPADLET |argModeSetList| + (PROG (G168229) + (SPADLET G168229 NIL) + (RETURN + (DO ((G168234 |l| (CDR G168234)) + (|x| NIL)) + ((OR (ATOM G168234) + (PROGN + (SETQ |x| (CAR G168234)) + NIL)) + (NREVERSE0 G168229)) + (SEQ (EXIT + (SETQ G168229 + (CONS (|bottomUp| |x|) + G168229)))))))) + (SPADLET |eltTypes| + (|replaceSymbols| + (PROG (G168244) + (SPADLET G168244 NIL) + (RETURN + (DO ((G168249 |argModeSetList| + (CDR G168249)) + (|x| NIL)) + ((OR (ATOM G168249) + (PROGN + (SETQ |x| (CAR G168249)) + NIL)) + (NREVERSE0 G168244)) + (SEQ + (EXIT + (SETQ G168244 + (CONS (CAR |x|) G168244))))))) + |l|)) + (COND + ((AND (NULL (|isPartialMode| |tar|)) (PAIRP |tar|) + (EQ (QCAR |tar|) '|Tuple|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |ud| (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |mode| + (CONS '|Tuple| + (CONS + (|resolveTypeListAny| + (CONS |ud| |eltTypes|)) + NIL)))) + ('T + (SPADLET |mode| + (CONS '|Tuple| + (CONS + (|resolveTypeListAny| |eltTypes|) + NIL))))) + (COND + ((|isPartialMode| |tar|) + (SPADLET |tar| (|resolveTM| |mode| |tar|)))) + (|evalTuple| |op| |l| |mode| |tar|))))))))) + +;evalTuple(op,l,m,tar) == +; [agg,:.,underMode]:= m +; code := asTupleNewCode(#l, +; [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l]) +; val := +; $genValue => objNewWrap(timedEVALFUN code,m) +; objNew(code,m) +; if tar then val1 := coerceInteractive(val,tar) else val1 := val +; val1 => +; putValue(op,val1) +; putModeSet(op,[tar or m]) +; putValue(op,val) +; putModeSet(op,[m]) + +(DEFUN |evalTuple| (|op| |l| |m| |tar|) + (PROG (|agg| |LETTMP#1| |underMode| |code| |val| |val1|) + (RETURN + (SEQ (PROGN + (SPADLET |agg| (CAR |m|)) + (SPADLET |LETTMP#1| (REVERSE (CDR |m|))) + (SPADLET |underMode| (CAR |LETTMP#1|)) + (SPADLET |code| + (|asTupleNewCode| (|#| |l|) + (PROG (G168285) + (SPADLET G168285 NIL) + (RETURN + (DO ((G168290 |l| (CDR G168290)) + (|x| NIL)) + ((OR (ATOM G168290) + (PROGN + (SETQ |x| (CAR G168290)) + NIL)) + (NREVERSE0 G168285)) + (SEQ (EXIT + (SETQ G168285 + (CONS + (OR + (|getArgValue| |x| + |underMode|) + (|throwKeyedMsg| 'S2IC0007 + (CONS |underMode| NIL))) + G168285))))))))) + (SPADLET |val| + (COND + (|$genValue| + (|objNewWrap| (|timedEVALFUN| |code|) |m|)) + ('T (|objNew| |code| |m|)))) + (COND + (|tar| (SPADLET |val1| + (|coerceInteractive| |val| |tar|))) + ('T (SPADLET |val1| |val|))) + (COND + (|val1| (|putValue| |op| |val1|) + (|putModeSet| |op| (CONS (OR |tar| |m|) NIL))) + ('T (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |m| NIL))))))))) + +;upNullTuple(op,l,tar) == +; -- handler for the empty tuple +; defMode := +; tar and tar is [a,b] and (a in '(Stream Vector List)) and +; not isPartialMode(b) => ['Tuple,b] +; '(Tuple (None)) +; val := objNewWrap(asTupleNew(0,NIL), defMode) +; tar and not isPartialMode(tar) => +; null (val' := coerceInteractive(val,tar)) => +; throwKeyedMsg("S2IS0013",[tar]) +; putValue(op,val') +; putModeSet(op,[tar]) +; putValue(op,val) +; putModeSet(op,[defMode]) + +(DEFUN |upNullTuple| (|op| |l| |tar|) + (PROG (|a| |ISTMP#1| |b| |defMode| |val| |val'|) + (RETURN + (PROGN + (SPADLET |defMode| + (COND + ((AND |tar| (PAIRP |tar|) + (PROGN + (SPADLET |a| (QCAR |tar|)) + (SPADLET |ISTMP#1| (QCDR |tar|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + 'T))) + (|member| |a| '(|Stream| |Vector| |List|)) + (NULL (|isPartialMode| |b|))) + (CONS '|Tuple| (CONS |b| NIL))) + ('T '(|Tuple| (|None|))))) + (SPADLET |val| (|objNewWrap| (|asTupleNew| 0 NIL) |defMode|)) + (COND + ((AND |tar| (NULL (|isPartialMode| |tar|))) + (COND + ((NULL (SPADLET |val'| (|coerceInteractive| |val| |tar|))) + (|throwKeyedMsg| 'S2IS0013 (CONS |tar| NIL))) + ('T (|putValue| |op| |val'|) + (|putModeSet| |op| (CONS |tar| NIL))))) + ('T (|putValue| |op| |val|) + (|putModeSet| |op| (CONS |defMode| NIL)))))))) + +;--% Handler for typeOf +;uptypeOf form == +; form isnt [op, arg] => NIL +; if VECP arg then transferPropsToNode(getUnname arg,arg) +; if m := isType(arg) then +; m := +; categoryForm?(m) => '(SubDomain (Domain)) +; isPartialMode m => '(Mode) +; '(Domain) +; else if not (m := getMode arg) then [m] := bottomUp arg +; t := typeOfType m +; putValue(op, objNew(m,t)) +; putModeSet(op,[t]) + +(DEFUN |uptypeOf| (|form|) + (PROG (|op| |ISTMP#1| |arg| |LETTMP#1| |m| |t|) + (RETURN + (COND + ((NULL (AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |arg| (QCAR |ISTMP#1|)) 'T))))) + NIL) + ('T + (COND + ((VECP |arg|) + (|transferPropsToNode| (|getUnname| |arg|) |arg|))) + (COND + ((SPADLET |m| (|isType| |arg|)) + (SPADLET |m| + (COND + ((|categoryForm?| |m|) + '(|SubDomain| (|Domain|))) + ((|isPartialMode| |m|) '(|Mode|)) + ('T '(|Domain|))))) + ((NULL (SPADLET |m| (|getMode| |arg|))) + (SPADLET |LETTMP#1| (|bottomUp| |arg|)) + (SPADLET |m| (CAR |LETTMP#1|)) |LETTMP#1|) + ('T NIL)) + (SPADLET |t| (|typeOfType| |m|)) + (|putValue| |op| (|objNew| |m| |t|)) + (|putModeSet| |op| (CONS |t| NIL))))))) + +;typeOfType type == +; type in '((Mode) (Domain)) => '(SubDomain (Domain)) +; '(Domain) + +(DEFUN |typeOfType| (|type|) + (COND + ((|member| |type| '((|Mode|) (|Domain|))) + '(|SubDomain| (|Domain|))) + ('T '(|Domain|)))) + +;--% Handler for where +;upwhere t == +; -- upwhere does the puts in where into a local environment +; t isnt [op,tree,clause] => NIL +; -- since the "clause" might be a local macro, we now call mkAtree +; -- on the "tree" part (it is not yet a vat) +; not $genValue => +; compFailure [:bright '" where", +; '"for compiled code is not yet implemented."] +; $whereCacheList : local := nil +; [env,:e] := upwhereClause(clause,$env,$e) +; tree := upwhereMkAtree(tree,env,e) +; if x := getAtree(op,'dollar) then +; atom tree => throwKeyedMsg("S2IS0048",NIL) +; putAtree(CAR tree,'dollar,x) +; upwhereMain(tree,env,e) +; val := getValue tree +; putValue(op,val) +; result := putModeSet(op,getModeSet tree) +; wcl := [op for op in $whereCacheList] +; for op in wcl repeat clearDependencies(op,'T) +; result + +(DEFUN |upwhere| (|t|) + (PROG (|$whereCacheList| |op| |ISTMP#1| |ISTMP#2| |clause| |LETTMP#1| + |env| |e| |tree| |x| |val| |result| |wcl|) + (DECLARE (SPECIAL |$whereCacheList|)) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |t|) + (PROGN + (SPADLET |op| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |tree| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |clause| + (QCAR |ISTMP#2|)) + 'T))))))) + NIL) + ((NULL |$genValue|) + (|compFailure| + (APPEND (|bright| (MAKESTRING " where")) + (CONS (MAKESTRING + "for compiled code is not yet implemented.") + NIL)))) + ('T (SPADLET |$whereCacheList| NIL) + (SPADLET |LETTMP#1| + (|upwhereClause| |clause| |$env| |$e|)) + (SPADLET |env| (CAR |LETTMP#1|)) + (SPADLET |e| (CDR |LETTMP#1|)) + (SPADLET |tree| (|upwhereMkAtree| |tree| |env| |e|)) + (COND + ((SPADLET |x| (|getAtree| |op| '|dollar|)) + (COND + ((ATOM |tree|) (|throwKeyedMsg| 'S2IS0048 NIL)) + ('T (|putAtree| (CAR |tree|) '|dollar| |x|))))) + (|upwhereMain| |tree| |env| |e|) + (SPADLET |val| (|getValue| |tree|)) + (|putValue| |op| |val|) + (SPADLET |result| + (|putModeSet| |op| (|getModeSet| |tree|))) + (SPADLET |wcl| + (PROG (G168397) + (SPADLET G168397 NIL) + (RETURN + (DO ((G168402 |$whereCacheList| + (CDR G168402)) + (|op| NIL)) + ((OR (ATOM G168402) + (PROGN + (SETQ |op| (CAR G168402)) + NIL)) + (NREVERSE0 G168397)) + (SEQ (EXIT (SETQ G168397 + (CONS |op| G168397)))))))) + (DO ((G168411 |wcl| (CDR G168411)) (|op| NIL)) + ((OR (ATOM G168411) + (PROGN (SETQ |op| (CAR G168411)) NIL)) + NIL) + (SEQ (EXIT (|clearDependencies| |op| 'T)))) + |result|)))))) + +;upwhereClause(tree,env,e) == +; -- uses the variable bindings from env and e and returns an environment +; -- of its own bindings +; $env: local := copyHack env +; $e: local := copyHack e +; bottomUp tree +; [$env,:$e] + +(DEFUN |upwhereClause| (|tree| |env| |e|) + (PROG (|$env| |$e|) + (DECLARE (SPECIAL |$env| |$e|)) + (RETURN + (PROGN + (SPADLET |$env| (|copyHack| |env|)) + (SPADLET |$e| (|copyHack| |e|)) + (|bottomUp| |tree|) + (CONS |$env| |$e|))))) + +;upwhereMkAtree(tree,$env,$e) == mkAtree tree + +(DEFUN |upwhereMkAtree| (|tree| |$env| |$e|) + (DECLARE (SPECIAL |$env| |$e|)) + (|mkAtree| |tree|)) + +;upwhereMain(tree,$env,$e) == +; -- uses local copies of $env and $e while evaluating tree +; bottomUp tree + +(DEFUN |upwhereMain| (|tree| |$env| |$e|) + (DECLARE (SPECIAL |$env| |$e|)) + (|bottomUp| |tree|)) + +;copyHack(env) == +; -- makes a copy of an environment with the exception of pairs +; -- (localModemap . something) +; c:= CAAR env +; d:= [fn p for p in c] where fn(p) == +; CONS(CAR p,[(EQCAR(q,'localModemap) => q; copy q) for q in CDR p]) +; [[d]] + +(DEFUN |copyHack,fn| (|p|) + (PROG () + (RETURN + (SEQ (CONS (CAR |p|) + (PROG (G168460) + (SPADLET G168460 NIL) + (RETURN + (DO ((G168465 (CDR |p|) (CDR G168465)) + (|q| NIL)) + ((OR (ATOM G168465) + (PROGN (SETQ |q| (CAR G168465)) NIL)) + (NREVERSE0 G168460)) + (SEQ (EXIT (SETQ G168460 + (CONS + (SEQ + (IF + (EQCAR |q| '|localModemap|) + (EXIT |q|)) + (EXIT (COPY |q|))) + G168460)))))))))))) + + +(DEFUN |copyHack| (|env|) + (PROG (|c| |d|) + (RETURN + (SEQ (PROGN + (SPADLET |c| (CAAR |env|)) + (SPADLET |d| + (PROG (G168481) + (SPADLET G168481 NIL) + (RETURN + (DO ((G168486 |c| (CDR G168486)) + (|p| NIL)) + ((OR (ATOM G168486) + (PROGN + (SETQ |p| (CAR G168486)) + NIL)) + (NREVERSE0 G168481)) + (SEQ (EXIT (SETQ G168481 + (CONS (|copyHack,fn| |p|) + G168481)))))))) + (CONS (CONS |d| NIL) NIL)))))) + +;-- Creates the function names of the special function handlers and puts +;-- them on the property list of the function name +;EVALANDFILEACTQ +; ( +; for name in $specialOps repeat +; ( +; functionName:=INTERNL('up,name) ; +; MAKEPROP(name,'up,functionName) ; +; CREATE_-SBC functionName +; ) +; ) + +(EVALANDFILEACTQ + (REPEAT (IN |name| |$specialOps|) + (SEQ (SPADLET |functionName| (INTERNL '|up| |name|)) + (MAKEPROP |name| '|up| |functionName|) + (EXIT (CREATE-SBC |functionName|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}