aboutsummaryrefslogtreecommitdiff
path: root/src/interp/i-eval.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/i-eval.boot.pamphlet')
-rw-r--r--src/interp/i-eval.boot.pamphlet474
1 files changed, 474 insertions, 0 deletions
diff --git a/src/interp/i-eval.boot.pamphlet b/src/interp/i-eval.boot.pamphlet
new file mode 100644
index 00000000..0803bae7
--- /dev/null
+++ b/src/interp/i-eval.boot.pamphlet
@@ -0,0 +1,474 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp i-eval.boot}
+\author{The Axiom Team}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{License}
+<<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.
+
+@
+<<*>>=
+<<license>>
+
+--% Constructor Evaluation
+
+$noEvalTypeMsg := nil
+
+evalDomain form ==
+ if $evalDomain then
+ sayMSG concat('" instantiating","%b",prefix2String form,"%d")
+ startTimingProcess 'instantiation
+ newType? form => form
+ result := eval mkEvalable form
+ stopTimingProcess 'instantiation
+ result
+
+mkEvalable form ==
+ form is [op,:argl] =>
+ op="QUOTE" => form
+ op="WRAPPED" => mkEvalable devaluate argl
+ op="Record" => mkEvalableRecord form
+ op="Union" => mkEvalableUnion form
+ op="Mapping"=> mkEvalableMapping form
+ op="Enumeration" => form
+ loadIfNecessary op
+ kind:= GETDATABASE(op,'CONSTRUCTORKIND)
+ cosig := GETDATABASE(op, 'COSIG) =>
+ [op,:[val for x in argl for typeFlag in rest cosig]] where val ==
+ typeFlag =>
+ kind = 'category => MKQ x
+ VECP x => MKQ x
+ loadIfNecessary x
+ mkEvalable x
+ x is ['QUOTE,:.] => x
+ x is ['_#,y] => ['SIZE,MKQ y]
+ MKQ x
+ [op,:[mkEvalable x for x in argl]]
+ form=$EmptyMode => $Integer
+ IDENTP form and constructor?(form) => [form]
+ FBPIP form => BPINAME form
+ form
+
+mkEvalableMapping form ==
+ [first form,:[mkEvalable d for d in rest form]]
+
+mkEvalableRecord form ==
+ [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]]
+
+mkEvalableUnion form ==
+ isTaggedUnion form =>
+ [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]]
+ [first form,:[mkEvalable d for d in rest form]]
+
+evaluateType0 form ==
+ -- Takes a parsed, unabbreviated type and evaluates it, replacing
+ -- type valued variables with their values, and calling bottomUp
+ -- on non-type valued arguemnts to the constructor
+ -- and finally checking to see whether the type satisfies the
+ -- conditions of its modemap
+ -- However, the input might be an attribute, not a type
+ -- $noEvalTypeMsg: fluid := true
+ domain:= isDomainValuedVariable form => domain
+ form = $EmptyMode => form
+ form = "?" => $EmptyMode
+ STRINGP form => form
+ form = "$" => form
+ $expandSegments : local := nil
+ form is ['typeOf,.] =>
+ form' := mkAtree form
+ bottomUp form'
+ objVal getValue(form')
+ form is [op,:argl] =>
+ op='CATEGORY =>
+ argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]]
+ form
+ op in '(Join Mapping) =>
+ [op,:[evaluateType arg for arg in argl]]
+ op='Union =>
+ argl and first argl is [x,.,.] and member(x,'(_: Declare)) =>
+ [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
+ [op,:[evaluateType arg for arg in argl]]
+ op='Record =>
+ [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
+ op='Enumeration => form
+ constructor? op => evaluateType1 form
+ NIL
+ constructor? form =>
+ ATOM form => evaluateType [form]
+ throwEvalTypeMsg("S2IE0003",[form,form])
+
+evaluateType form ==
+ -- Takes a parsed, unabbreviated type and evaluates it, replacing
+ -- type valued variables with their values, and calling bottomUp
+ -- on non-type valued arguemnts to the constructor
+ -- and finally checking to see whether the type satisfies the
+ -- conditions of its modemap
+ domain:= isDomainValuedVariable form => domain
+ form = $EmptyMode => form
+ form = "?" => $EmptyMode
+ STRINGP form => form
+ form = "$" => form
+ $expandSegments : local := nil
+ form is ['typeOf,.] =>
+ form' := mkAtree form
+ bottomUp form'
+ objVal getValue(form')
+ form is [op,:argl] =>
+ op='CATEGORY =>
+ argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]]
+ form
+ op in '(Join Mapping) =>
+ [op,:[evaluateType arg for arg in argl]]
+ op='Union =>
+ argl and first argl is [x,.,.] and member(x,'(_: Declare)) =>
+ [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
+ [op,:[evaluateType arg for arg in argl]]
+ op='Record =>
+ [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
+ op='Enumeration => form
+ evaluateType1 form
+ constructor? form =>
+ ATOM form => evaluateType [form]
+ throwEvalTypeMsg("S2IE0003",[form,form])
+ throwEvalTypeMsg("S2IE0004",[form])
+
+evaluateType1 form ==
+ --evaluates the arguments passed to a constructor
+ [op,:argl]:= form
+ constructor? op =>
+ null (sig := getConstructorSignature form) =>
+ throwEvalTypeMsg("S2IE0005",[form])
+ [.,:ml] := sig
+ ml := replaceSharps(ml,form)
+ # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form])
+ for x in argl for m in ml for argnum in 1.. repeat
+ typeList := [v,:typeList] where v ==
+ categoryForm?(m) =>
+ m := evaluateType MSUBSTQ(x,'_$,m)
+ evalCategory(x' := (evaluateType x), m) => x'
+ throwEvalTypeMsg("S2IE0004",[form])
+ m := evaluateType m
+ GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and
+ (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) =>
+ [zt,:zv]:= z1:= getAndEvalConstructorArgument tree
+ (v:= coerceOrRetract(z1,m)) => objValUnwrap v
+ throwKeyedMsgCannotCoerceWithValue(zv,zt,m)
+ if x = $EmptyMode then x := $quadSymbol
+ throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form])
+ [op,:NREVERSE typeList]
+ throwEvalTypeMsg("S2IE0007",[op])
+
+throwEvalTypeMsg(msg, args) ==
+ $noEvalTypeMsg => spadThrow()
+ throwKeyedMsg(msg, args)
+
+makeOrdinal i ==
+ ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1)
+
+evaluateSignature sig ==
+ -- calls evaluateType on a signature
+ sig is [ ='SIGNATURE,fun,sigl] =>
+ ['SIGNATURE,fun,
+ [(t = '_$ => t; evaluateType(t)) for t in sigl]]
+ sig
+
+--% Code Evaluation
+
+-- This code generates, then evaluates code during the bottom up phase
+-- of interpretation
+
+splitIntoBlocksOf200 a ==
+ null a => nil
+ [[first (r:=x) for x in tails a for i in 1..200],
+ :splitIntoBlocksOf200 rest r]
+
+--------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
+evalForm(op,opName,argl,mmS) ==
+ -- applies the first applicable function
+
+ for mm in mmS until form repeat
+ [sig,fun,cond]:= mm
+ (CAR sig) = 'interpOnly => form := CAR sig
+ #argl ^= #CDDR sig => 'skip ---> RDJ 6/95
+ form:=
+ $genValue or null cond =>
+ [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL
+ for x in argl for t in CDDR sig]
+ [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL
+ for x in argl for t in CDDR sig for c in cond]
+ form or null argl =>
+ dc:= CAR sig
+ form :=
+ dc='local => --[fun,:form]
+ atom fun =>
+ fun in $localVars => ['SPADCALL,:form,fun]
+ [fun,:form,NIL]
+ ['SPADCALL,:form,fun]
+ dc is ["__FreeFunction__",:freeFun] =>
+ ['SPADCALL,:form,freeFun]
+ fun is ['XLAM,xargs,:xbody] =>
+ rec := first form
+ xbody is [['RECORDELT,.,ind,len]] =>
+ optRECORDELT([CAAR xbody,rec,ind,len])
+ xbody is [['SETRECORDELT,.,ind,len,.]] =>
+ optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form])
+ xbody is [['RECORDCOPY,.,len]] =>
+ optRECORDCOPY([CAAR xbody,rec,len])
+ ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)]
+ dcVector := evalDomain dc
+ fun0 :=
+ newType? CAAR mm =>
+ mm' := first ncSigTransform mm
+ ncGetFunction(opName, first mm', rest mm')
+ NRTcompileEvalForm(opName,rest sig,dcVector)
+ null fun0 => throwKeyedMsg("S2IE0008",[opName])
+ [bpi,:domain] := fun0
+ EQ(bpi,function Undef) =>
+ sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig])
+ NIL
+ if $NRTmonitorIfTrue = true then
+ sayBrightlyNT ['"Applying ",first fun0,'" to:"]
+ pp [devaluateDeeply x for x in form]
+ _$:fluid := domain
+ ['SPADCALL, :form, fun0]
+ not form => nil
+-- not form => throwKeyedMsg("S2IE0008",[opName])
+ form='interpOnly => rewriteMap(op,opName,argl)
+ targetType := CADR sig
+ if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType
+ evalFormMkValue(op,form,targetType)
+
+sideEffectedArg?(t,sig,opName) ==
+ opString := SYMBOL_-NAME opName
+ (opName ^= 'setelt) and (ELT(opString, #opString-1) ^= char '_!) => nil
+ dc := first sig
+ t = dc
+
+getArgValue(a, t) ==
+ atom a and not VECP a =>
+ t' := coerceOrRetract(getBasicObject a,t)
+ t' and wrapped2Quote objVal t'
+ v := getArgValue1(a, t) => v
+ alt := altTypeOf(objMode getValue a, a, nil) =>
+ t' := coerceInt(getValue a, alt)
+ t' := coerceOrRetract(t',t)
+ t' and wrapped2Quote objVal t'
+ nil
+
+getArgValue1(a,t) ==
+ -- creates a value for a, coercing to t
+ t' := getValue(a) =>
+ (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and
+ objValUnwrap(t') is ['MAP,:.] =>
+ getMappingArgValue(a,t,m)
+ t' := coerceOrRetract(t',t)
+ t' and wrapped2Quote objVal t'
+ systemErrorHere '"getArgValue"
+
+getArgValue2(a,t,se?,opName) ==
+ se? and (objMode(getValue a) ^= t) =>
+ throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t])
+ getArgValue(a,t)
+
+getArgValueOrThrow(x, type) ==
+ getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type])
+
+getMappingArgValue(a,t,m is ['Mapping,:ml]) ==
+ (una := getUnname a) in $localVars =>
+ $genValue =>
+ name := get(una,'name,$env)
+ a.0 := name
+ mmS := selectLocalMms(a,name,rest ml, nil)
+ or/[mm for mm in mmS |
+ (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName]
+ NIL
+ una
+ mmS := selectLocalMms(a,una,rest ml, nil)
+ or/[mm for mm in mmS |
+ (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName]
+ NIL
+
+getArgValueComp2(arg, type, cond, se?, opName) ==
+ se? and (objMode(getValue arg) ^= type) =>
+ throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type])
+ getArgValueComp(arg, type, cond)
+
+getArgValueComp(arg,type,cond) ==
+ -- getArgValue for compiled case. if there is a condition then
+ -- v must be data to verify that coerceInteractive succeeds.
+ v:= getArgValue(arg,type)
+ null v => nil
+ null cond => v
+ v is ['QUOTE,:.] or getBasicMode v => v
+ n := getUnnameIfCan arg
+ if num := isSharpVarWithNum n then
+ not $compilingMap => n := 'unknownVar
+ alias := get($mapName,'alias,$e)
+ n := alias.(num - 1)
+ keyedMsgCompFailure("S2IE0010",[n])
+
+evalFormMkValue(op,form,tm) ==
+ val:=
+ u:=
+ $genValue => wrap timedEVALFUN form
+ form
+ objNew(u,tm)
+--+
+ if $NRTmonitorIfTrue = true then
+ sayBrightlyNT ['"Value of ",op.0,'" ===> "]
+ pp unwrap u
+ putValue(op,val)
+ [tm]
+
+failCheck x ==
+ x = '"failed" =>
+ stopTimingProcess peekTimedName()
+ THROW('interpreter,objNewWrap('"failed",$String))
+ x = $coerceFailure =>
+ NIL
+ x
+
+--% Some Antique Comments About the Interpreter
+
+--EVAL BOOT contains the top level interface to the Scratchhpad-II
+--interpreter. The Entry point into the interpreter from the parser is
+--processInteractive.
+--The type analysis algorithm is contained in the file BOTMUP BOOT,
+--and MODSEL boot,
+--the map handling routines are in MAP BOOT and NEWMAP BOOT, and
+--the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT.
+--
+--Conventions:
+-- All spad values in the interpreter are passed around in triples.
+-- These are lists of three items: [value,mode,environment]. The value
+-- may be wrapped (this is a pair whose CAR is the atom WRAPPED and
+-- whose CDR is the value), which indicates that it is a real value,
+-- or unwrapped in which case it needs to be EVALed to produce the
+-- proper value. The mode is the type of value, and should always be
+-- completely specified (not contain $EmptyMode). The environment
+-- is always empty, and is included for historical reasons.
+--
+--Modemaps:
+-- Modemaps are descriptions of compiled Spad function which the
+-- interpreter uses to perform type analysis. They consist of patterns
+-- of types for the arguments, and conditions the types must satisfy
+-- for the function to apply. For each function name there is a list
+-- of modemaps in file MODEMAP DATABASE for each distinct function with
+-- that name. The following is the list of the modemaps for "*"
+-- (multiplication. The first modemap (the one with the labels) is for
+-- module mltiplication which is multiplication of an element of a
+-- module by a member of its scalar domain.
+--
+-- This is the signature pattern for the modemap, it is of the form:
+-- (DomainOfComputation TargetType <ArgumentType ...>)
+-- |
+-- | This is the predicate that needs to be
+-- | satisfied for the modemap to apply
+-- | |
+-- V |
+-- /-----------/ |
+-- ( ( (*1 *1 *2 *1) V
+-- /-----------------------------------------------------------/
+-- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) )
+-- . CATDEF) <-- This is the file where the function was defined
+-- ( (*1 *1 *2 *1)
+-- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) )
+-- . CATDEF)
+-- ( (*1 *1 *2 *1)
+-- ( (AND
+-- (isDomain *2 (NonNegativeInteger))
+-- (ofCategory *1 (AbelianMonoid))) )
+-- . CATDEF)
+-- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF)
+-- )
+--
+--Environments:
+-- Environments associate properties with atoms.
+-- (see CUTIL BOOT for the exact structure of environments).
+-- Some common properties are:
+-- modeSet:
+-- During interpretation we build a modeSet property for each node in
+-- the expression. This is (in theory) a list of all the types
+-- possible for the node. In the current implementation these
+-- modeSets always contain a single type.
+-- value:
+-- Value properties are always triples. This is where the values of
+-- variables are stored. We also build value properties for internal
+-- nodes during the bottom up phase.
+-- mode:
+-- This is the declared type of an identifier.
+--
+-- There are several different environments used in the interpreter:
+-- $InteractiveFrame : this is the environment where the user
+-- values are stored. Any side effects of evaluation of a top-level
+-- expression are stored in this environment. It is always used as
+-- the starting environment for interpretation.
+-- $e : This is the name used for $InteractiveFrame while interpreting.
+-- $env : This is local environment used by the interpreter.
+-- Only temporary information (such as types of local variables is
+-- stored in $env.
+-- It is thrown away after evaluation of each expression.
+--
+--Frequently used global variables:
+-- $genValue : if true then evaluate generated code, otherwise leave
+-- code unevaluated. If $genValue is false then we are compiling.
+-- $op: name of the top level operator (unused except in map printing)
+-- $mapList: list of maps being type analyzed, used in recursive
+-- map type anlysis.
+-- $compilingMap: true when compiling a map, used to detect where to
+-- THROW when interpret-only is invoked
+-- $compilingLoop: true when compiling a loop body, used to control
+-- nesting level of interp-only loop CATCH points
+-- $interpOnly: true when in interpret only mode, used to call
+-- alternate forms of COLLECT and REPEAT.
+-- $inCOLLECT: true when compiling a COLLECT, used only for hacked
+-- stream compiler.
+-- $StreamFrame: used in printing streams, it is the environment
+-- where local stream variables are stored
+-- $declaredMode: Weak type propagation for symbols, set in upCOERCE
+-- and upLET. This variable is used to determine
+-- the alternate polynomial types of Symbols.
+-- $localVars: list of local variables in a map body
+-- $MapArgumentTypeList: hack for stream compilation
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}