source: branches/working-0711/ccl/level-1/l1-readloop.lisp @ 8781

Last change on this file since 8781 was 8781, checked in by gb, 12 years ago

Split NOTE-FUNCTION-INFO into a lower-level part (that deals with recording
info); deal with SETF names and encoding lambda lists here.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;L1-readloop.lisp
20
21
22(defvar *break-on-signals* nil
23  "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
24   enter the debugger prior to signalling that condition.")
25(defvar *break-on-warnings* nil)
26(defvar *break-on-errors* t "Not CL.")
27(defvar *debugger-hook* nil
28  "This is either NIL or a function of two arguments, a condition and the value
29   of *DEBUGGER-HOOK*. This function can either handle the condition or return
30   which causes the standard debugger to execute. The system passes the value
31   of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
32   around the invocation.")
33(defvar *backtrace-on-break* nil)
34(defvar *** nil
35  "the previous value of **")
36(defvar ** nil
37  "the previous value of *")
38(defvar * nil
39  "the value of the most recent top level EVAL")
40(defvar /// nil
41  "the previous value of //")
42(defvar // nil
43  "the previous value of /")
44(defvar / nil
45  "a list of all the values returned by the most recent top level EVAL")
46(defvar +++ nil
47  "the previous value of ++")
48(defvar ++ nil
49  "the previous value of +")
50(defvar + nil
51  "the value of the most recent top level READ")
52(defvar - nil
53  "the form currently being evaluated")
54
55(defvar *continuablep* nil)
56(defvar *in-read-loop* nil 
57 "Is T if waiting for input in the read loop")
58
59
60(defvar *did-startup* nil)
61
62
63
64(defmacro catch-cancel (&body body)
65  `(catch :cancel ,@body))
66
67(defmacro throw-cancel (&optional value)
68  `(throw :cancel ,value))
69
70;;; Throwing like this works in listeners and in the initial process.
71;;; Can't easily tell if a process is a listener.  Should be able to.
72(defun toplevel ()
73  (throw :toplevel nil))
74
75
76;;; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS -
77;;; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either.
78(defun interactive-abort ()
79  (interactive-abort-in-process *current-process*))
80
81(defun interactive-abort-in-process (p)
82  (if p (process-interrupt p 
83                           #'(lambda ()
84                               (unless *inhibit-abort*
85                                 (if *in-read-loop* 
86                                        (abort-break)
87                                        (abort))
88                                 )))))
89
90
91(defun abort (&optional condition)
92  "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
93   none exists."
94  (invoke-restart-no-return (find-restart 'abort condition)))
95
96(defun continue (&optional condition)
97  "Transfer control to a restart named CONTINUE, or return NIL if none exists."
98  (let ((r (find-restart 'continue condition)))
99    (if r (invoke-restart r))))
100
101(defun muffle-warning (&optional condition)
102  "Transfer control to a restart named MUFFLE-WARNING, signalling a
103   CONTROL-ERROR if none exists."
104  (invoke-restart-no-return (find-restart 'muffle-warning condition)))
105
106(defun abort-break ()
107  (invoke-restart-no-return 'abort-break))
108
109
110(defun quit (&optional (exit-status 0))
111  (unless (typep exit-status '(signed-byte 32))
112    (report-bad-arg exit-status '(signed-byte 32)))
113  (let* ((ip *initial-process*)
114         (cp *current-process*))
115    (when (process-verify-quit ip)
116      (process-interrupt ip
117                         #'(lambda ()
118                             (process-exit-application *current-process*
119                                                       #'(lambda ()
120                                                           (%set-toplevel nil)
121                                                           (#__exit exit-status)))))
122      (unless (eq cp ip)
123        (process-kill cp)))))
124
125
126(defglobal *quitting* nil)
127
128
129(defun prepare-to-quit (&optional part)
130  (let-globally ((*quitting* t))
131    (when (or (null part) (eql 0 part))
132      (dolist (f *lisp-cleanup-functions*)
133        (funcall f)))
134    (let* ((stragglers ()))
135      (dolist (p (all-processes))
136        (unless (or (eq p *initial-process*)
137                    (not (process-active-p p)))
138          (if (process-persistent p)
139            (process-reset p :shutdown)
140            (process-kill p))))
141      (dolist (p (all-processes))
142        (let* ((semaphore (process-termination-semaphore p)))
143          (when semaphore
144            (unless (eq p *initial-process*)
145              (unless (timed-wait-on-semaphore semaphore 0.05)
146                (push p stragglers))))))
147      (dolist (p stragglers)
148        (let* ((semaphore (process-termination-semaphore p)))
149          (maybe-finish-process-kill p :kill)
150          (when semaphore
151            (timed-wait-on-semaphore semaphore 0.10)))))
152    (shutdown-lisp-threads)
153    (loop
154      (let* ((streams (open-file-streams)))
155        (when (null streams) (return))
156        (let* ((ioblock (stream-ioblock (car streams) nil)))
157          (when ioblock
158            (setf (ioblock-inbuf-lock ioblock) nil
159                  (ioblock-outbuf-lock ioblock) nil
160                  (ioblock-owner ioblock) nil)))
161        (close (car streams))))
162    (setf (interrupt-level) -1)         ; can't abort after this
163    ))
164
165
166(defun signal (condition &rest args)
167  "Invokes the signal facility on a condition formed from DATUM and
168   ARGUMENTS. If the condition is not handled, NIL is returned. If
169   (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
170   before any signalling is done."
171  (setq condition (condition-arg condition args 'simple-condition))
172  (let* ((*break-on-signals* *break-on-signals*))
173     (let* ((old-bos *break-on-signals*))
174       (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos)))
175         (setq *break-on-signals* nil)
176         (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals old-bos)))
177         
178   (when (typep condition *break-on-signals*)
179     (let ((*break-on-signals* nil))
180       (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr)))))
181  (let ((%handlers% %handlers%))
182    (while %handlers%
183      (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers)))
184           ((null handlers))
185        (when (typep condition (car handlers))
186          (let ((fn (cadr handlers)))
187            (cond ((null fn) (throw tag condition))
188                  ((fixnump fn) (throw tag (cons fn condition)))
189                  (t (funcall fn condition)))))))))
190
191(defvar *error-print-circle* nil)   ; reset to T when we actually can print-circle
192
193
194
195;;;***********************************
196;;;Mini-evaluator
197;;;***********************************
198
199(defun new-lexical-environment (&optional parent)
200  (%istruct 'lexical-environment parent nil nil nil nil nil nil))
201
202(defmethod make-load-form ((e lexical-environment) &optional env)
203  (declare (ignore env))
204  nil)
205
206(defun new-definition-environment (&optional (type 'compile-file))
207  (%istruct 'definition-environment (list type)  nil nil nil nil nil nil nil nil nil nil nil nil ))
208
209(defun definition-environment (env &optional clean-only &aux parent)
210  (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment))
211  (do* () 
212       ((or (null env) 
213            (listp (setq parent (lexenv.parent-env env)))
214            (and clean-only (or (lexenv.variables env) (lexenv.functions env)))))
215    (setq env parent))
216  (if (consp parent)
217    env))
218
219(defvar *symbol-macros* (make-hash-table :test #'eq))
220
221(defun %define-symbol-macro (name expansion)
222  (if (or (constant-symbol-p name)
223          (proclaimed-special-p name))
224      (signal-program-error "Symbol ~s already globally defined as a ~A"
225                            name (if (constant-symbol-p name)
226                                     'constant
227                                     'variable)))
228  (setf (gethash name *symbol-macros*) expansion)
229  name)
230
231(defvar *macroexpand-hook* 'funcall
232  "The value of this variable must be a designator for a function that can
233  take three arguments, a macro expander function, the macro form to be
234  expanded, and the lexical environment to expand in. The function should
235  return the expanded form. This function is called by MACROEXPAND-1
236  whenever a runtime expansion is needed. Initially this is set to
237  FUNCALL.") ; Should be #'funcall.
238;(queue-fixup (setq *macroexpand-hook* #'funcall)) ;  No it shouldn't.
239
240(defun %symbol-macroexpand-1 (sym env)
241  (flet ((expand-it (expansion)
242           (funcall *macroexpand-hook*
243                    (constantly expansion)
244                    sym
245                    env)))
246    (if (and env (not (istruct-typep env 'lexical-environment)))
247      (report-bad-arg env 'lexical-environment))
248    (do* ((env env (lexenv.parent-env env)))
249         ((null env))
250      (if (eq (%svref env 0) 'definition-environment)
251        (let* ((info (assq sym (defenv.symbol-macros env))))
252          (if info
253            (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t))
254            (return)))
255        (let* ((vars (lexenv.variables env)))
256          (when (consp vars)
257            (let* ((info (dolist (var vars)
258                           (if (eq (var-name var) sym)
259                             (return var)))))           
260              (when info
261                (if (and (consp (setq info (var-expansion info)))
262                         (eq (%car info) :symbol-macro))
263                  (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t))
264                  (return-from %symbol-macroexpand-1 (values sym nil)))))))))
265    ;; Look it up globally.
266    (multiple-value-bind (expansion win) (gethash sym *symbol-macros*)
267      (if win (values (expand-it expansion) t) (values sym nil)))))
268
269(defun macroexpand-1 (form &optional env &aux fn)
270  "If form is a macro (or symbol macro), expand it once. Return two values,
271   the expanded form and a T-or-NIL flag indicating whether the form was, in
272   fact, a macro. ENV is the lexical environment to expand in, which defaults
273   to the null environment."
274  (declare (resident))
275  (if (and (consp form)
276           (symbolp (%car form)))
277    (if (setq fn (macro-function (%car form) env))
278      (values (funcall *macroexpand-hook* fn form env) t)
279      (values form nil))
280    (if (and form (symbolp form))
281      (%symbol-macroexpand-1 form env)
282      (values form nil))))
283
284(defun macroexpand (form &optional env)
285  "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
286   Returns the final resultant form, and T if it was expanded. ENV is the
287   lexical environment to expand in, or NIL (the default) for the null
288   environment."
289  (declare (resident))
290  (multiple-value-bind (new win) (macroexpand-1 form env)
291    (do* ((won-at-least-once win))
292         ((null win) (values new won-at-least-once))
293      (multiple-value-setq (new win) (macroexpand-1 new env)))))
294
295(defun %symbol-macroexpand (form env &aux win won)
296  ; Keep expanding until no longer a symbol-macro or no longer a symbol.
297  (loop
298    (unless (and form (symbolp form)) (return))
299    (multiple-value-setq (form win) (macroexpand-1 form env))
300    (if win (setq won t) (return)))
301  (values form won))
302
303(defun retain-lambda-expression (name lambda-expression env)
304  (if (and (let* ((lambda-list (cadr lambda-expression)))
305             (and (not (memq '&lap lambda-list))
306                  (not (memq '&method lambda-list))
307                  (not (memq '&lexpr lambda-list))))
308           (nx-declared-inline-p name env)
309           (not (gethash name *nx1-alphatizers*))
310           ; A toplevel definition defined inside a (symbol-)macrolet should
311           ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
312           ; "clean-only" argument to ensure that there are no lexically
313           ; bound macros or symbol-macros.
314           (definition-environment env t))
315    lambda-expression))
316
317;;; This is different from AUGMENT-ENVIRONMENT.
318;;; If "info" is a lambda expression, then
319;;;  record a cons whose CAR is (encoded-lfun-bits . keyvect) and whose cdr
320;;;  is the lambda expression iff the function named by "name" is
321;;;  declared/proclaimed INLINE in env
322(defun note-function-info (name lambda-expression env)
323  (let* ((info nil)
324         (name (maybe-setf-function-name name)))
325    (when (lambda-expression-p lambda-expression)
326      (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
327        (setq info (cons (cons lfbits keyvect) 
328                         (retain-lambda-expression name lambda-expression env)))))
329    (record-function-info name info env))
330  name)
331
332; And this is different from FUNCTION-INFORMATION.
333(defun retrieve-environment-function-info (name env)
334 (let ((defenv (definition-environment env)))
335   (if defenv (assq (maybe-setf-function-name name) (defenv.defined defenv)))))
336
337(defun maybe-setf-function-name (name)
338  (if (and (consp name) (eq (car name) 'setf))
339    (setf-function-name (cadr name))
340    name))
341
342; Must differ from -something-, but not sure what ...
343(defun note-variable-info (name info env)
344  (let ((definition-env (definition-environment env)))
345    (if definition-env (push (cons name info) (defenv.specials definition-env)))
346    name))
347
348(defun compile-file-environment-p (env)
349  (let ((defenv (definition-environment env)))
350    (and defenv (eq 'compile-file (car (defenv.type defenv))))))
351
352(defun cheap-eval (form)
353  (cheap-eval-in-environment form nil))
354
355; used by nfcomp too
356; Should preserve order of decl-specs; it sometimes matters.
357(defun decl-specs-from-declarations (declarations)
358  (let ((decl-specs nil))
359    (dolist (declaration declarations decl-specs)
360      ;(unless (eq (car declaration) 'declare) (say "what"))
361      (dolist (decl-spec (cdr declaration))
362        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
363
364(defun cheap-eval-in-environment (form env &aux sym)
365  (declare (resident))
366  (flet ((progn-in-env (body&decls parse-env base-env)
367           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
368             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
369             (while (cdr body)
370               (cheap-eval-in-environment (pop body) base-env))
371             (cheap-eval-in-environment (car body) base-env))))
372    (if form
373      (cond ((symbolp form) 
374             (multiple-value-bind (expansion win) (macroexpand-1 form env)
375               (if win 
376                 (cheap-eval-in-environment expansion env) 
377                 (let* ((defenv (definition-environment env))
378                        (constant (if defenv (assq form (defenv.constants defenv))))
379                        (constval (%cdr constant)))
380                   (if constant
381                     (if (neq (%unbound-marker-8) constval)
382                       constval
383                       (error "Can't determine value of constant symbol ~s" form))
384                     (if (constant-symbol-p form)
385                       (%sym-global-value form)
386                       (symbol-value form)))))))
387            ((atom form) form)
388            ((eq (setq sym (%car form)) 'quote)
389             (verify-arg-count form 1 1)
390             (%cadr form))
391            ((eq sym 'function)
392             (verify-arg-count form 1 1)
393             (cond ((symbolp (setq sym (%cadr form)))
394                    (multiple-value-bind (kind local-p)
395                        (function-information sym env)
396                      (if (and local-p (eq kind :macro))
397                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
398                    (%function sym))
399                   ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
400                    (multiple-value-bind (kind local-p)
401                        (function-information sym env)
402                      (if (and local-p (eq kind :macro))
403                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
404                    (%function (setf-function-name (%cadr sym))))
405                   (t (%make-function nil sym env))))
406            ((eq sym 'nfunction)
407             (verify-arg-count form 2 2)
408             (%make-function (%cadr form) (%caddr form) env))
409            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
410            ((eq sym 'setq)
411             (if (not (%ilogbitp 0 (list-length form)))
412               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
413             (let* ((sym nil)
414                    (val nil))
415               (while (setq form (%cdr form))
416                 (setq sym (require-type (pop form) 'symbol))
417                 (multiple-value-bind (expansion expanded)
418                                      (macroexpand-1 sym env)
419                   (if expanded
420                     (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
421                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
422               val))
423            ((eq sym 'eval-when)
424             (destructuring-bind (when . body) (%cdr form)
425               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
426            ((eq sym 'if)
427             (destructuring-bind (test true &optional false) (%cdr form)
428               (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
429            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
430            ((eq sym 'symbol-macrolet)
431             (multiple-value-bind (body decls) (parse-body (cddr form) env)
432               (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls)))))
433            ((eq sym 'macrolet)
434             (let ((temp-env (augment-environment env
435                                                  :macro 
436                                                  (mapcar #'(lambda (m)
437                                                              (destructuring-bind (name arglist &body body) m
438                                                                (list name (enclose (parse-macro name arglist body env)
439                                                                                    env))))
440                                                          (cadr form)))))
441               (progn-in-env (cddr form) temp-env temp-env)))
442            ((and (symbolp sym) 
443                  (compiler-special-form-p sym)
444                  (not (functionp (fboundp sym))))
445             (if (eq sym 'unwind-protect)
446               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
447                 (unwind-protect
448                   (cheap-eval-in-environment protected-form env)
449                   (progn-in-env cleanup-forms env env)))
450               (funcall (%make-function nil `(lambda () (progn ,form)) env))))
451            ((and (symbolp sym) (macro-function sym env))
452             (if (eq sym 'step)
453               (let ((*compile-definitions* nil))
454                     (cheap-eval-in-environment (macroexpand-1 form env) env))
455               (cheap-eval-in-environment (macroexpand-1 form env) env)))
456            ((or (symbolp sym)
457                 (and (consp sym) (eq (%car sym) 'lambda)))
458             (let ((args nil))
459               (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
460               (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
461                      (nreverse args))))
462            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
463
464
465(%fhave 'eval #'cheap-eval)
466
467
468
469 
470(defun call-check-regs (fn &rest args)
471  (declare (dynamic-extent args)
472           (optimize (debug 3)))        ; don't use any saved registers
473  (let ((old-regs (multiple-value-list (get-saved-register-values))))
474    (declare (dynamic-extent old-regs))
475    (multiple-value-prog1 (apply fn args)
476      (let* ((new-regs (multiple-value-list (get-saved-register-values)))
477             (new-regs-tail new-regs))
478        (declare (dynamic-extent new-regs))
479        (unless (dolist (old-reg old-regs t)
480                  (unless (eq old-reg (car new-regs-tail))
481                    (return nil))
482                  (pop new-regs-tail))
483          (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}"
484                 fn args
485                 (mapcan 'list
486                         (let ((res nil))
487                           (dotimes (i (length old-regs))
488                             (push (format nil "save~d" i) res))
489                           (nreverse res))
490                         old-regs
491                         new-regs)))))))
492
493
494
495
496
497;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
498;; Stack frame accessors.
499
500; Kinda scant, wouldn't you say ?
501
502
503;end of L1-readloop.lisp
504
Note: See TracBrowser for help on using the repository browser.