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