source: branches/working-0711/ccl/compiler/nx-basic.lisp @ 11776

Last change on this file since 11776 was 11776, checked in by gz, 11 years ago

r11755 from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.4 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
18;; used by compiler and eval - stuff here is not excised with rest of compiler
19
20
21(in-package :ccl)
22
23#|| Note: when MCL-AppGen 4.0 is built, the following form will need to be included in it:
24; for compiler-special-form-p, called by cheap-eval-in-environment
25(defparameter *nx1-compiler-special-forms*
26  `(%DEFUN %FUNCTION %NEW-PTR %NEWGOTAG %PRIMITIVE %VREFLET BLOCK CATCH COMPILER-LET DEBIND
27    DECLARE EVAL-WHEN FBIND FLET FUNCTION GO IF LABELS LAP LAP-INLINE LET LET* LOAD-TIME-VALUE
28    LOCALLY MACRO-BIND MACROLET MAKE-LIST MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL
29    MULTIPLE-VALUE-LIST MULTIPLE-VALUE-PROG1 NEW-LAP NEW-LAP-INLINE NFUNCTION OLD-LAP
30    OLD-LAP-INLINE OR PROG1 PROGN PROGV QUOTE RETURN-FROM SETQ STRUCT-REF STRUCT-SET
31    SYMBOL-MACROLET TAGBODY THE THROW UNWIND-PROTECT WITH-STACK-DOUBLE-FLOATS WITHOUT-INTERRUPTS))
32||#
33
34(eval-when (:compile-toplevel)
35  (require 'nxenv))
36
37(defvar *lisp-compiler-version* 666 "I lost count.")
38
39(defvar *nx-compile-time-types* nil)
40(defvar *nx-proclaimed-types* nil)
41(defvar *nx-method-warning-name* nil)
42
43(defvar *nx-current-code-note*)
44
45;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
46;; hoping to make it go away.
47(defparameter *nx-acode-note-map* nil)
48
49(defun acode-note (acode &aux (hash *nx-acode-note-map*))
50  (and hash (gethash acode hash)))
51
52(defun (setf acode-note) (note acode)
53  (when note
54    (assert *nx-acode-note-map*)
55    (setf (gethash acode *nx-acode-note-map*) note)))
56
57
58(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
59  (when source-notes
60    (when (or (consp form) (vectorp form) (pathnamep form))
61      (let ((note (gethash form source-notes)))
62        (unless (listp note) note)))))
63
64
65(defun note-contained-in-p (note parent)
66  (loop for n = note then (code-note-source n) while (code-note-p n) thereis (eq n parent)))
67
68(defun nx-find-code-note (form)
69  ;; Try to find a source note for this form.  The act of matching up a source note with
70  ;; forms that might come from macroexpansion is heuristic at best.  In general, err in
71  ;; favor of not matching, because that leads to fewer false positives in code coverage
72  ;; reporting.
73  (when (or (consp form) (stringp form) (pathnamep form))
74    (let ((note (gethash form *nx-source-note-map*)))
75      (unless (listp note)
76        note))))
77
78(defun nx-ensure-code-note (form original parent-note)
79  ;; Try to find a source note for this form; if can't, just make a new record for it.
80  (let* ((source-note (or (and original (nx-find-code-note original))
81                          (nx-find-code-note form)))
82         (note (if (and source-note
83                        ;; Look out for a case like a lambda macro that turns (lambda ...)
84                        ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
85                        ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
86                        ;; Another case is forms wrapping THE around themselves.
87                        (neq source-note parent-note)
88                        ;; Don't use source notes from a different toplevel form, which could
89                        ;; happen due to inlining etc.  The result then is that the source note
90                        ;; appears in multiple places, and shows partial coverage (from the
91                        ;; other reference) in code that's never executed.
92                        (loop for p = parent-note then (code-note-parent-note p)
93                              when (null p) return t
94                              when (source-note-p p)
95                              return (let ((n source-note))
96                                       (loop as s = (code-note-source p)
97                                             while (source-note-p s) do (setq p s))
98                                       (loop as s = (code-note-source n)
99                                             while (source-note-p s) do (setq n s))
100                                       (eq n p))))
101                 source-note
102                 (make-code-note :form (or original form) :source parent-note))))
103    (register-code-note-parent note parent-note)
104    note))
105
106(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
107  (when (and source-notes
108             (setq sn (gethash original source-notes))
109             (not (gethash new source-notes)))
110    (setf (gethash new source-notes) sn))
111  (record-form-source-equivalent original new))
112
113
114
115(defvar *nx1-alphatizers* (make-hash-table :size 180 :test #'eq))
116
117(let ((policy (%istruct 'compiler-policy
118               #'(lambda (env)
119                   #+ccl-0711 (< (debug-optimize-quantity env) 2)
120                   #-ccl-0711 (neq (debug-optimize-quantity env) 3))   ;  allow-tail-recursion-elimination
121               #'(lambda (env)
122                   (declare (ignorable env))
123                   #+ccl-0711 nil
124                   #-ccl-0711 (eq (debug-optimize-quantity env) 3))   ; inhibit-register-allocation
125               #'(lambda (env)
126                   (let* ((safety (safety-optimize-quantity env)))
127                     (and (< safety 3)
128                          (>= (speed-optimize-quantity env)
129                              safety)))) ; trust-declarations
130               #'(lambda (env)
131                   #+ccl-0711 (> (speed-optimize-quantity env)
132                                 (space-optimize-quantity env))
133                   #-ccl-0711 (>= (speed-optimize-quantity env)
134                                  (+ (space-optimize-quantity env) 2))) ; open-code-inline
135               #'(lambda (env)
136                   (and (eq (speed-optimize-quantity env) 3) 
137                        (eq (safety-optimize-quantity env) 0)))   ; inhibit-safety-checking
138               #'(lambda (env)
139                   (let* ((safety (safety-optimize-quantity env)))
140                     (or (eq safety 3)
141                         (> safety (speed-optimize-quantity env)))))          ;the-typechecks
142               #'(lambda (env)
143                   (neq (debug-optimize-quantity env) 3))   ; inline-self-calls
144               #'(lambda (env)
145                   (and (neq (compilation-speed-optimize-quantity env) 3)
146                        (neq (safety-optimize-quantity env) 3)
147                        #+ccl-0711 (neq (speed-optimize-quantity env) 0)
148                        (neq (debug-optimize-quantity env) 3))) ; allow-transforms
149               #'(lambda (var env)       ; force-boundp-checks
150                   (declare (ignore var))
151                   (eq (safety-optimize-quantity env) 3))
152               #'(lambda (var val env)       ; allow-constant-substitution
153                   (declare (ignore var val env))
154                   t)
155               nil           ; extensions
156               )))
157  (defun new-compiler-policy (&key (allow-tail-recursion-elimination nil atr-p)
158                                   (inhibit-register-allocation nil ira-p)
159                                   (trust-declarations nil td-p)
160                                   (open-code-inline nil oci-p)
161                                   (inhibit-safety-checking nil ischeck-p)
162                                   (inline-self-calls nil iscall-p)
163                                   (allow-transforms nil at-p)
164                                   (force-boundp-checks nil fb-p)
165                                   (allow-constant-substitution nil acs-p)
166                                   (the-typechecks nil tt-p))
167    (let ((p (copy-uvector policy)))
168      (if atr-p (setf (policy.allow-tail-recursion-elimination p) allow-tail-recursion-elimination))
169      (if ira-p (setf (policy.inhibit-register-allocation p) inhibit-register-allocation))
170      (if td-p (setf (policy.trust-declarations p) trust-declarations))
171      (if oci-p (setf (policy.open-code-inline p) open-code-inline))
172      (if ischeck-p (setf (policy.inhibit-safety-checking p) inhibit-safety-checking))
173      (if iscall-p (setf (policy.inline-self-calls p) inline-self-calls))
174      (if at-p (setf (policy.allow-transforms p) allow-transforms))
175      (if fb-p (setf (policy.force-boundp-checks p) force-boundp-checks))
176      (if acs-p (setf (policy.allow-constant-substitution p) allow-constant-substitution))
177      (if tt-p (setf (policy.the-typechecks p) the-typechecks))
178      p))
179  (defun %default-compiler-policy () policy))
180
181(%include "ccl:compiler;lambda-list.lisp")
182
183
184
185;Syntactic Environment Access.
186
187(defun declaration-information (decl-name &optional env)
188  (if (and env (not (istruct-typep env 'lexical-environment)))
189    (report-bad-arg env 'lexical-environment))
190; *** This needs to deal with things defined with DEFINE-DECLARATION ***
191  (case decl-name
192    (optimize
193     (list 
194      (list 'speed (speed-optimize-quantity env))
195      (list 'safety (safety-optimize-quantity env))
196      (list 'compilation-speed (compilation-speed-optimize-quantity env))
197      (list 'space (space-optimize-quantity env))
198      (list 'debug (debug-optimize-quantity env))))
199    (declaration
200     *nx-known-declarations*)))
201
202(defun function-information (name &optional env &aux decls)
203  (let ((name (ensure-valid-function-name name)))
204    (if (and env (not (istruct-typep env 'lexical-environment)))
205      (report-bad-arg env 'lexical-environment))
206    (if (special-operator-p name)
207      (values :special-form nil nil)
208      (flet ((process-new-fdecls (fdecls)
209                                 (dolist (fdecl fdecls)
210                                   (when (eq (car fdecl) name)
211                                     (let ((decl-type (cadr fdecl)))
212                                       (when (and (memq decl-type '(dynamic-extent inline ftype))
213                                                  (not (assq decl-type decls)))
214                                         (push (cdr fdecl) decls)))))))
215        (declare (dynamic-extent #'process-new-fdecls))
216        (do* ((root t)
217              (contour env (when root (lexenv.parent-env contour))))
218             ((null contour)
219              (if (macro-function name)
220                (values :macro nil nil)
221                (if (fboundp name)
222                  (values :function 
223                          nil 
224                          (if (assq 'inline decls)
225                            decls
226                            (if (proclaimed-inline-p name)
227                              (push '(inline . inline) decls)
228                                (if (proclaimed-notinline-p name)
229                                  (push '(inline . notinline) decls)))))
230                  (values nil nil decls))))
231          (if (istruct-typep contour 'definition-environment)
232            (if (assq name (defenv.functions contour))
233              (return (values :macro nil nil))
234              (progn (setq root nil) (process-new-fdecls (defenv.fdecls contour))))
235            (progn
236              (process-new-fdecls (lexenv.fdecls contour))
237              (let ((found (assq name (lexenv.functions contour))))
238                (when found
239                  (return
240                   (if (and (consp (cdr found))(eq (%cadr found) 'macro))
241                     (values :macro t nil)
242                     (values :function t decls))))))))))))
243
244(defun variable-information (var &optional env)
245  (setq var (require-type var 'symbol))
246  (if (and env (not (istruct-typep env 'lexical-environment)))
247    (report-bad-arg env 'lexical-environment))
248  (let* ((vartype nil)
249         (boundp nil)
250         (envtype nil)
251         (typedecls (nx-declared-type var env)) ; should grovel nested/shadowed special decls for us.
252         (decls (if (and typedecls (neq t typedecls)) (list (cons 'type typedecls)))))
253    (loop
254      (cond ((null env)
255             (if (constant-symbol-p var)
256               (setq vartype :constant decls nil)
257               (if (proclaimed-special-p var)
258                 (setq vartype :special)
259                 (let* ((not-a-symbol-macro (cons nil nil)))
260                   (declare (dynamic-extent not-a-symbol-macro))
261                   (unless (eq (gethash var *symbol-macros* not-a-symbol-macro)
262                               not-a-symbol-macro)
263                     (setq vartype :symbol-macro)))))
264             (return))
265            ((eq (setq envtype (istruct-type-name env)) 'definition-environment)
266             (cond ((assq var (defenv.constants env))
267                    (setq vartype :constant)
268                    (return))
269                   ((assq var (defenv.symbol-macros env))
270                    (setq vartype :symbol-macro)
271                    (return))
272                   ((assq var (defenv.specials env))
273                    (setq vartype :special)
274                    (return))))
275            (t
276             (dolist (vdecl (lexenv.vdecls env))
277               (when (eq (car vdecl) var)
278                 (let ((decltype (cadr vdecl)))
279                   (unless (assq decltype decls)
280                     (case decltype
281                       (special (setq vartype :special))
282                       ((type dynamic-extent ignore) (push (cdr vdecl) decls)))))))
283             (let ((vars (lexenv.variables env)))
284               (unless (atom vars)
285                 (dolist (v vars)
286                   (when (eq (var-name v) var)
287                     (setq boundp t)
288                     (if (and (consp (var-ea v))
289                              (eq :symbol-macro (car (var-ea v))))
290                       (setq vartype :symbol-macro)
291                       (unless vartype (setq vartype
292                                             (let* ((bits (var-bits v)))
293                                               (if (and (typep bits 'integer)
294                                                        (logbitp $vbitspecial bits))
295                                                 :special
296                                                 :lexical)))))
297                     (return)))
298                 (when vartype (return))))))
299      (setq env (if (eq envtype 'lexical-environment) (lexenv.parent-env env))))
300    (values vartype boundp decls)))
301
302(defun nx-target-type (typespec)
303  ;; Could do a lot more here
304  (if (or (eq *host-backend* *target-backend*)
305          (not (eq typespec 'fixnum)))
306    typespec
307    (target-word-size-case
308     (32 '(signed-byte 30))
309     (64 '(signed-byte 61)))))
310
311; Type declarations affect all references.
312(defun nx-declared-type (sym &optional (env *nx-lexical-environment*))
313  (loop
314    (when (or (null env) (istruct-typep env 'definition-environment)) (return))
315    (dolist (decl (lexenv.vdecls env))
316      (if (and (eq (car decl) sym)
317               (eq (cadr decl) 'type))
318               (return-from nx-declared-type (nx-target-type (cddr decl)))))
319    (let ((vars (lexenv.variables env)))
320      (when (and (consp vars) 
321                 (dolist (var vars) 
322                   (when (eq (var-name var) sym) 
323                     (return t))))
324        (return-from nx-declared-type t)))
325    (setq env (lexenv.parent-env env)))
326  (let ((decl (or (assq sym *nx-compile-time-types*)
327                     (assq sym *nx-proclaimed-types*))))
328    (if decl (%cdr decl) t)))
329
330(defmacro define-declaration (decl-name lambda-list &body body &environment env)
331  (multiple-value-bind (body decls)
332                       (parse-body body env)
333    (let ((fn `(nfunction (define-declaration ,decl-name)
334                          (lambda ,lambda-list
335                            ,@decls
336                            (block ,decl-name
337                              ,@body)))))
338      `(progn
339         (proclaim '(declaration ,decl-name))
340         (setf (getf *declaration-handlers* ',decl-name) ,fn)))))
341
342(defun check-environment-args (variable symbol-macro function macro)
343  (flet ((check-all-pairs (pairlist argname)
344          (dolist (pair pairlist)
345            (unless (and (consp pair) (consp (%cdr pair)) (null (%cddr pair)) (symbolp (%car pair)))
346              (signal-simple-program-error "Malformed ~s argument: ~s is not of the form (~S ~S) in ~S" 
347                                           argname
348                                           pair
349                                           'name
350                                           'definition
351                                           pairlist))))
352         (check-all-symbols (symlist argname pairs pairsname)
353          (dolist (v symlist)
354            (unless (symbolp v) 
355              (signal-simple-program-error "Malformed ~S list: ~S is not a symbol in ~S." argname v symlist))
356            (when (assq v pairs) 
357              (signal-simple-program-error "~S ~S conflicts with ~S ~S" argname v pairsname (assq v pairs))))))
358    (check-all-pairs symbol-macro :symbol-macro)
359    (check-all-pairs macro :macro)
360    (check-all-symbols variable :variable symbol-macro :symbol-macro)
361    (check-all-symbols function :function macro :macro)))
362
363
364;; This -isn't- PARSE-DECLARATIONS.  It can't work; neither can this ...
365(defun process-declarations (env decls symbol-macros)
366  (let ((vdecls nil)
367        (fdecls nil)
368        (mdecls nil))
369    (flet ((add-type-decl (spec)
370            (destructuring-bind (typespec &rest vars) spec
371              (dolist (var vars)
372                (when (non-nil-symbol-p var)
373                  (push (list* var 
374                               'type
375                               (let ((already (assq 'type (nth-value 2 (variable-information var env)))))
376                                 (if already
377                                   (let ((oldtype (%cdr already)))
378                                     (if oldtype
379                                       (if (subtypep oldtype typespec)
380                                         oldtype
381                                         (if (subtypep typespec oldtype)
382                                           typespec))))
383                                   typespec)))
384                        vdecls))))))
385      ; do SPECIAL declarations first - this approximates the right thing, but doesn't quite make it.
386      (dolist (decl decls)
387        (when (eq (car decl) 'special)
388          (dolist (spec (%cdr decl))
389            (when (non-nil-symbol-p spec)
390              (if (assq spec symbol-macros)
391                (signal-program-error "Special declaration cannot be applied to symbol-macro ~S" spec))
392              (push (list* spec 'special t) vdecls)))))
393      (dolist (decl decls)
394        (let ((decltype (car decl)))
395          (case decltype
396              ((inline notinline)
397               (dolist (spec (%cdr decl))
398               (let ((fname nil))
399                 (if (non-nil-symbol-p spec)
400                   (setq fname spec)
401                   (if (and (consp spec) (eq (%car spec) 'setf))
402                     (setq fname (setf-function-name (cadr spec)))))
403                 (if fname
404                   (push (list* fname decltype t) fdecls)))))
405              (optimize
406               (dolist (spec (%cdr decl))
407                 (let ((val 3)
408                       (quantity spec))
409                   (if (consp spec)
410                     (setq quantity (car spec) val (cadr spec)))
411                 (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
412                   (push (cons quantity val) mdecls)))))
413              (dynamic-extent
414               (dolist (spec (%cdr decl))
415               (if (non-nil-symbol-p spec)
416                 (push (list* spec decltype t) vdecls)
417                 (if (and (consp spec) (eq (%car spec) 'function))
418                   (let ((fname (cadr spec)))
419                     (if (not (non-nil-symbol-p fname))
420                       (setq fname 
421                             (if (and (consp fname) (eq (%car fname) 'setf))
422                               (setf-function-name (cadr fname)))))
423                     (if fname (push (list* fname decltype t) fdecls)))))))
424              (type (add-type-decl (cdr decl)))
425              (ftype (destructuring-bind (typespec &rest fnames) (%cdr decl)
426                       (dolist (name fnames)
427                         (let ((fname name))
428                           (if (not (non-nil-symbol-p fname))
429                             (setq fname 
430                                   (if (and (consp fname) (eq (%car fname) 'setf))
431                                     (setf-function-name (cadr fname)))))
432                           (if fname (push (list* fname decltype typespec) fdecls))))))
433              (special)
434              (t
435               (if (memq decltype *cl-types*)
436                 (add-type-decl decl)
437                 (let ((handler (getf *declaration-handlers* decltype)))
438                   (when handler
439                     (multiple-value-bind (type info) (funcall handler decl)
440                       (ecase type
441                         (:variable
442                          (dolist (v info) (push (apply #'list* v) vdecls)))
443                         (:function
444                          (dolist (f info) (push (apply #'list* f) fdecls)))
445                         (:declare  ;; N.B. CLtL/2 semantics
446                          (push info mdecls)))))))))))
447      (setf (lexenv.vdecls env) (nconc vdecls (lexenv.vdecls env))
448            (lexenv.fdecls env) (nconc fdecls (lexenv.fdecls env))
449            (lexenv.mdecls env) (nconc mdecls (lexenv.mdecls env))))))
450
451 
452(defun cons-var (name &optional (bits 0))
453  (%istruct 'var name bits nil nil nil nil nil))
454
455
456(defun augment-environment (env &key variable symbol-macro function macro declare)
457  (if (and env (not (istruct-typep env 'lexical-environment)))
458    (report-bad-arg env 'lexical-environment))
459  (check-environment-args variable symbol-macro function macro)
460  (let* ((vars (mapcar #'cons-var variable))
461         (symbol-macros (mapcar #'(lambda (s)
462                                    (let* ((sym (car s)))
463                                      (unless (and (symbolp sym)
464                                                   (not (constantp sym env))
465                                                   (not (eq (variable-information sym env) :special)))
466                                        (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
467                                      (let ((v (cons-var (car s)))) 
468                                        (setf (var-expansion v) (cons :symbol-macro (cadr s)))
469                                        v)))
470                                symbol-macro))
471         (macros (mapcar #'(lambda (m) (list* (car m) 'macro (cadr m))) macro))
472         (functions (mapcar #'(lambda (f) (list* f 'function nil)) function))
473         (new-env (new-lexical-environment env)))
474    (setf (lexenv.variables new-env) (nconc vars symbol-macros)
475          (lexenv.functions new-env) (nconc functions macros))
476    (process-declarations new-env declare symbol-macro)
477    new-env))
478
479(defun enclose (lambda-expression &optional env)
480  (if (and env (not (istruct-typep env 'lexical-environment)))
481    (report-bad-arg env 'lexical-environment))
482  (unless (lambda-expression-p lambda-expression)
483    (error "Invalid lambda-expression ~S." lambda-expression))
484  (%make-function nil lambda-expression env))
485
486#|| Might be nicer to do %declaim
487(defmacro declaim (&rest decl-specs &environment env)
488  `(progn
489     (eval-when (:load-toplevel :execute)
490       (proclaim ',@decl-specs))
491     (eval-when (:compile-toplevel)
492       (%declaim ',@decl-specs ,env))))
493||#
494
495(defmacro declaim (&environment env &rest decl-specs)
496  "DECLAIM Declaration*
497  Do a declaration or declarations for the global environment."
498  (let* ((body (mapcar #'(lambda (spec) `(proclaim ',spec)) decl-specs)))
499  `(progn
500     (eval-when (:compile-toplevel)
501       (compile-time-proclamation ',decl-specs ,env))
502     (eval-when (:load-toplevel :execute)
503       ,@body))))
504
505;;; If warnings have more than a single entry on their
506;;; args slot, don't merge them.
507(defun merge-compiler-warnings (old-warnings)
508  (let ((warnings nil))
509    (dolist (w old-warnings)
510      (let* ((w-args (compiler-warning-args w)))
511        (if
512          (or (cdr w-args)
513              (dolist (w1 warnings t) 
514                (let ((w1-args (compiler-warning-args w1)))
515                  (when (and (eq (compiler-warning-warning-type w)
516                                 (compiler-warning-warning-type w1))
517                             w1-args
518                             (null (cdr w1-args))
519                             (eq (%car w-args)
520                                 (%car w1-args)))
521                    (incf (compiler-warning-nrefs w1))
522                    (return)))))
523          (push w warnings))))
524    warnings))
525
526;;; This is called by, e.g., note-function-info & so can't be -too- funky ...
527;;; don't call proclaimed-inline-p or proclaimed-notinline-p with alphatized crap
528
529(defun nx-declared-inline-p (sym env)
530  (setq sym (maybe-setf-function-name sym))
531  (loop
532    (when (listp env)
533      (return (and (symbolp sym)
534                   (proclaimed-inline-p sym))))
535    (dolist (decl (lexenv.fdecls env))
536      (when (and (eq (car decl) sym)
537                 (eq (cadr decl) 'inline))
538        (return-from nx-declared-inline-p (eq (cddr decl) 'inline))))
539    (setq env (lexenv.parent-env env))))
540
541(defun report-compile-time-argument-mismatch (condition stream)
542  (destructuring-bind (callee reason args spread-p)
543      (compiler-warning-args condition)
544    (format stream "In the ~a ~s with arguments ~:s,~%  "
545            (if spread-p "application of" "call to")
546            callee
547            args)
548    (case (car reason)
549      (:toomany
550       (destructuring-bind (provided max)
551           (cdr reason)
552         (format stream "~d argument~p were provided, but at most ~d ~a accepted~&  by " provided provided max (if (eql max 1) "is" "are"))))
553      (:toofew
554       (destructuring-bind (provided min)
555           (cdr reason)
556         (format stream "~d argument~p were provided, but at least ~d ~a required~&  by " provided provided min (if (eql min 1) "is" "are") )))
557      (:odd-keywords
558       (let* ((tail (cadr reason)))
559         (format stream "the variable portion of the argument list ~s contains an odd number~&  of arguments and so can't be used to initialize keyword parameters~&  for " tail)))
560      (:unknown-keyword
561       (destructuring-bind (badguy goodguys)
562           (cdr reason)
563         (format stream "the keyword argument ~s is not one of ~s, which are recognized~&  by " badguy goodguys))))
564    (format stream
565            (ecase (compiler-warning-warning-type condition)       
566              (:global-mismatch "the current global definition of ~s")
567              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
568              (:lexical-mismatch "the lexically visible definition of ~s"))
569            callee)))
570
571(defparameter *compiler-warning-formats*
572  '((:special . "Undeclared free variable ~S")
573    (:unused . "Unused lexical variable ~S")
574    (:ignore . "Variable ~S not ignored.")
575    (:undefined-function . "Undefined function ~S")
576    (:unknown-declaration . "Unknown declaration ~S")
577    (:unknown-type-declaration . "Unknown type ~S")
578    (:unknown-declaration-variable . "~s declaration for unknown variable ~s")
579    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
580    (:unsettable . "Shouldn't assign to variable ~S")
581    (:global-mismatch . report-compile-time-argument-mismatch)
582    (:environment-mismatch . report-compile-time-argument-mismatch)
583    (:lexical-mismatch . report-compile-time-argument-mismatch)   
584    (:type . "Type declarations violated in ~S")
585    (:type-conflict . "Conflicting type declarations for ~S")
586    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
587    (:lambda . "Suspicious lambda-list: ~s")
588    (:result-ignored . "Function result ignored in call to ~s")
589    (:duplicate-definition . report-compile-time-duplicate-definition)
590    (:program-error . "~a")
591    (:unsure . "Nonspecific warning")))
592
593(defun report-compile-time-duplicate-definition (condition stream)
594  (destructuring-bind (name old-file new-file &optional from to) (compiler-warning-args condition)
595    (format stream
596            "Duplicate definitions of ~s~:[~*~;~:* (as a ~a and a ~a)~]~:[~;, in this file~:[~; and in ~s~]~]"
597            (maybe-setf-name name) from to
598            (and old-file new-file)
599            (neq old-file new-file)
600            old-file)))
601
602(defun adjust-compiler-warning-args (warning-type args)
603  (case warning-type
604    ((:undefined-function :result-ignored) (mapcar #'maybe-setf-name args))
605    (t args)))
606
607
608(defun report-compiler-warning (condition stream)
609  (let* ((warning-type (compiler-warning-warning-type condition))
610         (format-string (cdr (assq warning-type *compiler-warning-formats*)))
611         (name (reverse (compiler-warning-function-name condition))))
612    (format stream "In ")
613    (print-nested-name name stream)
614    (when (every #'null name)
615      (let ((position (compiler-warning-stream-position condition)))
616        (when position (format stream " at position ~s" position))))
617    (format stream ": ")
618    (if (typep format-string 'string)
619      (apply #'format stream format-string (adjust-compiler-warning-args warning-type (compiler-warning-args condition)))
620      (funcall format-string condition stream))
621    ;(format stream ".")
622    (let ((nrefs (compiler-warning-nrefs condition)))
623      (when (and nrefs (neq nrefs 1))
624        (format stream " (~D references)" nrefs)))))
625
626(defun environment-structref-info (name env)
627  (let ((defenv (definition-environment env)))
628    (when defenv
629      (cdr (assq name (defenv.structrefs defenv))))))
630
631; end
Note: See TracBrowser for help on using the repository browser.