source: trunk/source/level-1/l1-readloop.lisp @ 12085

Last change on this file since 12085 was 12069, checked in by gz, 10 years ago

merge r12050

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 33.3 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(defloadvar *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  ;; Didn't abort, so really quitting.
165  (setq *quitting* t))
166
167
168(defun signal (condition &rest args)
169  "Invokes the signal facility on a condition formed from DATUM and
170   ARGUMENTS. If the condition is not handled, NIL is returned. If
171   (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
172   before any signalling is done."
173  (setq condition (condition-arg condition args 'simple-condition))
174  (let* ((*break-on-signals* *break-on-signals*))
175     (let* ((old-bos *break-on-signals*))
176       (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos)))
177         (setq *break-on-signals* nil)
178         (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals* old-bos)))
179         
180   (when (typep condition *break-on-signals*)
181     (let ((*break-on-signals* nil))
182       (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr)))))
183  (let ((%handlers% %handlers%))
184    (while %handlers%
185      (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers)))
186           ((null handlers))
187        (when (typep condition (car handlers))
188          (let ((fn (cadr handlers)))
189            (cond ((null fn) (throw tag condition))
190                  ((fixnump fn) (throw tag (cons fn condition)))
191                  (t (funcall fn condition)))))))))
192
193(defvar *error-print-circle* nil)   ; reset to T when we actually can print-circle
194
195
196
197;;;***********************************
198;;;Mini-evaluator
199;;;***********************************
200
201(defun new-lexical-environment (&optional parent)
202  (%istruct 'lexical-environment parent nil nil nil nil nil nil))
203
204(defmethod make-load-form ((e lexical-environment) &optional env)
205  (declare (ignore env))
206  nil)
207
208(defun new-definition-environment (&optional (type 'compile-file))
209  (%istruct 'definition-environment (list type)  nil nil nil nil nil nil nil nil nil nil nil nil ))
210
211(defun definition-environment (env &optional clean-only &aux parent)
212  (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment))
213  (do* () 
214       ((or (null env) 
215            (listp (setq parent (lexenv.parent-env env)))
216            (and clean-only (or (lexenv.variables env) (lexenv.functions env)))))
217    (setq env parent))
218  (if (consp parent)
219    env))
220
221(defvar *symbol-macros* (make-hash-table :test #'eq))
222
223(defun %define-symbol-macro (name expansion)
224  (if (or (constant-symbol-p name)
225          (proclaimed-special-p name))
226      (signal-program-error "Symbol ~s already globally defined as a ~A"
227                            name (if (constant-symbol-p name)
228                                     'constant
229                                     'variable)))
230  (setf (gethash name *symbol-macros*) expansion)
231  name)
232
233(defvar *macroexpand-hook* 'funcall
234  "The value of this variable must be a designator for a function that can
235  take three arguments, a macro expander function, the macro form to be
236  expanded, and the lexical environment to expand in. The function should
237  return the expanded form. This function is called by MACROEXPAND-1
238  whenever a runtime expansion is needed. Initially this is set to
239  FUNCALL.") ; Should be #'funcall.
240;(queue-fixup (setq *macroexpand-hook* #'funcall)) ;  No it shouldn't.
241
242(defun %symbol-macroexpand-1 (sym env)
243  (flet ((expand-it (expansion)
244           (funcall *macroexpand-hook*
245                    (constantly expansion)
246                    sym
247                    env)))
248    (if (and env (not (istruct-typep env 'lexical-environment)))
249      (report-bad-arg env 'lexical-environment))
250    (do* ((env env (lexenv.parent-env env)))
251         ((null env))
252      (if (istruct-typep env 'definition-environment)
253        (let* ((info (assq sym (defenv.symbol-macros env))))
254          (if info
255            (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t))
256            (return)))
257        (let* ((vars (lexenv.variables env)))
258          (when (consp vars)
259            (let* ((info (dolist (var vars)
260                           (if (eq (var-name var) sym)
261                             (return var)))))           
262              (when info
263                (if (and (consp (setq info (var-expansion info)))
264                         (eq (%car info) :symbol-macro))
265                  (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t))
266                  (return-from %symbol-macroexpand-1 (values sym nil)))))))))
267    ;; Look it up globally.
268    (multiple-value-bind (expansion win) (gethash sym *symbol-macros*)
269      (if win (values (expand-it expansion) t) (values sym nil)))))
270
271(defun macroexpand-all (form &optional (env (new-lexical-environment)))
272  "Recursivly expand all macros in FORM."
273  (flet ((mexpand (forms env)
274           (mapcar (lambda (form) (macroexpand-all form env)) forms)))
275    (macrolet ((destructuring-bind-body (binds form &body body)
276                 (if (eql '&body (first (last binds)))
277                   (let ((&body (gensym "&BODY")))
278                     `(destructuring-bind ,(append (butlast binds) (list '&body &body))
279                          ,form
280                        (multiple-value-bind (body decls)
281                            (parse-body ,&body env nil)
282                          ,@body)))
283                   `(destructuring-bind ,binds ,form ,@body))))
284      (multiple-value-bind (expansion win)
285          (macroexpand-1 form env)
286        (if win
287          (macroexpand-all expansion env)
288          (if (atom form)
289            form
290            (case (first form)
291              (macrolet
292               (destructuring-bind-body (macros &body) (rest form)
293                (setf env (augment-environment env
294                                               :macro (mapcar (lambda (macro)
295                                                                (destructuring-bind
296                                                                      (name arglist &body body)
297                                                                    macro
298                                                                  (list name (enclose (parse-macro name arglist body env)))))
299                                                              macros)
300                                               :declare (decl-specs-from-declarations decls)))
301                (let ((body (mexpand body env)))
302                  (if decls
303                    `(locally ,@decls ,@body)
304                    `(progn ,@body)))))
305              (symbol-macrolet
306               (destructuring-bind-body (symbol-macros &body) (rest form)
307                (setf env (augment-environment env :symbol-macro symbol-macros :declare (decl-specs-from-declarations decls)))
308                (let ((body (mexpand body env)))
309                  (if decls
310                    `(locally ,@decls ,@body)
311                    `(progn ,@body)))))
312              ((let let* compiler-let)
313               (destructuring-bind-body (bindings &body) (rest form)
314                `(,(first form)
315                   ,(mapcar (lambda (binding)
316                             
317                              (if (listp binding)
318                                (list (first binding) (macroexpand-all (second binding) env))
319                                binding))
320                            bindings)
321                   ,@decls
322                   ,@(mexpand body env))))
323              ((flet labels)
324               (destructuring-bind-body (bindings &body) (rest form)
325                `(,(first form)
326                   ,(mapcar (lambda (binding)
327                              (list* (first binding) (cdr (macroexpand-all `(lambda ,@(rest binding)) env))))
328                            bindings)
329                   ,@decls
330                   ,@(mexpand body env))))
331              (nfunction (list* 'nfunction (second form) (macroexpand-all (third form) env)))
332              (function
333                 (if (and (consp (second form))
334                          (eql 'lambda (first (second form))))
335                   (destructuring-bind (lambda arglist &body body&decls)
336                       (second form)
337                     (declare (ignore lambda))
338                     (multiple-value-bind (body decls)
339                         (parse-body body&decls env)
340                       `(lambda ,arglist ,@decls ,@(mexpand body env))))
341                   form))
342              ((eval-when the locally block return-from)
343                 (list* (first form) (second form) (mexpand (cddr form) env)))
344              (setq
345                 `(setq ,@(loop for (name value) on (rest form) by #'cddr
346                                collect name
347                                collect (macroexpand-all value env))))
348              ((go quote) form)
349              ((fbind with-c-frame with-variable-c-frame ppc-lap-function)
350               (error "Unable to macroexpand ~S." form))
351              ((catch if load-time-value multiple-value-call multiple-value-prog1 progn
352                progv tagbody throw unwind-protect)
353               (cons (first form) (mexpand (rest form) env)))
354              (t
355               ;; need to check that (first form) is either fboundp or a local function...
356               (cons (first form) (mexpand (rest form) env))))))))))
357
358(defun macroexpand-1 (form &optional env &aux fn)
359  "If form is a macro (or symbol macro), expand it once. Return two values,
360   the expanded form and a T-or-NIL flag indicating whether the form was, in
361   fact, a macro. ENV is the lexical environment to expand in, which defaults
362   to the null environment."
363  (declare (resident))
364  (if (and (consp form)
365           (symbolp (%car form)))
366    (if (setq fn (macro-function (%car form) env))
367      (values (funcall *macroexpand-hook* fn form env) t)
368      (values form nil))
369    (if (and form (symbolp form))
370      (%symbol-macroexpand-1 form env)
371      (values form nil))))
372
373(defun macroexpand (form &optional env)
374  "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
375   Returns the final resultant form, and T if it was expanded. ENV is the
376   lexical environment to expand in, or NIL (the default) for the null
377   environment."
378  (declare (resident))
379  (multiple-value-bind (new win) (macroexpand-1 form env)
380    (do* ((won-at-least-once win))
381         ((null win) (values new won-at-least-once))
382      (multiple-value-setq (new win) (macroexpand-1 new env)))))
383
384(defun %symbol-macroexpand (form env &aux win won)
385  ; Keep expanding until no longer a symbol-macro or no longer a symbol.
386  (loop
387    (unless (and form (symbolp form)) (return))
388    (multiple-value-setq (form win) (macroexpand-1 form env))
389    (if win (setq won t) (return)))
390  (values form won))
391
392(defun retain-lambda-expression (name lambda-expression env)
393  (if (and (let* ((lambda-list (cadr lambda-expression)))
394             (and (not (memq '&lap lambda-list))
395                  (not (memq '&method lambda-list))
396                  (not (memq '&lexpr lambda-list))))
397           (nx-declared-inline-p name env)
398           (not (gethash name *nx1-alphatizers*))
399           ; A toplevel definition defined inside a (symbol-)macrolet should
400           ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
401           ; "clean-only" argument to ensure that there are no lexically
402           ; bound macros or symbol-macros.
403           (definition-environment env t))
404    lambda-expression))
405
406
407(defun %cons-def-info (type &optional lfbits keyvect lambda specializers qualifiers)
408  (ecase type
409    (defun nil)
410    (defmacro (setq lambda '(macro) lfbits nil)) ;; some code assumes lfbits=nil
411    (defgeneric (setq lambda (list :methods)))
412    (defmethod (setq lambda (list :methods (cons qualifiers specializers))))
413    (deftype (setq lambda '(type) lfbits (cons nil *loading-file-source-file*))))
414  (vector lfbits keyvect *loading-file-source-file* lambda))
415
416(defun def-info.lfbits (def-info)
417  (and def-info
418       (let ((lfbits (svref def-info 0)))
419         (if (consp lfbits) (%car lfbits) lfbits))))
420
421(defun def-info.keyvect (def-info)
422  (and def-info (svref def-info 1)))
423
424(defun def-info.file (def-info)
425  (and def-info (svref def-info 2)))
426
427(defun def-info.lambda (def-info)
428  (and def-info
429       (let ((data (svref def-info 3)))
430         (and (eq (car data) 'lambda) data))))
431
432(defun def-info.methods (def-info)
433  (and def-info
434       (let ((data (svref def-info 3)))
435         (and (eq (car data) :methods) (%cdr data)))))
436
437(defun def-info-with-new-methods (def-info new-methods)
438  (if (eq new-methods (def-info.methods def-info))
439    def-info
440    (let ((new (copy-seq def-info)))
441      (setf (svref new 3) (cons :methods new-methods))
442      new)))
443
444(defun def-info.macro-p (def-info)
445  (let ((data (and def-info (svref def-info 3))))
446    (eq (car data) 'macro)))
447
448(defun def-info.function-p (def-info)
449  (not (and def-info (eq (car (svref def-info 3)) 'type))))
450
451(defun def-info.function-type (def-info)
452  (if (null def-info)
453    nil ;; ftype only, for the purposes here, is same as nothing.
454    (let ((data (svref def-info 3)))
455      (ecase (car data)
456        ((nil lambda) 'defun)
457        (:methods 'defgeneric)
458        (macro 'defmacro)
459        (ftype nil)
460        (type nil)))))
461
462(defun def-info.deftype (def-info)
463  (and def-info
464       (let ((bits (svref def-info 0)))
465         ;; bits or (bits . type-source-file)
466         (and (consp bits) bits))))
467
468(defun def-info.deftype-type (def-info)
469  ;; 'class (for defclass/defstruct) or 'macro (for deftype et. al.)
470  (and def-info
471       (consp (svref def-info 0))
472       (svref def-info 1)))
473
474(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
475
476(defvar *compiler-warn-on-duplicate-definitions* t)
477
478(defun combine-deftype-infos (name def-info old-deftype new-deftype)
479  (when (or new-deftype old-deftype)
480    (when (and old-deftype new-deftype *compiler-warn-on-duplicate-definitions*)
481      (nx1-whine :duplicate-definition
482                 `(type ,name)
483                 (cdr old-deftype)
484                 (cdr new-deftype)))
485    (let ((target (if new-deftype
486                      (or (cdr new-deftype) (cdr old-deftype))
487                      (cdr old-deftype)))
488          (target-deftype (def-info.deftype def-info)))
489      (unless (and target-deftype (eq (cdr target-deftype) target))
490        (setq def-info (copy-seq (or def-info '#(nil nil nil (ftype)))))
491        (setf (svref def-info 0) (cons (def-info.lfbits def-info) target)))))
492  def-info)
493
494#+debug
495(defun describe-def-info (def-info)
496  (list :lfbits (def-info.lfbits def-info)
497        :keyvect (def-info.keyvect def-info)
498        :macro-p (def-info.macro-p def-info)
499        :function-p (def-info.function-p def-info)
500        :lambda (and (def-info.function-p def-info) (def-info.lambda def-info))
501        :methods (and (def-info.function-p def-info) (def-info.methods def-info))
502        :function-type (def-info.function-type def-info)
503        :deftype (def-info.deftype def-info)
504        :deftype-type (def-info.deftype-type def-info)))
505
506(defun combine-definition-infos (name old-info new-info)
507  (let ((old-type (def-info.function-type old-info))  ;; defmacro
508        (old-deftype (def-info.deftype old-info))      ;; nil
509        (new-type (def-info.function-type new-info))  ;; nil
510        (new-deftype (def-info.deftype new-info)))   ;; (nil . file)
511    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
512           ;; TODO: Check compatibility of lfbits...
513           ;; TODO: check that all methods implement defgeneric keys
514           (let ((old-methods (def-info.methods old-info))
515                 (new-methods (def-info.methods new-info)))
516             (loop for new-method in new-methods
517                   do (if (member new-method old-methods :test #'equal)
518                        (when *compiler-warn-on-duplicate-definitions*
519                          (nx1-whine :duplicate-definition
520                                     `(method ,@(car new-method) ,name ,(cdr new-method))
521                                     (def-info.file old-info)
522                                     (def-info.file new-info)))
523                        (push new-method old-methods)))
524             (setq new-info (def-info-with-new-methods old-info old-methods))))
525          ((or (eq (or old-type 'defun) (or new-type 'defun))
526               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
527           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
528             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
529           (unless new-info (setq new-info old-info)))
530          (t
531           (when (and (def-info.function-p old-info) (def-info.function-p new-info)
532                      *compiler-warn-on-duplicate-definitions*)
533             (apply #'nx1-whine :duplicate-definition
534                    name
535                    (def-info.file old-info)
536                    (def-info.file new-info)
537                    (cond ((eq old-type 'defmacro) '("macro" "function"))
538                          ((eq new-type 'defmacro) '("function" "macro"))
539                          ((eq old-type 'defgeneric) '("generic function" "function"))
540                          (t '("function" "generic function")))))
541           (unless new-type (setq new-info old-info))))
542    (combine-deftype-infos name new-info old-deftype new-deftype)))
543
544(defun record-definition-info (name info env)
545  (let* ((definition-env (definition-environment env)))
546    (if definition-env
547      (let* ((defs (defenv.defined definition-env))
548             (already (if (listp defs) (assq name defs) (gethash name defs))))
549        (if already
550          (setf (%cdr already) (combine-definition-infos name (%cdr already) info))
551          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
552                               then (deferred-warnings.parent defer)
553                             while (typep defer 'deferred-warnings)
554                             thereis (gethash name (deferred-warnings.defs defer)))))
555            (when outer
556              (setq info (combine-definition-infos name (%cdr outer) info)))
557            (let ((new (cons name info)))
558              (if (listp defs)
559                (setf (defenv.defined definition-env) (cons new defs))
560                (setf (gethash name defs) new)))))
561        info))))
562
563(defun record-function-info (name info env)
564  (record-definition-info name info env))
565
566;;; This is different from AUGMENT-ENVIRONMENT.
567(defun note-function-info (name lambda-expression env)
568  (let* ((info nil)
569         (name (maybe-setf-function-name name)))
570    (when (lambda-expression-p lambda-expression)
571      (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
572        (setq info (%cons-def-info 'defun lfbits keyvect
573                                   (retain-lambda-expression name lambda-expression env)))))
574    (record-function-info name info env))
575  name)
576
577(defun note-type-info (name kind env)
578  (record-definition-info name (%cons-def-info 'deftype nil kind) env))
579
580
581; And this is different from FUNCTION-INFORMATION.
582(defun retrieve-environment-function-info (name env)
583 (let ((defenv (definition-environment env)))
584   (when defenv
585     (let* ((defs (defenv.defined defenv))
586            (sym (maybe-setf-function-name name))
587            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
588       (and info (def-info.function-p (cdr info)) info)))))
589
590;;; Must differ from -something-, but not sure what ...
591(defun note-variable-info (name info env)
592  (let ((definition-env (definition-environment env)))
593    (if definition-env (push (cons name info) (defenv.specials definition-env)))
594    name))
595
596(defun compile-file-environment-p (env)
597  (let ((defenv (definition-environment env)))
598    (and defenv (eq 'compile-file (car (defenv.type defenv))))))
599
600(defun cheap-eval (form)
601  (cheap-eval-in-environment form nil))
602
603; used by nfcomp too
604; Should preserve order of decl-specs; it sometimes matters.
605(defun decl-specs-from-declarations (declarations)
606  (let ((decl-specs nil))
607    (dolist (declaration declarations decl-specs)
608      ;(unless (eq (car declaration) 'declare) (say "what"))
609      (dolist (decl-spec (cdr declaration))
610        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
611
612(defun cheap-eval-macroexpand-1 (form env)
613  (multiple-value-bind (new win) (macroexpand-1 form env)
614    (when win
615      (note-source-transformation form new))
616    (values new win)))
617
618(defun cheap-eval-transform (original new)
619  (note-source-transformation original new)
620  new)
621
622(defun cheap-eval-function (name lambda env)
623  (multiple-value-bind (lfun warnings)
624                       (compile-named-function lambda
625                                               :name name
626                                               :env env
627                                               :function-note *loading-toplevel-location*
628                                               :keep-lambda *save-definitions*
629                                               :keep-symbols *save-local-symbols*
630                                               :source-notes *nx-source-note-map*)
631    (signal-or-defer-warnings warnings env)
632    lfun))
633
634(fset 'nx-source-note (nlambda bootstrapping-source-note (form) (declare (ignore form)) nil))
635
636(defun cheap-eval-in-environment (form env &aux sym)
637  (declare (resident))
638  ;; records source locations if *nx-source-note-map* is bound by caller
639  (setq *loading-toplevel-location* (or (nx-source-note form) *loading-toplevel-location*))
640  (flet ((progn-in-env (body&decls parse-env base-env)
641           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
642             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
643             (loop with default-location = *loading-toplevel-location*
644               while (cdr body) as form = (pop body)
645               do (cheap-eval-in-environment form base-env)
646               do (setq *loading-toplevel-location* default-location))
647             (cheap-eval-in-environment (car body) base-env))))
648    (if form
649      (cond ((symbolp form) 
650             (multiple-value-bind (expansion win) (cheap-eval-macroexpand-1 form env)
651               (if win 
652                 (cheap-eval-in-environment expansion env)
653                 (let* ((defenv (definition-environment env))
654                        (constant (if defenv (assq form (defenv.constants defenv))))
655                        (constval (%cdr constant)))
656                   (if constant
657                     (if (neq (%unbound-marker-8) constval)
658                       constval
659                       (error "Can't determine value of constant symbol ~s" form))
660                     (if (constant-symbol-p form)
661                       (%sym-global-value form)
662                       (symbol-value form)))))))
663            ((atom form) form)
664            ((eq (setq sym (%car form)) 'quote)
665             (verify-arg-count form 1 1)
666             (%cadr form))
667            ((eq sym 'function)
668             (verify-arg-count form 1 1)
669             (cond ((symbolp (setq sym (%cadr form)))
670                    (multiple-value-bind (kind local-p)
671                        (function-information sym env)
672                      (if (and local-p (eq kind :macro))
673                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
674                    (%function sym))
675                   ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
676                    (multiple-value-bind (kind local-p)
677                        (function-information sym env)
678                      (if (and local-p (eq kind :macro))
679                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
680                    (%function (setf-function-name (%cadr sym))))
681                   (t (cheap-eval-function nil sym env))))
682            ((eq sym 'nfunction)
683             (verify-arg-count form 2 2)
684             (cheap-eval-function (%cadr form) (%caddr form) env))
685            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
686            ((eq sym 'setq)
687             (if (not (%ilogbitp 0 (list-length form)))
688               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
689             (let* ((sym nil)
690                    (val nil)
691                    (original form))
692               (while (setq form (%cdr form))
693                 (setq sym (require-type (pop form) 'symbol))
694                 (multiple-value-bind (expansion expanded)
695                                      (cheap-eval-macroexpand-1 sym env)
696                   (if expanded
697                     (setq val (cheap-eval-in-environment
698                                (cheap-eval-transform original `(setf ,expansion ,(%car form)))
699                                env))
700                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
701               val))
702            ((eq sym 'eval-when)
703             (destructuring-bind (when . body) (%cdr form)
704               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
705            ((eq sym 'if)
706             (destructuring-bind (test true &optional false) (%cdr form)
707               (setq test (let ((*loading-toplevel-location* *loading-toplevel-location*))
708                            (cheap-eval-in-environment test env)))
709               (cheap-eval-in-environment (if test true false) env)))
710            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
711            ((eq sym 'symbol-macrolet)
712             (multiple-value-bind (body decls) (parse-body (cddr form) env)
713               (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls)))))
714            ((eq sym 'macrolet)
715             (let ((temp-env (augment-environment env
716                                                  :macro 
717                                                  (mapcar #'(lambda (m)
718                                                              (destructuring-bind (name arglist &body body) m
719                                                                (list name (enclose (parse-macro name arglist body env)
720                                                                                    env))))
721                                                          (cadr form)))))
722               (progn-in-env (cddr form) temp-env temp-env)))
723            ((and (symbolp sym) 
724                  (compiler-special-form-p sym)
725                  (not (functionp (fboundp sym))))
726             (if (eq sym 'unwind-protect)
727               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
728                 (unwind-protect
729                     (let ((*loading-toplevel-location* *loading-toplevel-location*))
730                       (cheap-eval-in-environment protected-form env))
731                   (progn-in-env cleanup-forms env env)))
732               (funcall (cheap-eval-function nil (cheap-eval-transform form `(lambda () (progn ,form))) env))))
733            ((and (symbolp sym) (macro-function sym env))
734             (cheap-eval-in-environment (cheap-eval-macroexpand-1 form env) env))
735            ((or (symbolp sym)
736                 (and (consp sym) (eq (%car sym) 'lambda)))
737             (let ((args nil) (form-location *loading-toplevel-location*))
738               (dolist (elt (%cdr form))
739                 (push (cheap-eval-in-environment elt env) args)
740                 (setq *loading-toplevel-location* form-location))
741               (apply #'call-check-regs (if (symbolp sym) sym (cheap-eval-function nil sym env))
742                      (nreverse args))))
743            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
744
745
746(%fhave 'eval #'cheap-eval)
747
748
749
750 
751(defun call-check-regs (fn &rest args)
752  (declare (dynamic-extent args)
753           (optimize (debug 3)))        ; don't use any saved registers
754  (let ((old-regs (multiple-value-list (get-saved-register-values))))
755    (declare (dynamic-extent old-regs))
756    (multiple-value-prog1 (apply fn args)
757      (let* ((new-regs (multiple-value-list (get-saved-register-values)))
758             (new-regs-tail new-regs))
759        (declare (dynamic-extent new-regs))
760        (unless (dolist (old-reg old-regs t)
761                  (unless (eq old-reg (car new-regs-tail))
762                    (return nil))
763                  (pop new-regs-tail))
764          (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}"
765                 fn args
766                 (mapcan 'list
767                         (let ((res nil))
768                           (dotimes (i (length old-regs))
769                             (push (format nil "save~d" i) res))
770                           (nreverse res))
771                         old-regs
772                         new-regs)))))))
773
774
775
776
777
778;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
779;; Stack frame accessors.
780
781; Kinda scant, wouldn't you say ?
782
783
784;end of L1-readloop.lisp
785
Note: See TracBrowser for help on using the repository browser.