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 33)if false 34[[intloopReadConsole]] 35is the top level loop when reading from the input console. 36Normally we never really exit this function. 37 38We read a string from the input. The serverReadLine\cite{1} function 39is a special readline function that handles communication with the 40session manager code, which is a separate process running in parallel. 41In the usual case it just returns the current string. 42 43If the user enters a blank line ([[#a=]]) then just put up another prompt 44and iterate. 45 46If the user has set [[$DALYMODE]] to true and the new line starts with 47an open parenthesis then the input is assumed to be a lisp expression 48and is evaluated by the underlying common lisp. This is useful if you 49are doing a lot of debugging. Commands can also be executed in the 50underlying common lisp by using the [[)lisp]] command. 51 52If the user typed [[)fin]] then we exit the loop and drop into the 53underlying common lisp. You can use the [[(restart)]] function call 54to return to the top level loop. 55 56If the input line starts with a close parenthesis we parse the 57input line as a command rather than an expression. We execute the command 58and iterate. 59 60If the input line contains a trailing underscore, which is the standard 61end-of-line escape character, then we continue to read the line by 62iterating. 63 64If none of the above conditions occur we simply evaluate the input line 65and iterate. 66)endif 67 68)package "BOOT" 69 70-- User function to call when performing interactive input or output. 71 72-- $ioHook receives two arguments, namely a symbol identifying current i/o 73-- event, and a list (or nil) containing optional arguments, depending on the 74-- event. 75 76-- One possible way to use it is: 77-- )lisp (setf |$ioHook| (lambda (x arg) (format t "<~S>~%" x))) 78 79DEFPARAMETER($ioHook, nil) 80DEFPARAMETER($erMsgToss, false) 81 82ioHook(x, :args) == 83 if $ioHook then FUNCALL($ioHook, x, args) 84 85--% INTERPRETER TOP LEVEL 86 87-- Variables to control phases and their output 88 89$ncmMacro := NIL 90$ncmPhase := NIL 91 92evalInlineCode() == 93 args := getCLArgs() 94 while args repeat 95 arg := first args 96 args := rest args 97 if arg = '"-eval" and args then 98 CATCH('SPAD_READER, CATCH('top_level, parseAndEvalStr first(args))) 99 args := rest args 100 101spad() == 102 -- starts the interpreter, read in profiles, etc. 103 $PrintCompilerMessageIfTrue: local 104 setOutputAlgebra "%initialize%" 105 readSpadProfileIfThere() 106 evalInlineCode() 107 runspad() 108 'EndOfSpad 109 110runspad() == 111 mode:='restart 112 while mode='restart repeat 113 resetStackLimits() 114 CATCH('coerceFailure, 115 mode:=CATCH('top_level, ncTopLevel())) 116 117ncTopLevel() == 118-- Top-level read-parse-eval-print loop for the interpreter. Uses 119-- the Bill Burge's parser. 120 _*EOF_*: fluid := NIL 121 $InteractiveMode :fluid := true 122 $e:fluid := $InteractiveFrame 123 int_loop() 124 125++ If the interpreter is spawn by the session manager, then 126++ each successful connection also creates its own frame. 127++ In particular, the only time we get to do anything in the `initial' 128++ frame is when we get the first connection. In that case, we would 129++ be asked by the session manager to create a frame. The client is 130++ not aware of that, It is therefore confusing to display a prompt, 131++ because all this horse-threading happens behind the client's back. 132printFirstPrompt?() == 133 $interpreterFrameName ~= "initial" or not($SpadServer) 134 135 136int_loop () == 137 mode := "restart" 138 while mode = "restart" repeat 139 resetStackLimits() 140 mode := CATCH("top_level", 141 SpadInterpretStream(1, [], true)) 142 143 144SpadInterpretStream(step_num, source, interactive?) == 145 pile? := not interactive? 146 147 $newcompErrorCount: local := 0 -- SMW Feb 2/90. 148 -- Used in highComplete, ncHardError etc. 149 150 $inclAssertions: local := ["AIX", "CommonLisp"] -- Jan 28/90 151 152 153 $lastPos : local := $nopos ------------>!!! 154 $erMsgToss : local := false --------------->!!! 155 $ncMsgList : local := nil 156 157 interactive? => 158 if printFirstPrompt?() then 159 princPrompt() 160 intloopReadConsole([], step_num) 161 [] 162 intloopInclude (source,0) 163 [] 164 165 ----------------------------------------------------------------- 166 167ncINTERPFILE(file, echo) == 168 $EchoLines : local := echo 169 $ReadingFile : local := true 170 SpadInterpretStream(1, file, false) 171 172setCurrentLine s == 173 v := $currentLine 174 $currentLine := 175 NULL(v) => s 176 u := 177 STRINGP(s) => [s] 178 s 179 STRINGP(v) => [v, :u] 180 RPLACD(LASTNODE(v), u) 181 v 182 183intloopReadConsole(b, n)== 184 repeat 185 ioHook("startReadLine") 186 a := serverReadLine(_*STANDARD_-INPUT_*) 187 ioHook("endOfReadLine") 188 not STRINGP a => leaveScratchpad() 189 b = [] and #a=0 => 190 princPrompt() 191 $DALYMODE and intloopPrefix?('"(",a) => 192 intnplisp(a) 193 princPrompt() 194 pfx := stripSpaces intloopPrefix?('")fi",a) 195 pfx and ((pfx = '")fi") or (pfx = '")fin")) => return [] 196 b = [] and (d := intloopPrefix?('")", a)) => 197 setCurrentLine d 198 n := ncloopCommand(d, n) 199 princPrompt() 200 b := CONS(a, b) 201 ncloopEscaped a => "iterate" 202 n := intloopProcessStrings(nreverse b, n) 203 princPrompt() 204 b := [] 205 206-- The 'intloopPrefix?' function tests if the string 'prefix' is 207-- is a prefix of the string 'whole', ignoring leading whitespace. 208intloopPrefix?(prefix,whole) == 209 #prefix > #whole => false 210 good := true 211 leading := true 212 spaces := 0 213 i := 0 214 len := #prefix 215 wlen := #whole 216 for j in 0.. while (good and i < len and j < wlen) repeat 217 good := (prefix.i = whole.j) or (leading and (whole.j = char " ")) 218 if prefix.i = whole.j then i := i+1 219 if (whole.j = char " ") and leading then 220 spaces := spaces + 1 221 else leading := false 222 spaces = wlen => nil 223 if good then SUBSTRING(whole,spaces,nil) else good 224 225 226intloopProcess(n,interactive,s)== 227 StreamNull s => n 228 [lines, ptree] := first s 229 pfAbSynOp?(ptree,"command")=> 230 if interactive then setCurrentLine tokPart ptree 231 InterpExecuteSpadSystemCommand(tokPart ptree) 232 intloopProcess(n, interactive, rest s) 233 intloopProcess(intloopSpadProcess(n, lines, ptree, interactive), 234 interactive, rest s) 235 236intloopEchoParse s== 237 [dq, stream] := first s 238 [lines, restl] := ncloopDQlines(dq, $lines) 239 setCurrentLine(mkLineList(lines)) 240 if $EchoLines then ncloopPrintLines lines 241 $lines := restl 242 cons([[lines, npParse dqToList dq]], rest s) 243 244intloopInclude0(st, name, n) == 245 $lines:local:=incStream(st,name) 246 intloopProcess(n,false, 247 next(function intloopEchoParse, 248 next(function insertpile, 249 next(function lineoftoks,$lines)))) 250 251intloopInclude(name, n) == 252 handle_input_file(name, function intloopInclude0, [name, n]) 253 or error('"File not found") 254 255fakepile(s) == 256 if npNull s then [false, 0, [], s] 257 else 258 [h, t] := [car s, cdr s] 259 ss := cdr(h) 260 ress := car h 261 while not npNull t repeat 262 h := car (car t) 263 t := cdr t 264 ress := dqAppend(ress, h) 265 cons([[ress, :ss]], t) 266 267intloopProcessStrings(s, n) == 268 setCurrentLine s 269 intloopProcess(n, true, 270 next(function ncloopParse, 271 next(function fakepile, 272 next(function lineoftoks, incStrings s)))) 273 274$pfMacros := [] 275 276clearMacroTable() == 277 SETF($pfMacros, nil) 278 279getParserMacros() == $pfMacros 280 281displayParserMacro m == 282 m := ASSQ(m, $pfMacros) 283 NULL m => nil 284 pfPrintSrcLines(CADDR(m)) 285 286intSetNeedToSignalSessionManager() == 287 $NeedToSignalSessionManager := true 288 289intloopSpadProcess(stepNo,lines,ptree,interactive?)== 290 $stepNo:local := stepNo 291 $currentCarrier := cc := ['carrier] 292 ncPutQ(cc, 'stepNumber, stepNo) 293 ncPutQ(cc, 'messages, $ncMsgList) 294 ncPutQ(cc, 'lines, lines) 295 $ncMsgList := nil 296 result := CATCH("SpadCompileItem", 297 CATCH("coerceFailure", CATCH("SPAD_READER", 298 interp(cc, ptree, interactive?)))) where 299 300 interp(cc, ptree, interactive?) == 301 ncConversationPhase(function phParse, [cc, ptree]) 302 ncConversationPhase(function phMacro, [cc]) 303 ncConversationPhase(function phIntReportMsgs,[cc, interactive?]) 304 ncConversationPhase(function phInterpret, [cc]) 305 306 #ncEltQ(cc, 'messages) ~= 0 => ncError() 307 308 intSetNeedToSignalSessionManager() 309 $prevCarrier := $currentCarrier 310 result = 'ncEnd => stepNo 311 result = 'ncError => stepNo 312 result = 'ncEndItem => stepNo 313 stepNo+1 314 315phInterpret carrier == 316 ptree := ncEltQ(carrier, 'ptree) 317 val := intInterpretPform(ptree) 318 ncPutQ(carrier, 'value, val) 319 320intInterpretPform pf == 321 sform := pf2Sex(pf) 322 $QuietCommand : local := $QuietCommand_tmp 323 processInteractive(sform, pf) 324 325--% phReportMsgs: carrier[lines,messages,..]-> carrier[lines,messages,..] 326phIntReportMsgs(carrier, interactive?) == 327 $erMsgToss => 'OK 328 lines := ncEltQ(carrier, 'lines) 329 msgs := ncEltQ(carrier, 'messages) 330 nerr := #msgs 331 ncPutQ(carrier, 'ok?, nerr = 0) 332 nerr = 0 => 'OK 333 processMsgList(msgs, lines) 334 intSayKeyedMsg ('S2CTP010,[nerr]) 335 'OK 336 337intSayKeyedMsg(key, args) == 338 sayKeyedMsg(key, args) 339 340mkLineList lines == 341 l := [rest line for line in lines | nonBlank rest line] 342 #l = 1 => first l 343 l 344 345nonBlank str == 346 value := false 347 for i in 0..MAXINDEX str repeat 348 str.i ~= char " " => 349 value := true 350 return value 351 value 352 353ncloopCommand (line,n) == 354 InterpExecuteSpadSystemCommand(line) 355 n 356 357ncloopEscaped x == #x > 0 and x.(#x - 1) = '"__".0 358 359ncloopDQlines (dq,stream)== 360 StreamNull stream 361 a:= poGlobalLinePosn tokPosn CADR dq 362 b:= poGlobalLinePosn CAAR stream 363 streamChop (a-b+1,stream) 364 365streamChop(n,s)== 366 if StreamNull s 367 then [nil,nil] 368 else if EQL(n,0) 369 then [nil,s] 370 else 371 [a,b]:= streamChop(n-1,cdr s) 372 line:=car s 373 c := ncloopPrefix?('")command", rest line) 374 d:= cons(car line,if c then c else cdr line) 375 [cons(d,a),b] 376 377ncloopPrintLines lines == 378 for line in lines repeat WRITE_-LINE rest line 379 WRITE_-LINE '" " 380 381ncloopIncFileName string== 382 fn := incFileName string 383 not fn => 384 WRITE_-LINE (CONCAT(string, '" not found")) 385 [] 386 fn 387 388ncloopParse s== 389 [dq, stream] := first s 390 [lines, .] := ncloopDQlines(dq, stream) 391 cons([[lines, npParse dqToList dq]], rest s) 392 393incString s== incRenumber incLude(0,[s],0,['"strings"] ,[Top]) 394 395incStrings(s) == incRenumber incLude(0, s, 0, ['"strings"], [Top]) 396 397ncError() == 398 THROW("SpadCompileItem",'ncError) 399 400--% Compilation Carriers 401-- This data structure is used to carry information between phases. 402 403--% phParse: carrier[tokens,...] -> carrier[ptree, tokens,...] 404phParse(carrier,ptree) == 405 phBegin 'Parsing 406 ncPutQ(carrier, 'ptree, ptree) 407 'OK 408 409 410--% phMacro: carrier[ptree,...] -> carrier[ptree, ptreePremacro,...] 411phMacro carrier == 412 phBegin 'Macroing 413 ptree := ncEltQ(carrier, 'ptree) 414 ncPutQ(carrier, 'ptreePremacro, ptree) 415 416 ptree := macroExpanded ptree 417 if $ncmMacro then 418 intSayKeyedMsg ('S2CTP007,[%pform ptree] ) 419 420 ncPutQ(carrier, 'ptree, ptree) 421 'OK 422 423ncConversationPhase(fn, args) == 424 carrier := first args 425 426 $ncMsgList: local := [] 427 $convPhase: local := 'NoPhase 428 429 UNWIND_-PROTECT( APPLY(fn, args), wrapup(carrier) ) where 430 wrapup(carrier) == 431 for m in $ncMsgList repeat 432 ncPutQ(carrier, 'messages, [m, :ncEltQ(carrier, 'messages)]) 433 434ncloopPrefix?(prefix,whole) == 435 #prefix > #whole => false 436 good:=true 437 for i in 0..#prefix-1 for j in 0.. while good repeat 438 good:= prefix.i = whole.j 439 if good then SUBSTRING(whole,#prefix,nil) else good 440 441phBegin id == 442 $convPhase := id 443 if $ncmPhase then intSayKeyedMsg('S2CTP021,[id]) 444