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-- This file contains the top-most code for receiving parser output,
35-- calling the analysis routines and printing the result output. It
36-- also contains several flavors of routines that start the interpreter
37-- from LISP.
38
39
40--% Top Level Interpreter Code
41
42-- When $QuiteCommand is true Spad will not produce any output from
43--  a top level command
44DEFPARAMETER($QuietCommand, NIL)
45-- When $ProcessInteractiveValue is true, we don't want the value printed
46-- or recorded.
47DEFPARAMETER($ProcessInteractiveValue, NIL)
48
49DEFPARAMETER($QuietCommand_tmp, nil)
50intSetQuiet() ==
51  $QuietCommand_tmp := true
52
53intUnsetQuiet() ==
54  $QuietCommand_tmp := nil
55
56--% Starting the interpreter from LISP
57
58interpsysInitialization() ==
59  -- The function  start  begins the interpreter process, reading in
60  -- the profile and printing start-up messages.
61  $PrintCompilerMessageIfTrue: local := nil
62  resetWorkspaceVariables()
63  initHist()
64  initNewWorld()
65  compressOpen()
66  interpOpen()
67  createInitializers()
68  if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"interpreter"])
69  initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses)
70  statisticsInitialization()
71  $InteractiveFrame := makeInitialModemapFrame()
72  initializeSystemCommands()
73  initializeInterpreterFrameRing()
74  setOutputAlgebra "%initialize%"
75  loadExposureGroupData()
76  if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"database"])
77  mkLowerCaseConTable()
78  if not $ruleSetsInitialized then initializeRuleSets()
79  if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"constructors"])
80  makeConstructorsAutoLoad()
81  GCMSG(NIL)
82  SETQ($IOindex,1)
83  if $displayStartMsgs then sayKeyedMsg("S2IZ0053",['"history"])
84  initHist()
85  if $displayStartMsgs then spadStartUpMsgs()
86  $superHash := MAKE_HASHTABLE('UEQUAL)
87
88interpsys_restart() ==
89  $IOindex := 1
90  $InteractiveFrame := makeInitialModemapFrame()
91  loadExposureGroupData()
92  statisticsInitialization()
93  initHist()
94  initializeInterpreterFrameRing()
95
96  if $displayStartMsgs then spadStartUpMsgs()
97  $currentLine := nil
98  compressOpen() -- set up the compression tables
99  interpOpen() -- open up the interpreter database
100  operationOpen() -- all of the operations known to the system
101  categoryOpen() -- answer hasCategory question
102  browseOpen()
103  makeConstructorsAutoLoad()
104  createInitializers2()
105
106readSpadProfileIfThere() ==
107  -- reads SPADPROF INPUT if it exists
108  file := getEnv('"FRICAS_INITFILE")
109  file = '"" => nil
110  efile :=
111    make_input_filename(file) => file
112    file := ['_.fricas, 'input]
113    make_input_filename(file) => file
114    file := ['_.axiom, 'input]
115    make_input_filename(file) => file
116    NIL
117  efile =>
118    $edit_file := efile
119    read_or_compile(true, false)
120  NIL
121
122--% Parser Output --> Interpreter
123
124DEFPARAMETER($inRetract, nil)
125
126processInteractive(form, posnForm) ==
127  --  Top-level dispatcher for the interpreter.  It sets local variables
128  --  and then calls processInteractive1 to do most of the work.
129  --  This function receives the output from the parser.
130
131  initializeTimedNames($interpreterTimedNames,$interpreterTimedClasses)
132
133  $op: local:= (form is [op,:.] => op; form) --name of operator
134  $Coerce: local := NIL
135  $compErrorMessageStack:local := nil
136  $freeVars : local := NIL
137  $mapList:local := NIL            --list of maps being type analyzed
138  $compilingMap:local:= NIL        --true when compiling a map
139  $compilingLoop:local:= NIL       --true when compiling a loop body
140  $interpOnly: local := NIL        --true when in interpret only mode
141  $whereCacheList: local := NIL    --maps compiled because of where
142  $timeGlobalName: local := '$compTimeSum  --see incrementTimeSum
143  $declaredMode: local := NIL      --Weak type propagation for symbols
144  $localVars:local := NIL          --list of local variables in function
145  $analyzingMapList:local := NIL   --names of maps currently being
146                                   --analyzed
147  $instantCoerceCount: local := 0
148  $instantCanCoerceCount: local := 0
149  $instantMmCondCount: local := 0
150  $minivector: local := NIL
151  $domPvar: local := NIL
152  $inRetract: local := NIL
153  object := processInteractive1(form, posnForm)
154  if not($ProcessInteractiveValue) then
155    if $reportInstantiations = true then
156      reportInstantiations()
157      CLRHASH $instantRecord
158    writeHistModesAndValues()
159    updateHist()
160  object
161
162processInteractive1(form, posnForm) ==
163  -- calls the analysis and output printing routines
164  $e : local := $InteractiveFrame
165  recordFrame 'system
166
167  startTimingProcess 'analysis
168  object   := interpretTopLevel(form, posnForm)
169  stopTimingProcess 'analysis
170
171  startTimingProcess 'print
172  if not($ProcessInteractiveValue) then
173    recordAndPrint(objValUnwrap object,objMode object)
174  recordFrame 'normal
175  stopTimingProcess 'print
176
177  object
178
179ncParseAndInterpretString s ==
180   processInteractive(parseFromString(s), nil)
181
182--% Result Output Printing
183
184recordAndPrint(x,md) ==
185  --  Prints out the value x which is of type m, and records the changes
186  --  in environment $e into $InteractiveFrame
187  --  $printAnyIfTrue  is documented in setvart.boot. controlled with )se me any
188  if md = '(Any) and $printAnyIfTrue  then
189    md' := first  x
190    x' := rest x
191  else
192    x' := x
193    md' := md
194  mode:= (md=$EmptyMode => quadSch(); md)
195  if (md ~= $Void) or $printVoidIfTrue then
196    if null $collectOutput then TERPRI(get_algebra_stream())
197    if $QuietCommand = false then
198      output(x',md')
199  putHist('%,'value,objNewWrap(x,md),$e)
200  if $printTimeIfTrue or $printTypeIfTrue then printTypeAndTime(x',md')
201  if $printStorageIfTrue then printStorage()
202  if $printStatisticsSummaryIfTrue then printStatisticsSummary()
203  'done
204
205printTypeAndTime(x,m) ==  --m is the mode/type of the result
206  printTypeAndTimeNormal(x, m)
207
208printTypeAndTimeNormal(x,m) ==
209  -- called only if either type or time is to be displayed
210  if m is ['Union, :argl] then
211    x' := retract(objNewWrap(x,m))
212    m' := objMode x'
213    m := ['Union, :[arg for arg in argl | sameUnionBranch(arg, m')], '"..."]
214  if $printTimeIfTrue then
215    timeString := makeLongTimeString($interpreterTimedNames,
216      $interpreterTimedClasses)
217  if $printTypeIfTrue then
218      type_string := outputDomainConstructor(m)
219  $printTimeIfTrue and $printTypeIfTrue =>
220    $collectOutput =>
221      $outputLines := [msgText("S2GL0012", [type_string]), :$outputLines]
222    sayKeyedMsg("S2GL0014", [type_string, timeString])
223  $printTimeIfTrue =>
224    $collectOutput => nil
225    sayKeyedMsg("S2GL0013",[timeString])
226  $printTypeIfTrue =>
227    $collectOutput =>
228        $outputLines :=
229            [justifyMyType msgText("S2GL0012", [type_string]), :$outputLines]
230    sayKeyedMsg("S2GL0012", [type_string])
231
232sameUnionBranch(uArg, m) ==
233  uArg is [":", ., t] => t = m
234  uArg = m
235
236msgText(key, args) ==
237  msg := segmentKeyedMsg getKeyedMsg key
238  msg := substituteSegmentedMsg(msg,args)
239  msg := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN)
240  concatenateStringList([STRINGIMAGE x for x in CDAR msg])
241
242justifyMyType(t) ==
243  len := #t
244  len > $LINELENGTH => t
245  CONCAT(fillerSpaces($LINELENGTH-len, '" "), t)
246
247typeTimePrin x ==
248  $highlightDelta: local:= 0
249  maprinSpecial(x,0,79)
250
251printStorage() ==
252  $collectOutput => nil
253  storeString :=
254    makeLongSpaceString($interpreterTimedNames, $interpreterTimedClasses)
255  sayKeyedMsg("S2GL0016",[storeString])
256
257printStatisticsSummary() ==
258  $collectOutput => nil
259  summary := statisticsSummary()
260  sayKeyedMsg("S2GL0017",[summary])
261
262--%  Interpreter Middle-Level Driver + Utilities
263
264interpretTopLevel(x, posnForm) ==
265  --  Top level entry point from processInteractive1.  Sets up catch
266  --  for a thrown result
267  savedTimerStack := COPY $timedNameStack
268  c := CATCH('interpreter,interpret(x, posnForm))
269  while savedTimerStack ~= $timedNameStack repeat
270    stopTimingProcess peekTimedName()
271  c = 'tryAgain => interpretTopLevel(x, posnForm)
272  c
273
274interpret(x, posnForm) ==
275  --type analyzes and evaluates expression x, returns object
276  $env:local := [[NIL]]
277  $genValue:local := true       --evaluate all generated code
278  -- counter used to limit recursion depth during resolve
279  $resolve_level : local := 0
280  interpret1(x,nil,posnForm)
281
282interpret1(x,rootMode,posnForm) ==
283  -- dispatcher for the type analysis routines.  type analyzes and
284  -- evaluates the expression x in the rootMode (if non-nil)
285  -- which may be $EmptyMode.  returns an object if evaluating, and a
286  -- modeset otherwise
287
288  -- create the attributed tree
289
290  node := mkAtreeWithSrcPos(x, posnForm)
291  if rootMode then putTarget(node,rootMode)
292
293  -- do type analysis and evaluation of expression.  The real guts
294
295  modeSet:= bottomUp node
296  newRootMode := (null rootMode => first modeSet ; rootMode)
297  argVal := getArgValue(node, newRootMode)
298  argVal and not $genValue => objNew(argVal, newRootMode)
299  argVal and (val:=getValue node) => interpret2(val,newRootMode,posnForm)
300  keyedSystemError("S2IS0053",[x])
301
302interpret2(object,m1,posnForm) ==
303  x := objVal object
304  m := objMode object
305  m=$EmptyMode =>
306    x is [op, :.]  and op in '(SPADMAP STREAM) => objNew(x, m1)
307    m1 = $EmptyMode => objNew(x,m)
308    systemErrorHere '"interpret2"
309  m1 =>
310    if (ans := coerceInteractive(object,m1)) then ans
311    else throwKeyedMsgCannotCoerceWithValue(x,m,m1)
312  object
313