From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/interp/i-spec2.boot.pamphlet | 1202 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 1202 insertions(+) create mode 100644 src/interp/i-spec2.boot.pamphlet (limited to 'src/interp/i-spec2.boot.pamphlet') diff --git a/src/interp/i-spec2.boot.pamphlet b/src/interp/i-spec2.boot.pamphlet new file mode 100644 index 00000000..8b16f053 --- /dev/null +++ b/src/interp/i-spec2.boot.pamphlet @@ -0,0 +1,1202 @@ +\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} -- cgit v1.2.3