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-- Socket types.  This list must be consistent with the one in com.h
35DEFCONSTANT($SessionManager, 1)
36DEFCONSTANT($ViewportServer, 2)
37DEFCONSTANT($MenuServer, 3)
38DEFCONSTANT($SessionIO, 4)
39DEFCONSTANT($MessageServer, 5)
40DEFCONSTANT($InterpWindow, 6)
41DEFCONSTANT($KillSpad, 7)
42DEFCONSTANT($DebugWindow, 8)
43DEFCONSTANT($Forker, 9)
44
45-- Session Manager action requests
46DEFCONSTANT($CreateFrame, 1)
47DEFCONSTANT($SwitchFrames, 2)
48DEFCONSTANT($EndOfOutput, 3)
49DEFCONSTANT($CallInterp, 4)
50DEFCONSTANT($EndSession, 5)
51DEFCONSTANT($LispCommand, 6)
52DEFCONSTANT($SpadCommand, 7)
53DEFCONSTANT($SendXEventToHyperTeX, 8)
54DEFCONSTANT($QuietSpadCommand, 9)
55DEFCONSTANT($CloseClient, 10)
56DEFCONSTANT($QueryClients, 11)
57DEFCONSTANT($QuerySpad, 12)
58DEFCONSTANT($NonSmanSession, 13)
59DEFCONSTANT($KillLispSystem, 14)
60
61DEFCONSTANT($CreateFrameAnswer, 50)
62
63-- Scratchpad-II server
64
65-- Assoc list of interpreter frame names and unique integer identifiers
66
67DEFPARAMETER($frameAlist, nil)
68DEFPARAMETER($frameNumber, 0)
69DEFPARAMETER($currentFrameNum, 0)
70DEFPARAMETER($EndServerSession, false)
71DEFPARAMETER($NeedToSignalSessionManager, false)
72
73serverReadLine(stream) ==
74-- used in place of read_-line in a scratchpad server system.
75  FORCE_-OUTPUT()
76  not $SpadServer =>
77      read_line(stream)
78  _*EOF_*: fluid := NIL
79  line :=
80   while not $EndServerSession and not _*EOF_* repeat
81    if $NeedToSignalSessionManager then
82      sockSendInt($SessionManager, $EndOfOutput)
83    $NeedToSignalSessionManager := false
84    action := serverSwitch()
85    action = $CallInterp =>
86      l := read_line(stream)
87      $NeedToSignalSessionManager := true
88      return l
89    action = $CreateFrame =>
90      frameName := GENTEMP('"frame")
91      addNewInterpreterFrame(frameName)
92      $frameAlist := [[$frameNumber,:frameName], :$frameAlist]
93      $currentFrameNum := $frameNumber
94      sockSendInt($SessionManager, $CreateFrameAnswer)
95      sockSendInt($SessionManager, $frameNumber)
96      $frameNumber := $frameNumber + 1
97--  MRX I'm not sure whether I should call ioHook("startPrompt")/ioHook("endOfPrompt") here
98      sockSendString($SessionManager, MKPROMPT())
99    action = $SwitchFrames =>
100      $currentFrameNum := sockGetInt($SessionManager)
101      currentFrame := LASSOC($currentFrameNum, $frameAlist)
102      changeToNamedInterpreterFrame currentFrame
103    action = $EndSession =>
104      $EndServerSession := true
105    action = $LispCommand =>
106      $NeedToSignalSessionManager := true
107      stringBuf := sockGetStringFrom($MenuServer)
108      form := unescapeStringsInForm READ_-FROM_-STRING stringBuf
109      protectedEVAL form
110    action = $QuietSpadCommand =>
111      $NeedToSignalSessionManager := true
112      executeQuietCommand()
113    action = $SpadCommand =>
114      $NeedToSignalSessionManager := true
115      stringBuf := sockGetStringFrom($MenuServer)
116      CATCH('coerceFailure, CATCH('top_level, CATCH('SPAD_READER,
117        parseAndInterpret stringBuf)))
118--  MRX I'm not sure whether I should call ioHook("startPrompt")/ioHook("endOfPrompt") here
119      princPrompt()
120      FORCE_-OUTPUT()
121    action = $NonSmanSession =>
122      $SpadServer := nil
123    action = $KillLispSystem =>
124      QUIT()
125    NIL
126  line => line
127  ""
128
129parseAndInterpret str ==
130  $InteractiveMode :fluid := true
131  $e:fluid := $InteractiveFrame
132  ncParseAndInterpretString str
133
134executeQuietCommand() ==
135  $QuietCommand: fluid := true
136  sockGetStringFrom($MenuServer)
137  CATCH('coerceFailure, CATCH('top_level, CATCH('SPAD_READER,
138    parseAndInterpret stringBuf)))
139
140parseAndEvalToHypertex str ==
141  lines := parseAndEvalToStringEqNum(str)
142  len := LENGTH lines
143  sockSendInt($MenuServer, len)
144  for s in lines repeat
145    sockSendString($MenuServer, s)
146
147parseAndEvalToString str ==
148  $collectOutput:local := true
149  $outputLines: local := nil
150  $IOindex: local := nil
151  v := CATCH('SPAD_READER, CATCH('top_level, parseAndEvalStr str))
152  v = 'restart => ['"error"]
153  NREVERSE $outputLines
154
155parseAndEvalToStringEqNum str ==
156  $collectOutput:local := true
157  $outputLines: local := nil
158  v := CATCH('SPAD_READER, CATCH('top_level, parseAndEvalStr str))
159  v = 'restart => ['"error"]
160  NREVERSE $outputLines
161
162parseAndInterpToString str ==
163  v := applyWithOutputToString('parseAndEvalStr, [str])
164  breakIntoLines rest v
165
166parseAndEvalStr string ==
167  $InteractiveMode :fluid := true
168  $e:fluid := $InteractiveFrame
169  parseAndEvalStr1 string
170
171parseAndEvalStr1 string ==
172  string.0 = char '")" =>
173    doSystemCommand SUBSEQ(string, 1)
174  sform := ncParseFromString string
175  $QuietCommand : local := $QuietCommand_tmp
176  processInteractive(sform, NIL)
177
178protectedEVAL x ==
179  error := true
180  val := NIL
181  UNWIND_-PROTECT((val := EVAL x; error := NIL),
182                   error => (resetStackLimits(); sendHTErrorSignal()))
183  val
184