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

Last change on this file since 13334 was 13193, checked in by gz, 10 years ago

Don't record source locations in compilations arising from explicit calls to EVAL (regardless of the setting of *save-source-locations* or *save-interactive-source-locations*)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 37.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;L1-readloop.lisp
21
22
23(defvar *break-on-signals* nil
24  "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
25   enter the debugger prior to signalling that condition.")
26(defvar *break-on-warnings* nil)
27(defvar *break-on-errors* t "Not CL.")
28(defvar *debugger-hook* nil
29  "This is either NIL or a function of two arguments, a condition and the value
30   of *DEBUGGER-HOOK*. This function can either handle the condition or return
31   which causes the standard debugger to execute. The system passes the value
32   of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
33   around the invocation.")
34(defvar *backtrace-on-break* nil)
35(defvar *** nil
36  "the previous value of **")
37(defvar ** nil
38  "the previous value of *")
39(defvar * nil
40  "the value of the most recent top level EVAL")
41(defvar /// nil
42  "the previous value of //")
43(defvar // nil
44  "the previous value of /")
45(defvar / nil
46  "a list of all the values returned by the most recent top level EVAL")
47(defvar +++ nil
48  "the previous value of ++")
49(defvar ++ nil
50  "the previous value of +")
51(defvar + nil
52  "the value of the most recent top level READ")
53(defvar - nil
54  "the form currently being evaluated")
55
56(defvar *continuablep* nil)
57(defvar *in-read-loop* nil 
58 "Is T if waiting for input in the read loop")
59
60
61(defvar *did-startup* nil)
62
63
64
65(defmacro catch-cancel (&body body)
66  `(catch :cancel ,@body))
67
68(defmacro throw-cancel (&optional value)
69  `(throw :cancel ,value))
70
71;;; Throwing like this works in listeners and in the initial process.
72;;; Can't easily tell if a process is a listener.  Should be able to.
73(defun toplevel ()
74  (throw :toplevel nil))
75
76
77;;; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS -
78;;; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either.
79(defun interactive-abort ()
80  (interactive-abort-in-process *current-process*))
81
82(defun interactive-abort-in-process (p)
83  (if p (process-interrupt p 
84                           #'(lambda ()
85                               (unless *inhibit-abort*
86                                 (if *in-read-loop* 
87                                        (abort-break)
88                                        (abort))
89                                 )))))
90
91
92(defun abort (&optional condition)
93  "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
94   none exists."
95  (invoke-restart-no-return (find-restart 'abort condition)))
96
97(defun continue (&optional condition)
98  "Transfer control to a restart named CONTINUE, or return NIL if none exists."
99  (let ((r (find-restart 'continue condition)))
100    (if r (invoke-restart r))))
101
102(defun muffle-warning (&optional condition)
103  "Transfer control to a restart named MUFFLE-WARNING, signalling a
104   CONTROL-ERROR if none exists."
105  (invoke-restart-no-return (find-restart 'muffle-warning condition)))
106
107(defun abort-break ()
108  (invoke-restart-no-return 'abort-break))
109
110
111(defun quit (&optional (exit 0) &key error-handler)
112  "exit must be either a (signed-byte 32) exit status or a function to call to exit lisp
113   error-handler can be a function of one argument, the condition, that will be called if an
114   error occurs while preparing to quit.  The error handler should exit"
115  (if (or (null exit) (typep exit '(signed-byte 32)))
116    (setq exit (let ((exit-status (or exit 0)))
117                 #'(lambda () (#__exit exit-status))))
118    (unless (typep exit 'function)
119      (report-bad-arg exit '(or (signed-byte 32) function))))
120  (let* ((ip *initial-process*)
121         (cp *current-process*))
122    (when (process-verify-quit ip)
123      (process-interrupt ip
124                         #'(lambda ()
125                             (handler-bind ((error (lambda (c)
126                                                     (when error-handler
127                                                       (funcall error-handler c)))))
128                               (process-exit-application *current-process*
129                                                         #'(lambda ()
130                                                             (%set-toplevel nil)
131                                                             (funcall exit) ;; must exit
132                                                             (bug "Exit function didn't exit"))))))
133      (unless (eq cp ip)
134        (process-kill cp)))))
135
136
137(defloadvar *quitting* nil)
138
139
140(defun prepare-to-quit (&optional part)
141  (let-globally ((*quitting* t))
142    (when (or (null part) (eql 0 part))
143      (dolist (f *lisp-cleanup-functions*)
144        (funcall f)))
145    (let* ((stragglers ()))
146      (dolist (p (all-processes))
147        (unless (or (eq p *initial-process*)
148                    (not (process-active-p p)))
149          (if (process-persistent p)
150            (process-reset p :shutdown)
151            (process-kill p))))
152      (dolist (p (all-processes))
153        (let* ((semaphore (process-termination-semaphore p)))
154          (when semaphore
155            (unless (eq p *initial-process*)
156              (unless (timed-wait-on-semaphore semaphore 0.05)
157                (push p stragglers))))))
158      (dolist (p stragglers)
159        (let* ((semaphore (process-termination-semaphore p)))
160          (maybe-finish-process-kill p :kill)
161          (when semaphore
162            (timed-wait-on-semaphore semaphore 0.10)))))
163    (shutdown-lisp-threads)
164    (loop
165      (let* ((streams (open-file-streams)))
166        (when (null streams) (return))
167        (let* ((ioblock (stream-ioblock (car streams) nil)))
168          (when ioblock
169            (setf (ioblock-inbuf-lock ioblock) nil
170                  (ioblock-outbuf-lock ioblock) nil
171                  (ioblock-owner ioblock) nil)))
172        (close (car streams))))
173    (setf (interrupt-level) -1)         ; can't abort after this
174    )
175  ;; Didn't abort, so really quitting.
176  (setq *quitting* t))
177
178
179(defun signal (condition &rest args)
180  "Invokes the signal facility on a condition formed from DATUM and
181   ARGUMENTS. If the condition is not handled, NIL is returned. If
182   (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
183   before any signalling is done."
184  (setq condition (condition-arg condition args 'simple-condition))
185  (let* ((*break-on-signals* *break-on-signals*))
186     (let* ((old-bos *break-on-signals*))
187       (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos)))
188         (setq *break-on-signals* nil)
189         (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals* old-bos)))
190         
191   (when (typep condition *break-on-signals*)
192     (let ((*break-on-signals* nil))
193       (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr)))))
194  (let ((%handlers% %handlers%))
195    (while %handlers%
196      (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers)))
197           ((null handlers))
198        (when (typep condition (car handlers))
199          (let ((fn (cadr handlers)))
200            (cond ((null fn) (throw tag condition))
201                  ((fixnump fn) (throw tag (cons fn condition)))
202                  (t (funcall fn condition)))))))))
203
204(defvar *error-print-circle* nil)   ; reset to T when we actually can print-circle
205
206
207
208;;;***********************************
209;;;Mini-evaluator
210;;;***********************************
211
212(defun new-lexical-environment (&optional parent)
213  (%istruct 'lexical-environment parent nil nil nil nil nil nil))
214
215(defmethod make-load-form ((e lexical-environment) &optional env)
216  (declare (ignore env))
217  nil)
218
219(defun new-definition-environment (&optional (type 'compile-file))
220  (%istruct 'definition-environment (list type)  nil nil nil nil nil nil nil nil nil nil nil nil ))
221
222(defun definition-environment (env &optional clean-only &aux parent)
223  (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment))
224  (do* () 
225       ((or (null env) 
226            (listp (setq parent (lexenv.parent-env env)))
227            (and clean-only (or (lexenv.variables env) (lexenv.functions env)))))
228    (setq env parent))
229  (if (consp parent)
230    env))
231
232(defvar *symbol-macros* (make-hash-table :test #'eq))
233
234(defun %define-symbol-macro (name expansion)
235  (if (or (constant-symbol-p name)
236          (proclaimed-special-p name))
237      (signal-program-error "Symbol ~s already globally defined as a ~A"
238                            name (if (constant-symbol-p name)
239                                     'constant
240                                     'variable)))
241  (setf (gethash name *symbol-macros*) expansion)
242  name)
243
244(defvar *macroexpand-hook* 'funcall
245  "The value of this variable must be a designator for a function that can
246  take three arguments, a macro expander function, the macro form to be
247  expanded, and the lexical environment to expand in. The function should
248  return the expanded form. This function is called by MACROEXPAND-1
249  whenever a runtime expansion is needed. Initially this is set to
250  FUNCALL.") ; Should be #'funcall.
251;(queue-fixup (setq *macroexpand-hook* #'funcall)) ;  No it shouldn't.
252
253(defun %symbol-macroexpand-1 (sym env)
254  (flet ((expand-it (expansion)
255           (funcall *macroexpand-hook*
256                    (constantly expansion)
257                    sym
258                    env)))
259    (if (and env (not (istruct-typep env 'lexical-environment)))
260      (report-bad-arg env 'lexical-environment))
261    (do* ((env env (lexenv.parent-env env)))
262         ((null env))
263      (if (istruct-typep env 'definition-environment)
264        (let* ((info (assq sym (defenv.symbol-macros env))))
265          (if info
266            (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t))
267            (return)))
268        (let* ((vars (lexenv.variables env)))
269          (dolist (vdecl (lexenv.vdecls env))
270            (if (and (eq (car vdecl) sym)
271                     (eq (cadr vdecl) 'special))
272              (return-from %symbol-macroexpand-1 (values sym nil))))
273          (when (consp vars)
274            (let* ((info (dolist (var vars)
275                           (if (eq (var-name var) sym)
276                             (return var)))))           
277              (when info
278                (if (and (consp (setq info (var-expansion info)))
279                         (eq (%car info) :symbol-macro))
280                  (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t))
281                  (return-from %symbol-macroexpand-1 (values sym nil)))))))))
282    ;; Look it up globally.
283    (multiple-value-bind (expansion win) (gethash sym *symbol-macros*)
284      (if win (values (expand-it expansion) t) (values sym nil)))))
285
286(defun macroexpand-all (form &optional (env (new-lexical-environment)))
287  "Recursivly expand all macros in FORM."
288  (flet ((mexpand (forms env)
289           (mapcar (lambda (form) (macroexpand-all form env)) forms)))
290    (macrolet ((destructuring-bind-body (binds form &body body)
291                 (if (eql '&body (first (last binds)))
292                   (let ((&body (gensym "&BODY")))
293                     `(destructuring-bind ,(append (butlast binds) (list '&body &body))
294                          ,form
295                        (multiple-value-bind (body decls)
296                            (parse-body ,&body env nil)
297                          ,@body)))
298                   `(destructuring-bind ,binds ,form ,@body))))
299      (multiple-value-bind (expansion win)
300          (macroexpand-1 form env)
301        (if win
302          (macroexpand-all expansion env)
303          (if (atom form)
304            form
305            (case (first form)
306              (macrolet
307               (destructuring-bind-body (macros &body) (rest form)
308                (setf env (augment-environment env
309                                               :macro (mapcar (lambda (macro)
310                                                                (destructuring-bind
311                                                                      (name arglist &body body)
312                                                                    macro
313                                                                  (list name (enclose (parse-macro name arglist body env)))))
314                                                              macros)
315                                               :declare (decl-specs-from-declarations decls)))
316                (let ((body (mexpand body env)))
317                  (if decls
318                    `(locally ,@decls ,@body)
319                    `(progn ,@body)))))
320              (symbol-macrolet
321               (destructuring-bind-body (symbol-macros &body) (rest form)
322                (setf env (augment-environment env :symbol-macro symbol-macros :declare (decl-specs-from-declarations decls)))
323                (let ((body (mexpand body env)))
324                  (if decls
325                    `(locally ,@decls ,@body)
326                    `(progn ,@body)))))
327              ((let let* compiler-let)
328               (destructuring-bind-body (bindings &body) (rest form)
329                `(,(first form)
330                   ,(mapcar (lambda (binding)
331                             
332                              (if (listp binding)
333                                (list (first binding) (macroexpand-all (second binding) env))
334                                binding))
335                            bindings)
336                   ,@decls
337                   ,@(mexpand body env))))
338              ((flet labels)
339               (destructuring-bind-body (bindings &body) (rest form)
340                 (let ((augmented-env
341                        (augment-environment env :function (mapcar #'car bindings))))
342                  `(,(first form)
343                     ,(mapcar (lambda (binding)
344                                (list* (first binding)
345                                       (cdr (macroexpand-all `(lambda ,@(rest binding))
346                                                             (if (eq (first form) 'labels)
347                                                                 augmented-env
348                                                                 env)))))
349                              bindings)
350                     ,@decls
351                     ,@(mexpand body augmented-env)))))
352              (nfunction (list* 'nfunction (second form) (macroexpand-all (third form) env)))
353              (function
354                 (if (and (consp (second form))
355                          (eql 'lambda (first (second form))))
356                   (destructuring-bind (lambda arglist &body body&decls)
357                       (second form)
358                     (declare (ignore lambda))
359                     (multiple-value-bind (body decls)
360                         (parse-body body&decls env)
361                       `(lambda ,arglist ,@decls ,@(mexpand body env))))
362                   form))
363              ((eval-when the locally block return-from)
364                 (list* (first form) (second form) (mexpand (cddr form) env)))
365              (setq
366                 `(setq ,@(loop for (name value) on (rest form) by #'cddr
367                                collect name
368                                collect (macroexpand-all value env))))
369              ((go quote) form)
370              ((fbind with-c-frame with-variable-c-frame ppc-lap-function)
371               (error "Unable to macroexpand ~S." form))
372              ((catch if load-time-value multiple-value-call multiple-value-prog1 progn
373                progv tagbody throw unwind-protect)
374               (cons (first form) (mexpand (rest form) env)))
375              (t
376               ;; need to check that (first form) is either fboundp or a local function...
377               (cons (first form) (mexpand (rest form) env))))))))))
378
379(defun macroexpand-1 (form &optional env &aux fn)
380  "If form is a macro (or symbol macro), expand it once. Return two values,
381   the expanded form and a T-or-NIL flag indicating whether the form was, in
382   fact, a macro. ENV is the lexical environment to expand in, which defaults
383   to the null environment."
384  (declare (resident))
385  (if (and (consp form)
386           (symbolp (%car form)))
387    (if (setq fn (macro-function (%car form) env))
388      (values (funcall *macroexpand-hook* fn form env) t)
389      (values form nil))
390    (if (and form (symbolp form))
391      (%symbol-macroexpand-1 form env)
392      (values form nil))))
393
394(defun macroexpand (form &optional env)
395  "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
396   Returns the final resultant form, and T if it was expanded. ENV is the
397   lexical environment to expand in, or NIL (the default) for the null
398   environment."
399  (declare (resident))
400  (multiple-value-bind (new win) (macroexpand-1 form env)
401    (do* ((won-at-least-once win))
402         ((null win) (values new won-at-least-once))
403      (multiple-value-setq (new win) (macroexpand-1 new env)))))
404
405(defun %symbol-macroexpand (form env &aux win won)
406  ; Keep expanding until no longer a symbol-macro or no longer a symbol.
407  (loop
408    (unless (and form (symbolp form)) (return))
409    (multiple-value-setq (form win) (macroexpand-1 form env))
410    (if win (setq won t) (return)))
411  (values form won))
412
413(defun retain-lambda-expression (name lambda-expression env)
414  (if (and (let* ((lambda-list (cadr lambda-expression)))
415             (and (not (memq '&lap lambda-list))
416                  (not (memq '&method lambda-list))
417                  (not (memq '&lexpr lambda-list))))
418           (nx-declared-inline-p name env)
419           (not (gethash name *nx1-alphatizers*))
420           ; A toplevel definition defined inside a (symbol-)macrolet should
421           ; be inlineable.  It isn't; call DEFINITION-ENVIRONMENT with a
422           ; "clean-only" argument to ensure that there are no lexically
423           ; bound macros or symbol-macros.
424           (definition-environment env t))
425    lambda-expression))
426
427
428(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers)
429  (ecase type
430    (defun nil)
431    (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil
432    (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits)))
433    (defmethod (setq data (list :methods
434                                (%cons-def-info-method lfbits keyvect qualifiers specializers))
435                     lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit))
436                     keyvect nil))
437    (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*))))
438  (vector lfbits keyvect *loading-file-source-file* data))
439
440(defun def-info.lfbits (def-info)
441  (and def-info
442       (let ((lfbits (svref def-info 0)))
443         (if (consp lfbits) (%car lfbits) lfbits))))
444
445(defun def-info.keyvect (def-info)
446  (and def-info (svref def-info 1)))
447
448(defun def-info.file (def-info)
449  (and def-info (svref def-info 2)))
450
451(defun def-info.lambda (def-info)
452  (and def-info
453       (let ((data (svref def-info 3)))
454         (and (eq (car data) 'lambda) data))))
455
456(defun def-info.methods (def-info)
457  (and def-info
458       (let ((data (svref def-info 3)))
459         (and (eq (car data) :methods) (%cdr data)))))
460
461(defun %cons-def-info-method (lfbits keyvect qualifiers specializers)
462  (cons (cons (and keyvect
463                   (if (logbitp $lfbits-aok-bit lfbits)
464                     (and (not (logbitp $lfbits-rest-bit lfbits))
465                          (list keyvect))
466                     keyvect))
467              *loading-file-source-file*)
468        (cons qualifiers specializers)))
469
470(defun def-info-method.keyvect (def-info-method)
471  (let ((kv (caar def-info-method)))
472    (if (listp kv)
473      (values (car kv) t)
474      (values kv  nil))))
475
476(defun def-info-method.file (def-info-method)
477  (cdar def-info-method))
478
479(defun def-info-with-new-methods (def-info new-bits new-methods)
480  (if (and (eq new-methods (def-info.methods def-info))
481           (eql new-bits (def-info.lfbits def-info)))
482    def-info
483    (let ((new (copy-seq def-info))
484          (old-bits (svref def-info 0)))
485      (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits))
486      (setf (svref new 3) (cons :methods new-methods))
487      new)))
488
489(defun def-info.macro-p (def-info)
490  (let ((data (and def-info (svref def-info 3))))
491    (eq (car data) 'macro)))
492
493(defun def-info.function-p (def-info)
494  (not (and def-info (eq (car (svref def-info 3)) 'type))))
495
496(defun def-info.function-type (def-info)
497  (if (null def-info)
498    nil ;; ftype only, for the purposes here, is same as nothing.
499    (let ((data (svref def-info 3)))
500      (ecase (car data)
501        ((nil lambda) 'defun)
502        (:methods 'defgeneric)
503        (macro 'defmacro)
504        (ftype nil)
505        (type nil)))))
506
507(defun def-info.deftype (def-info)
508  (and def-info
509       (let ((bits (svref def-info 0)))
510         ;; bits or (bits . type-source-file)
511         (and (consp bits) bits))))
512
513(defun def-info.deftype-type (def-info)
514  ;; 'class (for defclass/defstruct) or 'macro (for deftype et. al.)
515  (and def-info
516       (consp (svref def-info 0))
517       (svref def-info 1)))
518
519(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x))))
520
521(defvar *compiler-warn-on-duplicate-definitions* t)
522
523(defun combine-deftype-infos (name def-info old-deftype new-deftype)
524  (when (or new-deftype old-deftype)
525    (when (and old-deftype new-deftype *compiler-warn-on-duplicate-definitions*)
526      (nx1-whine :duplicate-definition
527                 `(type ,name)
528                 (cdr old-deftype)
529                 (cdr new-deftype)))
530    (let ((target (if new-deftype
531                      (or (cdr new-deftype) (cdr old-deftype))
532                      (cdr old-deftype)))
533          (target-deftype (def-info.deftype def-info)))
534      (unless (and target-deftype (eq (cdr target-deftype) target))
535        (setq def-info (copy-seq (or def-info '#(nil nil nil (ftype)))))
536        (setf (svref def-info 0) (cons (def-info.lfbits def-info) target)))))
537  def-info)
538
539#+debug
540(defun describe-def-info (def-info)
541  (list :lfbits (def-info.lfbits def-info)
542        :keyvect (def-info.keyvect def-info)
543        :macro-p (def-info.macro-p def-info)
544        :function-p (def-info.function-p def-info)
545        :lambda (and (def-info.function-p def-info) (def-info.lambda def-info))
546        :methods (and (def-info.function-p def-info) (def-info.methods def-info))
547        :function-type (def-info.function-type def-info)
548        :deftype (def-info.deftype def-info)
549        :deftype-type (def-info.deftype-type def-info)))
550
551(defun combine-gf-def-infos (name old-info new-info)
552  (let* ((old-bits (def-info.lfbits old-info))
553         (new-bits (def-info.lfbits new-info))
554         (old-methods (def-info.methods old-info))
555         (new-methods (def-info.methods new-info)))
556    (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits))
557      (when *compiler-warn-on-duplicate-definitions*
558        (nx1-whine :duplicate-definition
559                   name
560                   (def-info.file old-info)
561                   (def-info.file new-info)))
562      (return-from combine-gf-def-infos new-info))
563    (unless (congruent-lfbits-p old-bits new-bits)
564      (if (logbitp $lfbits-gfn-bit new-bits)
565        ;; A defgeneric, incongruent with previously defined methods
566        (nx1-whine :incongruent-gf-lambda-list name)
567        ;; A defmethod incongruent with previously defined explicit or implicit generic
568        (nx1-whine :incongruent-method-lambda-list
569                   (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name)
570                   name))
571      ;; Perhaps once this happens, should just mark it somehow to not complain again
572      (return-from combine-gf-def-infos 
573        (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info)))
574    (loop for new-method in new-methods
575          as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr)
576          do (when old
577               (when *compiler-warn-on-duplicate-definitions*
578                 (nx1-whine :duplicate-definition
579                            `(:method ,@(cadr new-method) ,name ,(cddr new-method))
580                            (def-info-method.file (car old))
581                            (def-info-method.file new-method)))
582               (setq old-methods (remove (car old) old-methods :test #'eq)))
583          do (push new-method old-methods))
584    (cond ((logbitp $lfbits-gfn-bit new-bits)
585           ;; If adding a defgeneric, use its info.
586           (setq old-info new-info old-bits new-bits))
587          ((not (logbitp $lfbits-gfn-bit old-bits))
588           ;; If no defgeneric (yet?) just remember whether any method has &key
589           (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit))))))
590    ;; Check that all methods implement defgeneric keys
591    (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info))))
592      (when (> (length gfkeys) 0)
593        (loop for minfo in old-methods
594              do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo)
595                   (when (and mkeys
596                              (not aok)
597                              (setq mkeys (loop for gk across gfkeys
598                                                unless (find gk mkeys) collect gk)))
599                     (nx1-whine :gf-keys-not-accepted
600                                `(:method ,@(cadr minfo) ,name ,(cddr minfo))
601                                mkeys))))))
602    (def-info-with-new-methods old-info old-bits old-methods)))
603
604(defun combine-definition-infos (name old-info new-info)
605  (let ((old-type (def-info.function-type old-info))
606        (old-deftype (def-info.deftype old-info))
607        (new-type (def-info.function-type new-info))
608        (new-deftype (def-info.deftype new-info)))
609    (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric))
610           (setq new-info (combine-gf-def-infos name old-info new-info)))
611          ((or (eq (or old-type 'defun) (or new-type 'defun))
612               (eq (or old-type 'defgeneric) (or new-type 'defgeneric)))
613           (when (and old-type new-type *compiler-warn-on-duplicate-definitions*)
614             (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info)))
615           (unless new-info (setq new-info old-info)))
616          (t
617           (when (and (def-info.function-p old-info) (def-info.function-p new-info)
618                      *compiler-warn-on-duplicate-definitions*)
619             (apply #'nx1-whine :duplicate-definition
620                    name
621                    (def-info.file old-info)
622                    (def-info.file new-info)
623                    (cond ((eq old-type 'defmacro) '("macro" "function"))
624                          ((eq new-type 'defmacro) '("function" "macro"))
625                          ((eq old-type 'defgeneric) '("generic function" "function"))
626                          (t '("function" "generic function")))))
627           (unless new-type (setq new-info old-info))))
628    (combine-deftype-infos name new-info old-deftype new-deftype)))
629
630(defun record-definition-info (name info env)
631  (let* ((definition-env (definition-environment env)))
632    (if definition-env
633      (let* ((defs (defenv.defined definition-env))
634             (already (if (listp defs) (assq name defs) (gethash name defs))))
635        (if already
636          (setf (%cdr already) (combine-definition-infos name (%cdr already) info))
637          (let ((outer (loop for defer = (cdr (defenv.type definition-env))
638                               then (deferred-warnings.parent defer)
639                             while (typep defer 'deferred-warnings)
640                             thereis (gethash name (deferred-warnings.defs defer)))))
641            (when outer
642              (setq info (combine-definition-infos name (%cdr outer) info)))
643            (let ((new (cons name info)))
644              (if (listp defs)
645                (setf (defenv.defined definition-env) (cons new defs))
646                (setf (gethash name defs) new)))))
647        info))))
648
649(defun record-function-info (name info env)
650  (record-definition-info name info env))
651
652;;; This is different from AUGMENT-ENVIRONMENT.
653(defun note-function-info (name lambda-expression env)
654  (let* ((info nil)
655         (name (maybe-setf-function-name name)))
656    (when (lambda-expression-p lambda-expression)
657      (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t)
658        (setq info (%cons-def-info 'defun lfbits keyvect
659                                   (retain-lambda-expression name lambda-expression env)))))
660    (record-function-info name info env))
661  name)
662
663(defun note-type-info (name kind env)
664  (record-definition-info name (%cons-def-info 'deftype nil kind) env))
665
666
667; And this is different from FUNCTION-INFORMATION.
668(defun retrieve-environment-function-info (name env)
669 (let ((defenv (definition-environment env)))
670   (when defenv
671     (let* ((defs (defenv.defined defenv))
672            (sym (maybe-setf-function-name name))
673            (info (if (listp defs) (assq sym defs) (gethash sym defs))))
674       (and info (def-info.function-p (cdr info)) info)))))
675
676;;; Must differ from -something-, but not sure what ...
677(defun note-variable-info (name info env)
678  (let ((definition-env (definition-environment env)))
679    (if definition-env (push (cons name info) (defenv.specials definition-env)))
680    name))
681
682(defun compile-file-environment-p (env)
683  (let ((defenv (definition-environment env)))
684    (and defenv (eq 'compile-file (car (defenv.type defenv))))))
685
686;; This is EVAL.
687(defun cheap-eval (form)
688  ;; Don't record source locations for explicit calls to EVAL.
689  (let ((*nx-source-note-map* nil))
690    (cheap-eval-in-environment form nil)))
691
692; used by nfcomp too
693; Should preserve order of decl-specs; it sometimes matters.
694(defun decl-specs-from-declarations (declarations)
695  (let ((decl-specs nil))
696    (dolist (declaration declarations decl-specs)
697      ;(unless (eq (car declaration) 'declare) (say "what"))
698      (dolist (decl-spec (cdr declaration))
699        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
700
701(defun cheap-eval-macroexpand-1 (form env)
702  (multiple-value-bind (new win) (macroexpand-1 form env)
703    (when win
704      (note-source-transformation form new))
705    (values new win)))
706
707(defun cheap-eval-transform (original new)
708  (note-source-transformation original new)
709  new)
710
711(defun cheap-eval-function (name lambda env)
712  (multiple-value-bind (lfun warnings)
713                       (compile-named-function lambda
714                                               :name name
715                                               :env env
716                                               :function-note *loading-toplevel-location*
717                                               :keep-lambda *save-definitions*
718                                               :keep-symbols *save-local-symbols*
719                                               :source-notes *nx-source-note-map*)
720    (signal-or-defer-warnings warnings env)
721    lfun))
722
723(fset 'nx-source-note (nlambda bootstrapping-source-note (form) (declare (ignore form)) nil))
724
725(defun cheap-eval-in-environment (form env &aux sym)
726  (declare (resident))
727  ;; records source locations if *nx-source-note-map* is bound by caller
728  (setq *loading-toplevel-location* (or (nx-source-note form) *loading-toplevel-location*))
729  (flet ((progn-in-env (body&decls parse-env base-env)
730           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
731             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
732             (loop with default-location = *loading-toplevel-location*
733               while (cdr body) as form = (pop body)
734               do (cheap-eval-in-environment form base-env)
735               do (setq *loading-toplevel-location* default-location))
736             (cheap-eval-in-environment (car body) base-env))))
737    (if form
738      (cond ((symbolp form) 
739             (multiple-value-bind (expansion win) (cheap-eval-macroexpand-1 form env)
740               (if win 
741                 (cheap-eval-in-environment expansion env)
742                 (let* ((defenv (definition-environment env))
743                        (constant (if defenv (assq form (defenv.constants defenv))))
744                        (constval (%cdr constant)))
745                   (if constant
746                     (if (neq (%unbound-marker-8) constval)
747                       constval
748                       (error "Can't determine value of constant symbol ~s" form))
749                     (if (constant-symbol-p form)
750                       (%sym-global-value form)
751                       (symbol-value form)))))))
752            ((atom form) form)
753            ((eq (setq sym (%car form)) 'quote)
754             (verify-arg-count form 1 1)
755             (%cadr form))
756            ((eq sym 'function)
757             (verify-arg-count form 1 1)
758             (cond ((symbolp (setq sym (%cadr form)))
759                    (multiple-value-bind (kind local-p)
760                        (function-information sym env)
761                      (if (and local-p (eq kind :macro))
762                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
763                    (%function sym))
764                   ((setf-function-name-p sym)
765                    (multiple-value-bind (kind local-p)
766                        (function-information sym env)
767                      (if (and local-p (eq kind :macro))
768                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
769                    (%function (setf-function-name (%cadr sym))))
770                   (t (cheap-eval-function nil sym env))))
771            ((eq sym 'nfunction)
772             (verify-arg-count form 2 2)
773             (cheap-eval-function (%cadr form) (%caddr form) env))
774            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
775            ((eq sym 'setq)
776             (if (not (%ilogbitp 0 (list-length form)))
777               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
778             (let* ((sym nil)
779                    (val nil)
780                    (original form))
781               (while (setq form (%cdr form))
782                 (setq sym (require-type (pop form) 'symbol))
783                 (multiple-value-bind (expansion expanded)
784                                      (cheap-eval-macroexpand-1 sym env)
785                   (if expanded
786                     (setq val (cheap-eval-in-environment
787                                (cheap-eval-transform original `(setf ,expansion ,(%car form)))
788                                env))
789                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
790               val))
791            ((eq sym 'eval-when)
792             (destructuring-bind (when . body) (%cdr form)
793               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
794            ((eq sym 'if)
795             (destructuring-bind (test true &optional false) (%cdr form)
796               (setq test (let ((*loading-toplevel-location* *loading-toplevel-location*))
797                            (cheap-eval-in-environment test env)))
798               (cheap-eval-in-environment (if test true false) env)))
799            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
800            ((eq sym 'symbol-macrolet)
801             (multiple-value-bind (body decls) (parse-body (cddr form) env)
802               (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls)))))
803            ((eq sym 'macrolet)
804             (let ((temp-env (augment-environment env
805                                                  :macro 
806                                                  (mapcar #'(lambda (m)
807                                                              (destructuring-bind (name arglist &body body) m
808                                                                (list name (enclose (parse-macro name arglist body env)
809                                                                                    env))))
810                                                          (cadr form)))))
811               (progn-in-env (cddr form) temp-env temp-env)))
812            ((and (symbolp sym) 
813                  (compiler-special-form-p sym)
814                  (not (functionp (fboundp sym))))
815             (if (eq sym 'unwind-protect)
816               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
817                 (unwind-protect
818                     (let ((*loading-toplevel-location* *loading-toplevel-location*))
819                       (cheap-eval-in-environment protected-form env))
820                   (progn-in-env cleanup-forms env env)))
821               (let ((fn (cheap-eval-function nil (cheap-eval-transform form `(lambda () (progn ,form))) env)))
822                 (funcall fn))))
823            ((and (symbolp sym) (macro-function sym env))
824             (cheap-eval-in-environment (cheap-eval-macroexpand-1 form env) env))
825            ((or (symbolp sym)
826                 (and (consp sym) (eq (%car sym) 'lambda)))
827             (let ((args nil) (form-location *loading-toplevel-location*))
828               (dolist (elt (%cdr form))
829                 (push (cheap-eval-in-environment elt env) args)
830                 (setq *loading-toplevel-location* form-location))
831               (apply #'call-check-regs (if (symbolp sym) sym (cheap-eval-function nil sym env))
832                      (nreverse args))))
833            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
834
835
836(%fhave 'eval #'cheap-eval)
837
838
839
840 
841(defun call-check-regs (fn &rest args)
842  (declare (dynamic-extent args)
843           (optimize (debug 3)))        ; don't use any saved registers
844  (let ((old-regs (multiple-value-list (get-saved-register-values))))
845    (declare (dynamic-extent old-regs))
846    (multiple-value-prog1 (apply fn args)
847      (let* ((new-regs (multiple-value-list (get-saved-register-values)))
848             (new-regs-tail new-regs))
849        (declare (dynamic-extent new-regs))
850        (unless (dolist (old-reg old-regs t)
851                  (unless (eq old-reg (car new-regs-tail))
852                    (return nil))
853                  (pop new-regs-tail))
854          (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}"
855                 fn args
856                 (mapcan 'list
857                         (let ((res nil))
858                           (dotimes (i (length old-regs))
859                             (push (format nil "save~d" i) res))
860                           (nreverse res))
861                         old-regs
862                         new-regs)))))))
863
864
865
866
867
868;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
869;; Stack frame accessors.
870
871; Kinda scant, wouldn't you say ?
872
873
874;end of L1-readloop.lisp
875
Note: See TracBrowser for help on using the repository browser.