source: trunk/lisp/lispm/ltop.lisp @ 229

Last change on this file since 229 was 229, checked in by rjs, 3 years ago

Update.

File size: 16.7 KB
Line 
1;;; -*-Mode:LISP; Package:SYSTEM-INTERNALS-*-
2;;; Initialization & top-level READ-EVAL-PRINT loop
3
4(DECLARE (SPECIAL ERROR-STACK-GROUP %ERROR-HANDLER-STACK-GROUP
5                  G P TRACE-LEVEL SYN-TERMINAL-IO + - * // ++ +++ ** ***
6                  INITIAL-READTABLE RUBOUT-HANDLER
7                  BUILD-INITIAL-OBARRAY-FLAG COLD-INITIALIZATION-LIST WARM-INITIALIZATION-LIST
8                  ONCE-ONLY-INITIALIZATION-LIST SYSTEM-INITIALIZATION-LIST
9                  LISP-TOP-LEVEL-INSIDE-EVAL TV:INITIAL-LISP-LISTENER))
10
11;Come here when machine starts.  Provides a base frame.
12(DEFUN LISP-TOP-LEVEL NIL
13  (LISP-REINITIALIZE NIL)                       ;(Re)Initialize critical variables and things
14  (LISP-TOP-LEVEL1 (OR TV:INITIAL-LISP-LISTENER TERMINAL-IO))
15  ;;Never returns
16  )
17
18;Called when the main process is reset.
19(DEFUN LISP-TOP-LEVEL2 ()
20  (LISP-TOP-LEVEL1 (OR TV:INITIAL-LISP-LISTENER TERMINAL-IO)))
21
22;Function to reset various things, do initialization that's inconvenient in cold load, etc.
23(DEFUN LISP-REINITIALIZE (&OPTIONAL (CALLED-BY-USER T))
24  (SETQ INHIBIT-SCHEDULING-FLAG T)              ;In case called by the user
25  (SETQ ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL)
26  (COND ((NOT CALLED-BY-USER)
27         (AND (FBOUNDP 'COMPILER:MA-RESET)      ;Unload microcompiled defs, because they are gone!
28             (COMPILER:MA-RESET))               ; Hopefully manage to do this before any gets called.
29         ;; Set up the TV sync program as soon as possible; until it is set up
30         ;; read references to the TV buffer can get NXM errors which cause a
31         ;; main-memory parity error halt.  Who-line updating can do this.
32         (AND (BOUNDP 'TV:DEFAULT-SCREEN) (SETUP-CPT))))
33  (OR (FBOUNDP 'INTERN) (FSET 'INTERN #'INTERN-OLD))
34  (OR (FBOUNDP 'FSET-CAREFULLY) (FSET 'FSET-CAREFULLY #'FSET-CAREFULLY-COLD-LOAD))
35  (SETQ DEFAULT-CONS-AREA WORKING-STORAGE-AREA) ;Reset default areas.
36  (AND (FBOUNDP 'NUMBER-GC-ON) (NUMBER-GC-ON))  ;This seems to work now, make it the default
37  (SETQ EH:CONDITION-HANDLERS NIL)
38  (COND ((NOT (BOUNDP 'BUILD-INITIAL-OBARRAY-FLAG))
39         (BUILD-INITIAL-OBARRAY)
40         (SETQ BUILD-INITIAL-OBARRAY-FLAG T)))
41
42  (COND ((NOT (BOUNDP 'CURRENT-PROCESS))        ;Very first time around
43         (SETQ SCHEDULER-EXISTS NIL
44               CURRENT-PROCESS NIL
45               TV:WHO-LINE-PROCESS NIL
46               TV:LAST-WHO-LINE-PROCESS NIL)
47         (OR (FBOUNDP 'TV:WHO-LINE-RUN-STATE-UPDATE)
48             (FSET 'TV:WHO-LINE-RUN-STATE-UPDATE #'(LAMBDA (&REST IGNORE) NIL)))
49         (KBD-INITIALIZE)))
50  (INITIALIZE-WIRED-KBD-BUFFER)
51
52  ;Get the right readtable.
53  (OR (BOUNDP 'INITIAL-READTABLE)
54      (SETQ INITIAL-READTABLE READTABLE))
55  (SETQ READTABLE INITIAL-READTABLE)
56
57  ;; Initialize the rubout handler.
58  (SETQ RUBOUT-HANDLER NIL)                     ;We're not in it now
59
60  ;; Initialize the error handler.
61  (OR (BOUNDP 'ERROR-STACK-GROUP)
62      (SETQ ERROR-STACK-GROUP (MAKE-STACK-GROUP 'ERROR-STACK-GROUP ':SAFE 0)))
63  (SETQ %ERROR-HANDLER-STACK-GROUP ERROR-STACK-GROUP)
64  (STACK-GROUP-PRESET ERROR-STACK-GROUP 'LISP-ERROR-HANDLER)    ;May not be defined yet
65  (SETF (SG-FOOTHOLD-DATA %INITIAL-STACK-GROUP) NIL)    ;EH depends on this
66  (AND (FBOUNDP 'LISP-ERROR-HANDLER)
67       (FUNCALL ERROR-STACK-GROUP '(INITIALIZE)))
68  (COND ((AND (BOUNDP '%INITIALLY-DISABLE-TRAPPING)
69              (NULL %INITIALLY-DISABLE-TRAPPING)
70              (FBOUNDP 'LISP-ERROR-HANDLER)
71              (FBOUNDP 'ENABLE-TRAPPING))
72         (ENABLE-TRAPPING)))
73  (SETQ EH:ERRSET-STATUS NIL)                   ;Turn off possible spurious errset
74
75  ;And all kinds of randomness...
76
77  (SETQ TRACE-LEVEL 0)
78  (SETQ INSIDE-TRACE NIL)
79  (SETQ G '?? P '??)
80  (SETQ + NIL * NIL - NIL ;In case of error during first read/eval/print cycle
81        // NIL ++ NIL +++ NIL ;or if their values were unprintable or obscene
82        ** NIL *** NIL)  ;and to get global values in case of break in a non-lisp-listener
83  (SETQ LISP-TOP-LEVEL-INSIDE-EVAL NIL)
84  (OR (BOUNDP 'PRIN1) (SETQ PRIN1 NIL))
85  (SETQ EVALHOOK NIL)
86  (FSET' EVAL (FUNCTION *EVAL))
87  (SETQ IBASE 8 BASE 8 *NOPOINT NIL)
88  (SETQ XR-CORRESPONDENCE-FLAG NIL              ;Prevent the reader from doing random things
89        XR-CORRESPONDENCE NIL)
90  (SETQ *RSET T)                                ;In case any MACLISP programs look at it
91  (SETQ PROGDESCLIST NIL RETPROGDESC NIL)
92  (SETQ SYS:UNDO-DECLARATIONS-FLAG NIL)         ;Don't get screwed by MACRO!
93  (SETQ FDEFINE-FILE-SYMBOL NIL)
94  (SETQ LOCAL-DECLARATIONS NIL FILE-LOCAL-DECLARATIONS NIL)
95  (SETQ COMPILER:QC-FILE-IN-PROGRESS NIL COMPILER:QC-FILE-READ-IN-PROGRESS NIL)
96  (AND (FBOUNDP 'PKG-FIND-PACKAGE)              ;If package system is present
97       (SETQ PACKAGE (PKG-FIND-PACKAGE "USER")))
98
99  ;; The first time, this does top-level SETQ's from the cold-load files
100  (AND (BOUNDP 'LISP-CRASH-LIST)
101       (MAPC (FUNCTION EVAL) LISP-CRASH-LIST))
102  (SETQ LISP-CRASH-LIST NIL)
103
104  ;Reattach IO streams.  Note that TERMINAL-IO will be fixed later to go to a window.
105  (OR (BOUNDP 'SYN-TERMINAL-IO) (SETQ SYN-TERMINAL-IO (MAKE-SYN-STREAM 'TERMINAL-IO)))
106  (OR CALLED-BY-USER
107      (SETQ TERMINAL-IO     COLD-LOAD-STREAM
108            STANDARD-OUTPUT SYN-TERMINAL-IO
109            STANDARD-INPUT  SYN-TERMINAL-IO
110            QUERY-IO        SYN-TERMINAL-IO
111            TRACE-OUTPUT    (MAKE-SYN-STREAM 'QUERY-IO)
112            ERROR-OUTPUT    TRACE-OUTPUT
113            ))
114
115  (SETQ TV:MOUSE-WINDOW NIL)  ;This gets looked at before the mouse process is turned on
116
117  ;; These are initializations that have to be done before other initializations
118  (INITIALIZATIONS 'SYSTEM-INITIALIZATION-LIST T)
119
120  (AND CURRENT-PROCESS
121       (FUNCALL CURRENT-PROCESS ':RUN-REASON 'LISP-INITIALIZE))
122
123  (INITIALIZATIONS 'COLD-INITIALIZATION-LIST)
124
125  (INITIALIZATIONS 'WARM-INITIALIZATION-LIST T)
126
127  (COND ((AND (FBOUNDP 'FORMAT) (FBOUNDP 'CHAOS:HOST-DATA))
128         (FORMAT T "~A~%" (CHAOS:HOST-DATA CHAOS:MY-ADDRESS)))
129        (T (PRINC "Lisp Machine cold load environment, beware!")))
130
131  ;; This process no longer needs to be able to run except for the usual reasons.
132  (COND ((FBOUNDP 'TV:WINDOW-INITIALIZE)
133         (MULTIPLE-VALUE-BIND (X Y)
134             (FUNCALL TERMINAL-IO ':READ-CURSORPOS)
135           (SETF (TV:SHEET-OUTPUT-HOLD-FLAG TV:INITIAL-LISP-LISTENER) 0)
136           (FUNCALL TV:INITIAL-LISP-LISTENER ':SET-CURSORPOS X Y)))
137        (T (SETQ TV:INITIAL-LISP-LISTENER NIL)))        ;Not created yet
138
139
140  (AND CURRENT-PROCESS
141       (FUNCALL CURRENT-PROCESS ':REVOKE-RUN-REASON 'LISP-INITIALIZE))
142
143  ;; The global value of TERMINAL-IO is a stream which goes to an auto-exposing
144  ;; window.  Some processes, such as Lisp listeners, rebind it to something else.
145  ;; CALLED-BY-USER is T if called from inside one of those.
146  (COND ((AND (NOT CALLED-BY-USER)
147              (FBOUNDP TV:DEFAULT-BACKGROUND-STREAM))
148         (SETQ TERMINAL-IO TV:DEFAULT-BACKGROUND-STREAM))))
149
150; The real top level.  Note that the stream to use is passed as an argument and
151; bound to the special variable TERMINAL-IO.
152(DEFUN LISP-TOP-LEVEL1 (TERMINAL-IO)
153  (DO ((*) (+) (-)      ;Bind these so that they are per-stack-group
154       (//) (++) (+++) (**) (***)
155       (THROW-FLAG))    ;Gets non-NIL if throw to TOP-LEVEL (e.g. quitting from an error)
156      (NIL)             ;Do forever
157    (MULTIPLE-VALUE (NIL THROW-FLAG)
158      (*CATCH 'TOP-LEVEL
159              (PROGN (TERPRI)
160                     (SETQ - (READ-FOR-TOP-LEVEL))
161                     (LET ((LISP-TOP-LEVEL-INSIDE-EVAL T))
162                       (SETQ // (MULTIPLE-VALUE-LIST (EVAL -))))
163                     (SETQ *** **       ;Save first value, propagate old saved values
164                           ** *
165                           * (CAR //))
166                     (DOLIST (VALUE //)
167                       (TERPRI)
168                       (FUNCALL (OR PRIN1 #'PRIN1) VALUE)))))
169    (AND THROW-FLAG (PRINT '*)) ;Signal return to top level
170    (SETQ +++ ++ ++ + + -)))                    ;Save last three input forms
171
172;Note that BREAK binds RUBOUT-HANDLER to NIL so that a new level of catch
173;will be established.  Before returning it clears the old rubout handler's buffer.
174;Changed 3/3/80 by Moon not to bind *, +, and -.
175(DEFUN BREAK (&QUOTE TAG &OPTIONAL &EVAL (CONDITIONAL T)
176              &AUX (RUBOUT-HANDLER NIL)
177                   (READ-PRESERVE-DELIMITERS NIL)
178                   ;Next line commented out since it causes more trouble in than out
179                   ;(IBASE 8) (BASE 8)
180                   (OLD-STANDARD-INPUT STANDARD-INPUT)
181                   (STANDARD-INPUT 'SI:TERMINAL-IO-SYN-STREAM)
182                   (STANDARD-OUTPUT 'SI:TERMINAL-IO-SYN-STREAM)
183                   (EH:ERRSET-STATUS NIL)       ;"Condition Wall" for errsets
184                   (EH:CONDITION-HANDLERS NIL)  ; and for conditions
185                   )
186  (COND (CONDITIONAL
187         ;; Deal with keyboard multiplexing in a way similar to the error-handler.
188         ;; If we break in the scheduler, set CURRENT-PROCESS to NIL.
189         ;; If this is not the scheduler process, make sure it has a run reason
190         ;; in case we broke in the middle of code manipulating process data.
191         ;; If INHIBIT-SCHEDULING-FLAG is set, turn it off and print a warning.
192         (COND ((EQ %CURRENT-STACK-GROUP SCHEDULER-STACK-GROUP)
193                (SETQ CURRENT-PROCESS NIL)))
194         (AND (NOT (NULL CURRENT-PROCESS))
195              (NULL (FUNCALL CURRENT-PROCESS ':RUN-REASONS))
196              (FUNCALL CURRENT-PROCESS ':RUN-REASON 'BREAK))
197         (COND (INHIBIT-SCHEDULING-FLAG
198                (FORMAT T "~%---> Turning off INHIBIT-SCHEDULING-FLAG, you may lose. <---~%")
199                (SETQ INHIBIT-SCHEDULING-FLAG NIL)))
200         (FORMAT T "~&;BKPT ~A~%" TAG)
201         (LET ((VALUE
202                 (DO ()
203                     (NIL)              ;Do forever (until explicit return)
204                   (TERPRI)
205                   (SETQ - (READ-FOR-TOP-LEVEL))
206                   (COND ((EQ - 'P)    ;Altmode-P proceeds from BREAK
207                          (RETURN NIL))
208                         ((AND (SYMBOLP -)
209                               (STRING-EQUAL - "’"))  ;so does Resume
210                          (RETURN NIL))
211                         ((EQ - 'G)    ;Altmode-G quits to top level (semi-obsolete)
212                          (*THROW 'TOP-LEVEL NIL))
213                         ((AND (LISTP -) (EQ (CAR -) 'RETURN))  ;(RETURN form) proceeds
214                          (RETURN (EVAL (CADR -)))))
215                   (SETQ // (MULTIPLE-VALUE-LIST (EVAL -)))
216                   (SETQ *** **
217                         ** *
218                         * (CAR //))    ;Save first value
219                   (DOLIST (VALUE //)
220                     (TERPRI)
221                     (FUNCALL (OR PRIN1 #'PRIN1) VALUE))
222                   (SETQ +++ ++ ++ + + -))))
223           ;; Before returning, clear rubout handler's buffer to avoid problems
224           (AND (MEMQ ':CLEAR-INPUT (FUNCALL OLD-STANDARD-INPUT ':WHICH-OPERATIONS))
225                (FUNCALL OLD-STANDARD-INPUT ':CLEAR-INPUT))
226           VALUE))))
227
228;;; Initialization stuff
229
230;;; Init lists have entries of the form (name form flag)
231;;; If flag is non-NIL init has been run.
232
233;; Some code relies on INIT-NAME being the CAR of the init entry.  **DO NOT CHANGE THIS**
234(DEFMACRO INIT-NAME (INIT) `(CAR ,INIT))
235(DEFMACRO INIT-FORM (INIT) `(CADR ,INIT))
236(DEFMACRO INIT-FLAG (INIT) `(CADDR ,INIT))
237
238(DEFMACRO INIT-LIST-CHECK (NAME) `(OR (BOUNDP ,NAME) (SET ,NAME NIL)))
239
240;;; Run the inits in the specified list.
241;;; If init has been run before it will only be run again if the second arg is non-NIL.
242;;; The third arg is the flag to be RLACA'd into the flag slot.  If it is NIL it will
243;;;  look as if the inits have never been run.  This may be useful for some applications.
244(DEFUN INITIALIZATIONS (LIST-NAME &OPTIONAL (REDO-FLAG NIL) (FLAG T))
245  (INIT-LIST-CHECK LIST-NAME)
246  (DO ((INIT (SYMEVAL LIST-NAME) (CDR INIT)))
247      ((NULL INIT))
248      (COND ((OR (NULL (INIT-FLAG (CAR INIT))) REDO-FLAG)
249             (EVAL (INIT-FORM (CAR INIT)))
250             (SETF (INIT-FLAG (CAR INIT)) FLAG)))))
251
252;;; Adds a new init to the list.
253;;; Keywords are:
254;;; NOW         Run the init now
255;;; FIRST       Run the init now if this is the first entry for the specified name
256;;; NORMAL      Do the "normal" thing (init when initializations normally run)
257;;; REDO        Do nothing now, but set up things so init gets redone
258;;; COLD        Use the cold boot list
259;;; WARM        Use the warm boot list
260;;; ONCE        Use the once-only list
261;;; SYSTEM      Use the system list
262;;; BEFORE-COLD The list that gets done before disk-save'ing out
263;;; If neither WARM nor COLD are specified, warm is assumed.  If a fourth argument
264;;; is given, then it is the list to use.  WARM and COLD will override the fourth argument.
265(DEFUN ADD-INITIALIZATION (NAME FORM &OPTIONAL KEYWORDS (LIST-NAME 'WARM-INITIALIZATION-LIST)
266                                     &AUX (WHEN NIL) INIT)
267  (INIT-LIST-CHECK LIST-NAME)
268  (DO ((L KEYWORDS (CDR L))
269       (V))
270      ((NULL L))
271      (SETQ V (GET-PNAME (CAR L)))
272      (COND ((STRING-EQUAL "NOW" V) (SETQ WHEN 'NOW))
273            ((STRING-EQUAL "FIRST" V) (SETQ WHEN 'FIRST))
274            ((STRING-EQUAL "NORMAL" V) (SETQ WHEN NIL))
275            ((STRING-EQUAL "REDO" V) (SETQ WHEN 'REDO))
276            ((STRING-EQUAL "WARM" V) (SETQ LIST-NAME 'WARM-INITIALIZATION-LIST))
277            ((STRING-EQUAL "COLD" V) (SETQ LIST-NAME 'COLD-INITIALIZATION-LIST))
278            ((STRING-EQUAL "BEFORE-COLD" V) (SETQ LIST-NAME 'BEFORE-COLD-INITIALIZATION-LIST))
279            ((STRING-EQUAL "SYSTEM" V)
280             (SETQ LIST-NAME 'SYSTEM-INITIALIZATION-LIST)
281             (SETQ WHEN 'FIRST))
282            ((STRING-EQUAL "ONCE" V)
283             (SETQ LIST-NAME 'ONCE-ONLY-INITIALIZATION-LIST)
284             (SETQ WHEN 'FIRST))
285            (T (FERROR NIL "Illegal keyword ~S" (CAR L)))))
286  (SETQ INIT
287        (DO ((L (SYMEVAL LIST-NAME) (CDR L)))
288            ((NULL L)
289             (COND ((NULL (SYMEVAL LIST-NAME))
290                    (CAR (SET LIST-NAME (NCONS (LIST NAME FORM NIL)))))
291                   (T (CADR (RPLACD (LAST (SYMEVAL LIST-NAME))
292                                    (NCONS (LIST NAME FORM NIL)))))))
293            (COND ((STRING-EQUAL (INIT-NAME (CAR L)) NAME)
294                   (SETF (INIT-FORM (CAR L)) FORM)
295                   (RETURN (CAR L))))))
296  (COND ((EQ WHEN 'REDO) (SETF (INIT-FLAG INIT) NIL))
297        ((OR (EQ WHEN 'NOW)
298             (AND (EQ WHEN 'FIRST) (NULL (INIT-FLAG INIT))))
299         (EVAL (INIT-FORM INIT))
300         (SETF (INIT-FLAG INIT) T))))
301
302;;; Deletes an init from the list.
303;;; Keywords are:
304;;; COLD        Use the cold boot list
305;;; WARM        Use the warm boot list
306;;; ONCE        Use the once-only list
307;;; SYSTEM      Use the system list
308;;; BEFORE-COLD The list that gets done before disk-save'ing out
309;;; If neither WARM nor COLD are specified, warm is assumed.  If a third argument
310;;; is given, then it is the list to use.  WARM and COLD will override the third argument.
311(DEFUN DELETE-INITIALIZATION (NAME &OPTIONAL KEYWORDS (LIST-NAME 'WARM-INITIALIZATION-LIST))
312  (INIT-LIST-CHECK LIST-NAME)
313  (DO ((L KEYWORDS (CDR L))
314       (V))
315      ((NULL L))
316      (SETQ V (GET-PNAME (CAR L)))
317      (COND ((STRING-EQUAL "WARM" V) (SETQ LIST-NAME 'WARM-INITIALIZATION-LIST))
318            ((STRING-EQUAL "COLD" V) (SETQ LIST-NAME 'COLD-INITIALIZATION-LIST))
319            ((STRING-EQUAL "BEFORE-COLD" V) (SETQ LIST-NAME 'BEFORE-COLD-INITIALIZATION-LIST))
320            ((STRING-EQUAL "ONCE" V) (SETQ LIST-NAME 'ONCE-ONLY-INITIALIZATION-LIST))
321            ((STRING-EQUAL "SYSTEM" V) (SETQ LIST-NAME 'SYSTEM-INITIALIZATION-LIST))
322            (T (FERROR NIL "Illegal keyword ~S" (CAR L)))))
323  (DO ((L (SYMEVAL LIST-NAME) (CDR L)))
324      ((NULL L))
325      (COND ((STRING-EQUAL (INIT-NAME (CAR L)) NAME)
326             (SET LIST-NAME (DELQ (CAR L) (SYMEVAL LIST-NAME)))))))
327
328(DEFUN RESET-INITIALIZATIONS (LIST-NAME)
329  (INIT-LIST-CHECK LIST-NAME)
330  (DO ((L (SYMEVAL LIST-NAME) (CDR L)))
331      ((NULL L))
332      (SETF (INIT-FLAG (CAR L)) NIL)))
333
334;Small version of FSET-CAREFULLY to be used until all the full
335;mechanisms are there (bootstrapping from cold-load)
336(DEFUN FSET-CAREFULLY-COLD-LOAD (FUNCTION-SPEC DEFINITION &OPTIONAL FORCE-FLAG)
337  FORCE-FLAG ;ignored by his simple version
338  (OR (SYMBOLP FUNCTION-SPEC) (FERROR NIL "~S must be a symbol at this point" FUNCTION-SPEC))
339  (AND FDEFINE-FILE-SYMBOL
340       (PUTPROP FUNCTION-SPEC FDEFINE-FILE-SYMBOL ':SOURCE-FILE-NAME))
341  (FSET FUNCTION-SPEC DEFINITION))
342
343;;; Stuff which has to go somewhere, to be around in the cold-load,
344;;; and doesn't have any logical place where it belongs (this used to
345;;; be in LMIO;KBD)
346
347(DEFVAR USER-ID "")     ;Not logged in
348
349
350;; This is here rather than with the scheduler because it has to be
351;; in the cold-load.  It checks for the non-existence of a scheduler
352;; and does it itself in that case.
353
354;; Takes a predicate and arguments to it.  The process becomes blocked
355;; until the application of the predicate to those arguments returns T.
356;; Note that the function is run in the SCHEDULER stack group, not the
357;; process's stack group!  This means that bindings in effect at the
358;; time PROCESS-WAIT is called will not be in effect; don't refer to
359;; variables "freely" if you are binding them.
360;;    Kludge:  if the scheduler seems broken, or we ARE the scheduler
361;; (i.e. a clock function tries to block), then loop-wait (no blinkers...)
362
363;; In case of a sequence-break while waiting, this function can get "reinvoked".
364;; Therefore, it must not modify its arguments, and must observe other restrictions.
365;; see EH:REINVOKE.
366(DEFUN PROCESS-WAIT (WHOSTATE FUNCTION &REST ARGUMENTS)
367  (COND ((APPLY FUNCTION ARGUMENTS)     ;Test condition before doing slow stack-group switch
368         NIL)                           ;Hmm, no need to wait after all
369        ((OR (NOT SCHEDULER-EXISTS)
370             (EQ SCHEDULER-STACK-GROUP %CURRENT-STACK-GROUP)
371             (NULL CURRENT-PROCESS)
372             (LET ((STATE (SG-CURRENT-STATE SCHEDULER-STACK-GROUP)))
373               (NOT (OR (= STATE SG-STATE-AWAITING-INITIAL-CALL)
374                        (= STATE SG-STATE-AWAITING-RETURN)))))
375         (DO () (NIL)
376           (AND (APPLY FUNCTION ARGUMENTS)
377                (RETURN NIL))))
378        (T
379         (SETF (PROCESS-WHOSTATE CURRENT-PROCESS) WHOSTATE)
380         (TV:WHO-LINE-PROCESS-CHANGE CURRENT-PROCESS)
381         (WITHOUT-INTERRUPTS    ;Dont allow below frobs to get reset by SB
382           (SET-PROCESS-WAIT CURRENT-PROCESS FUNCTION ARGUMENTS)
383           (FUNCALL SCHEDULER-STACK-GROUP))
384         (TV:WHO-LINE-PROCESS-CHANGE CURRENT-PROCESS))))
Note: See TracBrowser for help on using the repository browser.