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