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

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

From working-0711 branch: more extensive compile-time checking involving methods/gfs: warn about incongruent lambda lists, duplicate gf defs, required keyword args (from defgeneric), and invalid keyword args in gf calls. Also fix to keep method source files in env function info so dup method warnings can cite the right file.

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