1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34-- Initialize for use in msgdb
35$genValue := false
36
37--% Constructor Evaluation
38
39-- For use from compiled code
40
41quoteNontypeArgs(t) ==
42    t is [.] => t
43    op := opOf t
44    loadIfNecessary op
45    args := rest t
46    cs := rest GETDATABASE(op, 'COSIG)
47    nargs := [if c then quoteNontypeArgs(a) else ["QUOTE", a]
48                for a in args for c in cs]
49    [op, :nargs]
50
51evalType(t) == EVAL(quoteNontypeArgs(t))
52
53---
54
55$noEvalTypeMsg := nil
56$evalDomain := nil
57
58evalDomain form ==
59  if $evalDomain then
60    sayMSG concat('"   instantiating","%b",prefix2String form,"%d")
61  startTimingProcess 'instantiation
62  result := eval mkEvalable form
63  stopTimingProcess 'instantiation
64  result
65
66mkEvalable form ==
67  form is [op,:argl] =>
68    op="QUOTE" => form
69    op="WRAPPED" => mkEvalable devaluate argl
70    op="Record" => mkEvalableRecord form
71    op="Union"  => mkEvalableUnion  form
72    op="Mapping"=> mkEvalableMapping form
73    op="Enumeration" => form
74    loadIfNecessary op
75    kind:= GETDATABASE(op,'CONSTRUCTORKIND)
76    cosig := GETDATABASE(op, 'COSIG) =>
77      [op,:[val for x in argl for typeFlag in rest cosig]] where val ==
78        typeFlag =>
79          kind = 'category => MKQ x
80          VECP x => MKQ x
81          mkEvalable x
82        x is ['QUOTE,:.] => x
83        x is ['_#,y] => ['SIZE,MKQ y]
84        MKQ x
85    [op,:[mkEvalable x for x in argl]]
86  form=$EmptyMode => $Integer
87  IDENTP form and constructor?(form) => [form]
88  FBPIP form => BREAK()
89  form
90
91mkEvalableMapping form ==
92  [first form,:[mkEvalable d for d in rest form]]
93
94mkEvalableRecord form ==
95  [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]]
96
97mkEvalableUnion form ==
98  isTaggedUnion form =>
99    [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]]
100  [first form,:[mkEvalable d for d in rest form]]
101
102evaluateType form ==
103  -- Takes a parsed, unabbreviated type and evaluates it, replacing
104  --  type valued variables with their values, and calling bottomUp
105  --  on non-type valued arguments to the constructor
106  --  and finally checking to see whether the type satisfies the
107  --  conditions of its modemap
108  domain:= isDomainValuedVariable form => domain
109  form = $EmptyMode => form
110  form = "?"        => $EmptyMode
111  STRINGP form => form
112  form = "$" => form
113  form is ['typeOf,.] =>
114    form' := mkAtree form
115    bottomUp form'
116    objVal getValue(form')
117  form is [op,:argl] =>
118    op='CATEGORY =>
119      argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]]
120      form
121    op in '(Join Mapping) =>
122      [op,:[evaluateType arg for arg in argl]]
123    op='Union  =>
124      argl and first argl is [x,.,.] and member(x,'(_: Declare)) =>
125        [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
126      [op,:[evaluateType arg for arg in argl]]
127    op='Record =>
128      [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]]
129    op='Enumeration => form
130    evaluateFormAsType form
131  constructor? form =>
132    ATOM form => evaluateType [form]
133    throwEvalTypeMsg("S2IE0003",[form,form])
134  throwEvalTypeMsg("S2IE0004", [form])
135
136++ `form' used in a context where a type (domain or category) is
137++ expected.  Attempt to fully evaluate it.  Error if the resulting
138++ value is not a type.  When successful, the result is the reified
139++ canonical form of the type.
140evaluateFormAsType form ==
141  form is [op,:args] and constructor? op => evaluateType1 form
142  t := mkAtree form
143  -- ??? Maybe we should be more careful about generalized types.
144  bottomUp t is [m] and (m = ["Mode"] or isCategoryForm(m)) =>
145    objVal getValue t
146  throwEvalTypeMsg("S2IE0004",[form])
147
148evaluateType1 form ==
149  --evaluates the arguments passed to a constructor
150  [op,:argl]:= form
151  constructor? op =>
152    null (sig := getConstructorSignature form) =>
153       throwEvalTypeMsg("S2IE0005",[form])
154    [.,:ml] := sig
155    ml := replaceSharps(ml,form)
156    # argl ~= #ml => throwEvalTypeMsg("S2IE0003",[form,form])
157    for x in argl for m in ml for argnum in 1.. repeat
158      typeList := [v,:typeList] where v ==
159        categoryForm?(m) =>
160          m := evaluateType MSUBSTQ(x,'_$,m)
161          evalCategory(x' := (evaluateType x), m) => x'
162          throwEvalTypeMsg("S2IE0004",[form])
163        m := evaluateType m
164        GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and
165            (tree := mkAtree x) and  putTarget(tree,m) and ((bottomUp tree) is [m1]) =>
166                [zt,:zv]:= z1:= getAndEvalConstructorArgument tree
167                (v1 := coerceOrRetract(z1, m)) => objValUnwrap v1
168                throwKeyedMsgCannotCoerceWithValue(zv,zt,m)
169        throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form])
170    [op,:NREVERSE typeList]
171  throwEvalTypeMsg("S2IE0007",[op])
172
173throwEvalTypeMsg(msg, args) ==
174  $justUnparseType : local := true
175  $noEvalTypeMsg => spadThrow()
176  throwKeyedMsg(msg, args)
177
178makeOrdinal i ==
179  ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1)
180
181evaluateSignature sig ==
182  -- calls evaluateType on a signature
183  sig is [ ='SIGNATURE,fun,sigl] =>
184    ['SIGNATURE,fun,
185      [(t = '_$ => t; evaluateType(t)) for t in sigl]]
186  sig
187
188--% Code Evaluation
189
190-- This code generates, then evaluates code during the bottom up phase
191-- of interpretation
192
193splitIntoBlocksOf200 a ==
194  null a => nil
195  [[first (r:=x) for x in tails a for i in 1..200],
196    :splitIntoBlocksOf200 rest r]
197
198evalForm(op,opName,argl,mmS) ==
199  -- applies the first applicable function
200
201  for mm in mmS until form repeat
202    [sig,fun,cond]:= mm
203    (CAR sig) = 'interpOnly => form := CAR sig
204    #argl ~= #CDDR sig => 'skip ---> RDJ 6/95
205    form:=
206      $genValue or null cond =>
207        [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL
208         for x in argl for t in CDDR sig]
209      [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL
210        for x in argl for t in CDDR sig for c in cond]
211    form or null argl =>
212      dc:= CAR sig
213      form :=
214        dc='local => --[fun,:form]
215          atom fun =>
216            fun in $localVars => ['SPADCALL,:form,fun]
217            [fun,:form,NIL]
218          ['SPADCALL,:form,fun]
219        dc is ["__FreeFunction__",:freeFun] =>
220          ['SPADCALL,:form,freeFun]
221        fun is ['XLAM,xargs,:xbody] =>
222          rec :=  first form
223          xbody is [['RECORDELT,.,ind,len]] =>
224            optRECORDELT([CAAR xbody,rec,ind,len])
225          xbody is [['SETRECORDELT,.,ind,len,.]] =>
226            optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form])
227          xbody is [['RECORDCOPY,.,len]] =>
228            optRECORDCOPY([CAAR xbody,rec,len])
229          ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)]
230        dcVector := evalDomain dc
231        fun0 := NRTcompileEvalForm(opName,fun,dcVector)
232        null fun0 => throwKeyedMsg("S2IE0008",[opName])
233        [bpi,:domain] := fun0
234        EQ(bpi,function Undef) =>
235         sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig])
236         NIL
237        if $NRTmonitorIfTrue = true then
238          sayBrightlyNT ['"Applying ",first fun0,'" to:"]
239          pp [devaluateDeeply x for x in form]
240        _$:fluid := domain
241        ['SPADCALL, :form, fun0]
242  not form => nil
243--  not form => throwKeyedMsg("S2IE0008",[opName])
244  form='interpOnly => rewriteMap(op,opName,argl)
245  targetType := CADR sig
246  if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType
247  evalFormMkValue(op,form,targetType)
248
249sideEffectedArg?(t,sig,opName) ==
250  opString := SYMBOL_-NAME opName
251  (opName ~= "setelt!") and (ELT(opString, #opString-1) ~= char '_!) => nil
252  dc := first sig
253  t = dc
254
255getArgValue(a, t) ==
256  atom a and not VECP a =>
257    t' := coerceOrRetract(getBasicObject a,t)
258    t' and wrapped2Quote objVal t'
259  v := getArgValue1(a, t) => v
260  alt := altTypeOf(objMode getValue a, a, nil) =>
261    t' := coerceInt(getValue a, alt)
262    t' := coerceOrRetract(t',t)
263    t' and wrapped2Quote objVal t'
264  nil
265
266getArgValue1(a,t) ==
267  -- creates a value for a, coercing to t
268  t' := getValue(a) =>
269    (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and
270      objValUnwrap(t') is ['SPADMAP, :.] =>
271        getMappingArgValue(a,t,m)
272    t' := coerceOrRetract(t',t)
273    t' and wrapped2Quote objVal t'
274  systemErrorHere '"getArgValue"
275
276getArgValue2(a,t,se?,opName) ==
277  se? and (objMode(getValue a) ~= t) =>
278    throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t])
279  getArgValue(a,t)
280
281getArgValueOrThrow(x, type) ==
282  getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type])
283
284getMappingArgValue(a,t,m is ['Mapping,:ml]) ==
285  (una := getUnname a) in $localVars =>
286    $genValue =>
287      name := get(una,'name,$env)
288      a.0 := name
289      mmS := selectLocalMms(a,name,rest ml, nil)
290      or/[mm for mm in mmS |
291        (mm is [[., :ml1],oldName,:.] and ml=ml1)] =>
292            MKQ [COERCE(oldName, 'FUNCTION)]
293      NIL
294    una
295  mmS := selectLocalMms(a,una,rest ml, nil)
296  or/[mm for mm in mmS |
297    (mm is [[., :ml1],oldName,:.] and ml=ml1)] =>
298        MKQ [COERCE(oldName, 'FUNCTION)]
299  NIL
300
301getArgValueComp2(arg, type, cond, se?, opName) ==
302  se? and (objMode(getValue arg) ~= type) =>
303    throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type])
304  getArgValueComp(arg, type, cond)
305
306getArgValueComp(arg,type,cond) ==
307  -- getArgValue for compiled case.  if there is a condition then
308  --  v must be data to verify that coerceInteractive succeeds.
309  v:= getArgValue(arg,type)
310  null v => nil
311  null cond => v
312  v is ['QUOTE,:.] or getBasicMode v => v
313  n := getUnnameIfCan arg
314  if num := isSharpVarWithNum n then
315    not $compilingMap => n := 'unknownVar
316    alias := get($mapName,'alias,$e)
317    n := alias.(num - 1)
318  keyedMsgCompFailure("S2IE0010",[n])
319
320evalFormMkValue(op,form,tm) ==
321  val:=
322    u:=
323      $genValue => wrap timedEVALFUN form
324      form
325    objNew(u,tm)
326--+
327  if $NRTmonitorIfTrue = true then
328    sayBrightlyNT ['"Value of ",op.0,'" ===> "]
329    pp unwrap u
330  putValue(op,val)
331  [tm]
332
333--% Some Antique Comments About the Interpreter
334
335--EVAL BOOT contains the top level interface to the Scratchhpad-II
336--interpreter.  The Entry point into the interpreter from the parser is
337--processInteractive.
338--the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT.
339--
340--Conventions:
341--    All spad values in the interpreter are passed around in triples.
342--    These are lists of three items: [value,mode,environment].  The value
343--    may be wrapped (this is a pair whose CAR is the atom WRAPPED and
344--    whose CDR is the value), which indicates that it is a real value,
345--    or unwrapped in which case it needs to be EVALed to produce the
346--    proper value.  The mode is the type of value, and should always be
347--    completely specified (not contain $EmptyMode).  The environment
348--    is always empty, and is included for historical reasons.
349--
350--Modemaps:
351--    Modemaps are descriptions of compiled Spad function which the
352--    interpreter uses to perform type analysis. They consist of patterns
353--    of types for the arguments, and conditions the types must satisfy
354--    for the function to apply.  For each function name there is a list
355--    of modemaps in file MODEMAP DATABASE for each distinct function with
356--    that name. The following is the list of the modemaps for "*"
357--    (multiplication. The first modemap (the one with the labels) is for
358--    module mltiplication which is multiplication of an element of a
359--    module by a member of its scalar domain.
360--
361--   This is the signature pattern for the modemap, it is of the form:
362--    (DomainOfComputation TargetType <ArgumentType ...>)
363--          |
364--          |                This is the predicate that needs to be
365--          |                 satisfied for the modemap to apply
366--          |                            |
367--          V                            |
368--     /-----------/                     |
369-- ( ( (*1 *1 *2 *1)                     V
370--       /-----------------------------------------------------------/
371--     ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) )
372--      . CATDEF) <-- This is the file where the function was defined
373--   ( (*1 *1 *2 *1)
374--     ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) )
375--      . CATDEF)
376--   ( (*1 *1 *2 *1)
377--     ( (AND
378--         (isDomain *2 (NonNegativeInteger))
379--         (ofCategory *1 (AbelianMonoid))) )
380--      . CATDEF)
381--   ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF)
382--      )
383--
384--Environments:
385--    Environments associate properties with atoms.
386--    (see CUTIL BOOT for the exact structure of environments).
387--    Some common properties are:
388-- modeSet:
389--    During interpretation we build a modeSet property for each node in
390--    the expression.  This is (in theory) a list of all the types
391--    possible for the node.  In the current implementation these
392--    modeSets always contain a single type.
393-- value:
394--    Value properties are always triples.  This is where the values of
395--    variables are stored.  We also build value properties for internal
396--    nodes during the bottom up phase.
397-- mode:
398--    This is the declared type of an identifier.
399--
400--  There are several different environments used in the interpreter:
401--    $InteractiveFrame : this is the environment where the user
402--     values are stored.  Any side effects of evaluation of a top-level
403--     expression are stored in this environment.  It is always used as
404--     the starting environment for interpretation.
405--    $e : This is the name used for $InteractiveFrame while interpreting.
406--    $env : This is local environment used by the interpreter.
407--     Only temporary information (such as types of local variables is
408--     stored in $env.
409--     It is thrown away after evaluation of each expression.
410--
411--Frequently used global variables:
412--    $genValue : if true then evaluate generated code, otherwise leave
413--      code unevaluated.  If $genValue is false then we are compiling.
414--    $op: name of the top level operator (unused except in map printing)
415--    $mapList:  list of maps being type analyzed, used in recursive
416--               map type analysis.
417--    $compilingMap: true when compiling a map, used to detect where to
418--                   THROW when interpret-only is invoked
419--    $compilingLoop: true when compiling a loop body, used to control
420--                    nesting level of interp-only loop CATCH points
421--    $interpOnly: true when in interpret only mode, used to call
422--                 alternate forms of COLLECT and REPEAT.
423--    $inCOLLECT: true when compiling a COLLECT, used only for hacked
424--                stream compiler.
425--    $declaredMode: Weak type propagation for symbols, set in upCOERCE
426--                   and upLET.  This variable is used to determine
427--                   the alternate polynomial types of Symbols.
428--    $localVars: list of local variables in a map body
429--    $MapArgumentTypeList: hack for stream compilation
430