source: trunk/source/compiler/nx-basic.lisp @ 12463

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

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