source: trunk/source/level-1/sysutils.lisp @ 12219

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

Extend the mechanism used to warn about undefined and duplicate functions in a
compilation unit to do the same for types, use it for types defined by
deftype/defstruct/defclass.

Also make proclaim-type err on invalid types and warn about undefined ones.

Tighten up assorted type/ftype declaration checking. This in turn unleashed
a bunch of test suite tests requiring errors on conflicts between DECLARATION
declarations and types, so I put in checks for those as well.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.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
18;; sysutils.lisp - things which have outgrown l1-utils
19
20(in-package "CCL")
21
22(eval-when (:execute :compile-toplevel)
23  (require 'level-2)
24  (require 'optimizers)
25  (require 'backquote)
26  (require 'defstruct-macros)
27  )
28
29;;; things might be clearer if this stuff were in l1-typesys?
30;;; Translation from type keywords to specific predicates.
31(eval-when (:execute :compile-toplevel)
32
33(defconstant type-pred-pairs
34  '((array . arrayp)
35    (atom . atom)
36    (base-string . base-string-p)
37    (bignum . bignump)
38    (bit . bitp)
39    (bit-vector . bit-vector-p)
40    (character . characterp)
41    (compiled-function . compiled-function-p)
42    (complex . complexp)
43    (cons . consp)
44    (double-float . double-float-p)
45    (fixnum . fixnump) ;not cl
46    (float . floatp)
47    (function . functionp)
48    (hash-table . hash-table-p)
49    (integer . integerp)
50    (real . realp)
51    (keyword . keywordp)
52    (list . listp)
53    (long-float . double-float-p)
54    (nil . false)
55    (null . null)
56    (number . numberp)
57    (package . packagep)
58    (pathname . pathnamep)
59    (logical-pathname . logical-pathname-p)
60    (random-state . random-state-p)
61    (ratio . ratiop)
62    (rational . rationalp)
63    (readtable . readtablep)
64    (sequence . sequencep)
65    (short-float . short-float-p)
66    (signed-byte . integerp)
67    (simple-array . simple-array-p)
68    (simple-base-string . simple-base-string-p)
69    (simple-extended-string . simple-extended-string-p)
70    (simple-bit-vector . simple-bit-vector-p)
71    (simple-string . simple-string-p)
72    (simple-vector . simple-vector-p)
73    (single-float . short-float-p)
74    (stream . streamp)
75    (string . stringp)
76    (extended-string . extended-string-p)
77    (base-char . base-char-p)
78    (extended-char . extended-char-p)
79    (structure-object . structurep)
80    (symbol . symbolp)
81    (t . true)
82    (unsigned-byte . unsigned-byte-p)
83    (vector . vectorp)
84    ))
85
86(defmacro init-type-predicates ()
87  `(dolist (pair ',type-pred-pairs)
88     (setf (type-predicate (car pair)) (cdr pair))
89     (let ((ctype (info-type-builtin (car pair))))       
90       (if (typep ctype 'numeric-ctype)
91         (setf (numeric-ctype-predicate ctype) (cdr pair))))))
92
93)
94
95(init-type-predicates)
96
97(defun unsigned-byte-8-p (n)
98  (and (fixnump n)
99       (locally (declare (fixnum n))
100         (and 
101          (>= n 0)
102          (< n #x100)))))
103
104(defun signed-byte-8-p (n)
105  (and (fixnump n)
106       (locally (declare (fixnum n))
107         (and 
108          (>= n -128)
109          (<= n 127)))))
110
111(defun unsigned-byte-16-p (n)
112  (and (fixnump n)
113       (locally (declare (fixnum n))
114         (and 
115          (>= n 0)
116          (< n #x10000)))))
117
118(defun signed-byte-16-p (n)
119  (and (fixnump n)
120       (locally (declare (fixnum n))
121         (and 
122          (>= n -32768)
123          (<= n 32767)))))
124
125(defun unsigned-byte-32-p (n)
126  (and (integerp n)
127       (>= n 0)
128       (<= n #xffffffff)))
129
130(defun signed-byte-32-p (n)
131  (and (integerp n)
132       (>= n  -2147483648)
133       (<= n 2147483647)))
134
135(eval-when (:load-toplevel :execute)
136  (let ((more-pairs
137         '(((unsigned-byte 8) . unsigned-byte-8-p)
138           ((signed-byte 8) . signed-byte-8-p)
139           ((unsigned-byte 16) . unsigned-byte-16-p)
140           ((signed-byte 16) . signed-byte-16-p)
141           ((unsigned-byte 32) . unsigned-byte-32-p)
142           ((signed-byte 32) . signed-byte-32-p))))         
143    (dolist (pair more-pairs)
144      (let ((ctype (info-type-builtin (car pair))))       
145        (if (typep ctype 'numeric-ctype) (setf (numeric-ctype-predicate ctype) (cdr pair))))))
146  )
147
148
149(defun specifier-type-known (type) 
150  (let ((ctype (specifier-type type)))
151    (if (typep ctype 'unknown-ctype)
152      (error "Unknown type specifier ~s." type)
153      (if (and (typep ctype 'numeric-ctype) ; complexp??
154               (eq 'integer (numeric-ctype-class ctype))
155               (not (numeric-ctype-predicate ctype)))
156        (setf (numeric-ctype-predicate ctype)(make-numeric-ctype-predicate ctype))))
157    ctype))
158
159
160(defun find-builtin-cell (type  &optional (create t))
161  (let ((cell (gethash type %builtin-type-cells%)))
162    (or cell
163        (when create
164          (setf (gethash type %builtin-type-cells%)
165                (cons type (or (info-type-builtin type)(specifier-type-known type))))))))
166
167
168; for now only called for builtin types or car = unsigned-byte, signed-byte, mod or integer
169
170(defun builtin-typep (form cell)
171  (unless (listp cell)
172    (setq cell (require-type cell 'list)))
173  (locally (declare (type list cell))
174    (let ((ctype (cdr cell))
175          (name (car cell)))
176      (when (not ctype)
177        (setq ctype (or (info-type-builtin name)(specifier-type-known name)))
178        (when ctype (setf (gethash (car cell) %builtin-type-cells%) cell))
179        (rplacd cell ctype))
180      (if ctype 
181        (if (and (typep ctype 'numeric-ctype)
182                 (numeric-ctype-predicate ctype))
183          ; doing this inline is a winner - at least if true
184          (funcall (numeric-ctype-predicate ctype) form)
185          (%%typep form ctype))
186        (typep form name)))))
187
188#|
189(defvar %find-classes% (make-hash-table :test 'eq))
190
191(defun find-class-cell (name create?)
192  (let ((cell (gethash name %find-classes%)))
193    (or cell
194        (and create?
195             (setf (gethash name %find-classes%) (cons name nil))))))
196|#
197
198;(setq *type-system-initialized* t)
199
200
201;; Type-of, typep, and a bunch of other predicates.
202
203;;; Data type predicates.
204
205;;; things might be clearer if this stuff were in l1-typesys?
206;;; Translation from type keywords to specific predicates.
207
208
209
210
211;necessary since standard-char-p, by definition, errors if not passed a char.
212(setf (type-predicate 'standard-char)
213      #'(lambda (form) (and (characterp form) (standard-char-p form))))
214
215(defun type-of (form)
216  "Return the type of OBJECT."
217  (case form
218    ((t) 'boolean)
219    ((0 1) 'bit)
220    (t
221     (typecase form
222       (standard-char 'standard-char)
223       (keyword 'keyword)
224       ;; Partition integers so that the negative cases
225       ;; are SIGNED-BYTE and the positive are UNSIGNED-BYTE
226       (fixnum
227        (if (< (the fixnum form) 0)
228          'fixnum
229          '(integer 0 #.target::target-most-positive-fixnum)))
230       (bignum
231        (if (< form 0)
232          'bignum
233          '(integer  #.(1+ target::target-most-positive-fixnum))))
234       ((or array complex) (type-specifier (ctype-of form)))
235       (single-float 'single-float)
236       (double-float 'double-float)
237       (t
238        (if (eql (typecode form) target::subtag-istruct)
239          (istruct-type-name form)
240          (let* ((class (class-of form)))
241            (or (%class-proper-name class)
242                class))))))))
243
244;;; Create the list-style description of an array.
245
246;made more specific by fry. slisp used  (mod 2) , etc.
247;Oh.
248; As much fun as this has been, I think it'd be really neat if
249; it returned a type specifier.
250
251(defun describe-array (array)
252  (if (arrayp array)
253    (type-specifier
254     (specifier-type
255      `(,(if (simple-array-p array) 'simple-array 'array) 
256        ,(array-element-type array) 
257        ,(array-dimensions array))))
258    (report-bad-arg array 'array)))
259 
260
261;;;; TYPEP and auxiliary functions.
262
263
264
265(defun type-specifier-p (form &aux sym)
266  (cond ((symbolp form)
267         (or (type-predicate form)
268             (structure-class-p form)
269             (%deftype-expander form)
270             (find-class form nil)
271             ))
272        ((consp form)
273         (setq sym (%car form))
274         (or (type-specifier-p sym)
275             (memq sym '(member satisfies mod))
276             (and (memq sym '(and or not))
277                  (dolist (spec (%cdr form) t)
278                    (unless (type-specifier-p spec) (return nil))))))
279        (t (typep form 'class))))
280
281(defun built-in-type-p (type)
282  (if (symbolp type)
283    (or (type-predicate type)
284        (let ((class (find-class type nil)))
285          (and class (typep class 'built-in-class))))
286    (and (consp type)
287         (or (and (memq (%car type) '(and or not))
288                  (every #'built-in-type-p (%cdr type)))
289             (memq (%car type) '(array simple-array vector simple-vector
290                                 string simple-string bit-vector simple-bit-vector 
291                                 complex integer mod signed-byte unsigned-byte
292                                 rational float short-float single-float
293                                 double-float long-float real member))))))
294
295(defun typep (object type &optional env)
296  "Is OBJECT of type TYPE?"
297  (let* ((pred (if (symbolp type) (type-predicate type))))
298    (if pred
299      (funcall pred object)
300      (values (%typep object (if env (specifier-type type env) type))))))
301
302
303
304;;; This is like check-type, except it returns the value rather than setf'ing
305;;; anything, and so can be done entirely out-of-line.
306(defun require-type (arg type)
307  (multiple-value-bind (win sure)
308      (ctypep  arg (specifier-type type))
309    (if (or win (not sure))
310      arg
311      (%kernel-restart $xwrongtype arg type))))
312
313;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
314(defun %require-type (arg predsym)
315  (if (funcall predsym arg)
316    arg
317    (%kernel-restart $xwrongtype arg (type-for-predicate predsym))))
318
319(defun %require-type-builtin (arg type-cell) 
320  (if (builtin-typep arg type-cell)
321    arg
322    (%kernel-restart $xwrongtype arg (car type-cell))))
323
324
325
326;;; In lieu of an inverted mapping, at least try to find cases involving
327;;; builtin numeric types and predicates associated with them.
328(defun type-for-predicate (pred)
329  (or (block find
330        (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype)
331                                                   (eq (numeric-ctype-predicate ctype)
332                                                       pred))
333                                          (return-from find type)))
334                 *builtin-type-info*))
335      `(satisfies ,pred)))
336
337
338
339; Subtypep.
340
341(defun subtypep (type1 type2 &optional env)
342  "Return two values indicating the relationship between type1 and type2.
343  If values are T and T, type1 definitely is a subtype of type2.
344  If values are NIL and T, type1 definitely is not a subtype of type2.
345  If values are NIL and NIL, it couldn't be determined."
346  (csubtypep (specifier-type type1 env) (specifier-type type2 env)))
347
348
349
350
351(defun preload-all-functions ()
352  nil)
353
354
355 ; used by arglist
356(defun temp-cons (a b)
357  (cons a b))
358
359
360
361
362(defun copy-into-float (src dest)
363  (%copy-double-float src dest))
364
365(queue-fixup
366 (defun fmakunbound (name)
367   "Make NAME have no global function definition."
368   (let* ((fname (validate-function-name name)))
369     (remhash fname %structure-refs%)
370     (%unfhave fname))
371   name))
372
373(defun frozen-definition-p (name)
374  (if (symbolp name)
375    (%ilogbitp $sym_fbit_frozen (%symbol-bits name))))
376
377(defun redefine-kernel-function (name)
378  (when (and *warn-if-redefine-kernel*
379             (frozen-definition-p name)
380             (or (lfunp (fboundp name))
381                 (and (not (consp name)) (macro-function name)))
382             (or (and (consp name) (neq (car name) 'setf))
383                 (let ((pkg (symbol-package (if (consp name) (cadr name) name))))
384                   (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg)))))
385    (cerror "Replace the definition of ~S."
386            "The function ~S is predefined in Clozure CL." name)
387    (unless (consp name)
388      (proclaim-inline nil name))))
389
390(defun fset (name function)
391  (setq function (require-type function 'function))
392  (when (symbolp name)
393    (when (special-operator-p name)
394      (error "Can not redefine a special-form: ~S ." name))
395    (when (macro-function name)
396      (cerror "Redefine the macro ~S as a function"
397              "The macro ~S is being redefined as a function." name)))
398; This lets us redefine %FHAVE.  Big fun.
399  (let ((fhave #'%fhave))
400    (redefine-kernel-function name)
401    (fmakunbound name)
402    (funcall fhave name function)
403    function))
404
405(defsetf symbol-function fset)
406(defsetf fdefinition fset)
407
408(defun (setf macro-function) (macro-fun name &optional env)
409  (declare (ignore env))
410  (unless (typep macro-fun 'function)
411    (report-bad-arg macro-fun 'function))
412  (if (special-operator-p name)
413    (error "Can not redefine a special-form: ~S ." name))
414  (when (and (fboundp name) (not (macro-function name)))
415    (warn "The function ~S is being redefined as a macro." name))
416  (redefine-kernel-function name)
417  (fmakunbound name)
418  (%macro-have name macro-fun)
419  macro-fun)
420
421(defun set-macro-function (name def)
422  (setf (macro-function name) def))
423
424
425
426
427;;; Arrays and vectors, including make-array.
428
429
430
431
432
433
434
435(defun char (string index)
436  "Given a string and a non-negative integer index less than the length of
437  the string, returns the character object representing the character at
438  that position in the string."
439  (if (typep string 'simple-string)
440    (schar (the simple-string string) index)
441    (if (stringp string)
442      (multiple-value-bind (data offset) (array-data-and-offset string)
443        (schar (the simple-string data) (+ index offset)))
444      (report-bad-arg string 'string))))
445
446(defun set-char (string index new-el)
447  (if (typep string 'simple-string)
448    (setf (schar string index) new-el)
449    (if (stringp string)
450      (multiple-value-bind (data offset) (array-data-and-offset string)
451        (setf (schar (the simple-string data) (+ index offset)) new-el))
452      (report-bad-arg string 'string))))
453
454(defun equalp (x y)
455  "Just like EQUAL, but more liberal in several respects.
456  Numbers may be of different types, as long as the values are identical
457  after coercion.  Characters may differ in alphabetic case.  Vectors and
458  arrays must have identical dimensions and EQUALP elements, but may differ
459  in their type restriction.
460  If one of x or y is a pathname and one is a string with the name of the
461  pathname then this will return T."
462  (cond ((eql x y) t)
463        ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y))))
464        ((numberp x) (and (numberp y) (= x y)))
465        ((consp x)
466         (and (consp y)
467              (equalp (car x) (car y))
468              (equalp (cdr x) (cdr y))))       
469        ((pathnamep x) (equal x y))
470        ((vectorp x)
471         (and (vectorp y)
472              (let ((length (length x)))
473                (when (eq length (length y))
474                  (dotimes (i length t)
475                    (declare (fixnum i))
476                    (let ((x-el (aref x i))
477                          (y-el (aref y i)))
478                      (unless (or (eq x-el y-el) (equalp x-el y-el))
479                        (return nil))))))))
480        ((arrayp x)
481         (and (arrayp y)
482              (let ((rank (array-rank x)) x-el y-el)
483                (and (eq (array-rank y) rank)
484                     (if (%izerop rank) (equalp (aref x) (aref y))
485                         (and
486                          (dotimes (i rank t)
487                            (declare (fixnum i))
488                            (unless (eq (array-dimension x i)
489                                        (array-dimension y i))
490                              (return nil)))
491                          (multiple-value-bind (x0 i) (array-data-and-offset x)
492                            (multiple-value-bind (y0 j) (array-data-and-offset y)
493                              (dotimes (count (array-total-size x) t)
494                                (declare (fixnum count))
495                                (setq x-el (uvref x0 i) y-el (uvref y0 j))
496                                (unless (or (eq x-el y-el) (equalp x-el y-el))
497                                  (return nil))
498                                (setq i (%i+ i 1) j (%i+ j 1)))))))))))
499        ((and (structurep x) (structurep y))
500         (let ((size (uvsize x)))
501           (and (eq size (uvsize y))
502                (dotimes (i size t)
503                  (declare (fixnum i))
504                  (unless (equalp (uvref x i) (uvref y i))
505                    (return nil))))))
506        ((and (hash-table-p x) (hash-table-p y))
507         (%hash-table-equalp x y))
508        (t nil)))
509
510
511; The compiler (or some transforms) might want to do something more interesting
512; with these, but they have to exist as functions anyhow.
513
514
515
516(defun complement (function)
517  "Return a new function that returns T whenever FUNCTION returns NIL and
518   NIL whenever FUNCTION returns non-NIL."
519  (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell
520  #'(lambda (&rest args)
521      (declare (dynamic-extent args)) ; not tail-recursive anyway
522      (not (apply f args)))))
523
524; Special variables are evil, but I can't think of a better way to do this.
525
526(defparameter *outstanding-deferred-warnings* nil)
527
528(defun call-with-compilation-unit (thunk &key override)
529  (let* ((*outstanding-deferred-warnings* (%defer-warnings override)))
530    (multiple-value-prog1 (funcall thunk)
531      (report-deferred-warnings))))
532
533(defun %defer-warnings (override &aux (parent *outstanding-deferred-warnings*))
534  (when parent
535    (ensure-merged-deferred-warnings parent))
536  (%istruct 'deferred-warnings
537            (unless override parent)
538            nil
539            (make-hash-table :test #'eq)
540            nil))
541
542(defun ensure-merged-deferred-warnings (parent &aux (last (deferred-warnings.last-file parent)))
543  (when last
544    (setf (deferred-warnings.last-file parent) nil)
545    (let* ((child (car last)) ;; last = (deferred-warnings . file)
546           (warnings (deferred-warnings.warnings child))
547           (defs (deferred-warnings.defs child))
548           (parent-defs (deferred-warnings.defs parent))
549           (parent-warnings (deferred-warnings.warnings parent)))
550      (maphash (lambda (key val) (setf (gethash key parent-defs) val)) defs)
551      (setf (deferred-warnings.warnings parent) (append warnings parent-warnings))))
552  parent)
553
554
555;; Should be a generic function but compiler-warning class not defined yet.
556(defun verify-deferred-warning (w)
557  (etypecase w
558    (undefined-type-reference (verify-deferred-type-warning w))
559    (undefined-function-reference (verify-deferred-function-warning w))
560    (compiler-warning nil)))
561
562(defun verify-deferred-type-warning (w)
563  (let* ((args (compiler-warning-args w))
564         (typespec (car args))
565         (defs (deferred-warnings.defs *outstanding-deferred-warnings*)))
566    (handler-bind ((parse-unknown-type
567                    (lambda (c)
568                      (let* ((type (parse-unknown-type-specifier c))
569                             (spec (if (consp type) (car type) type))
570                             (cell (and (symbolp spec) (gethash spec defs))))
571                        (unless (and cell (def-info.deftype (cdr cell)))
572                          (when (and args (neq type typespec))
573                            (setf (car args) type))
574                          (return-from verify-deferred-type-warning w))
575                        ;; Else got defined.  TODO: Should check syntax, but don't have enuff info.
576                        ;; TODO: should note if got defined as a deftype (rather than class or struct) and
577                        ;; warn about forward reference, akin to the macro warning?  Might be missing out on
578                        ;; some intended optimizations.
579                        )))
580                   (program-error ;; got defined, but turns out it's being used wrong
581                    (lambda (c)
582                      (let ((w2 (make-condition 'invalid-type-warning
583                                  :file-name (compiler-warning-file-name w)
584                                  :function-name (compiler-warning-function-name w)
585                                  :source-note (compiler-warning-source-note w)
586                                  :warning-type :invalid-type
587                                  :args (list typespec c))))
588                        (setf (compiler-warning-stream-position w2)
589                              (compiler-warning-stream-position w))
590                        (return-from verify-deferred-type-warning w2)))))
591      (values-specifier-type typespec)
592      nil)))
593
594
595(defun verify-deferred-function-warning (w)
596  (let* ((args (compiler-warning-args w))
597         (wfname (car args))
598         (defs (deferred-warnings.defs *outstanding-deferred-warnings*))
599         (def (or (let ((cell (gethash wfname defs)))
600                   (and cell (def-info.function-p (cdr cell)) cell))
601                 (let* ((global (fboundp wfname)))
602                   (and (typep global 'function) global)))))
603    (cond ((null def) w)
604          ((or (typep def 'function)
605               (and (consp def)
606                    (def-info.lfbits (cdr def))))
607           ;; Check args in call to forward-referenced function.
608           (when (cdr args)
609             (destructuring-bind (arglist spread-p) (cdr args)
610               (multiple-value-bind (deftype reason)
611                   (nx1-check-call-args def arglist spread-p)
612                 (when deftype
613                   (let* ((w2 (make-condition
614                               'invalid-arguments
615                               :file-name (compiler-warning-file-name w)
616                               :function-name (compiler-warning-function-name w)
617                               :source-note (compiler-warning-source-note w)
618                               :warning-type deftype
619                               :args (list (car args) reason arglist spread-p))))
620                     (setf (compiler-warning-stream-position w2)
621                           (compiler-warning-stream-position w))
622                     w2))))))
623          ((def-info.macro-p (cdr def))
624           (let* ((w2 (make-condition
625                       'macro-used-before-definition
626                       :file-name (compiler-warning-file-name w)
627                       :function-name (compiler-warning-function-name w)
628                       :source-note (compiler-warning-source-note w)
629                       :warning-type :macro-used-before-definition
630                       :args (list (car args)))))
631             (setf (compiler-warning-stream-position w2)
632                   (compiler-warning-stream-position w))
633             w2)))))
634
635
636(defun report-deferred-warnings (&optional (file nil))
637  (let* ((current (ensure-merged-deferred-warnings *outstanding-deferred-warnings*))
638         (parent (deferred-warnings.parent current))
639         (warnings (deferred-warnings.warnings current))
640         (any nil)
641         (harsh nil))
642    (if parent
643      (progn
644        (setf (deferred-warnings.last-file parent) (cons current file))
645        (unless file ;; don't defer merge for non-file units.
646          (ensure-merged-deferred-warnings parent))
647        (setq parent t))
648      (let* ((file nil)
649             (init t))
650        (dolist (w warnings)
651          (when (setq w (verify-deferred-warning w))
652            (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
653            (setq init nil)))))
654    (values any harsh parent)))
655
656(defun print-nested-name (name-list stream)
657  (if (null name-list)
658    (princ "a toplevel form" stream)
659    (progn
660      (if (car name-list)
661        (prin1 (%car name-list) stream)
662        (princ "an anonymous lambda form" stream))
663      (when (%cdr name-list)
664        (princ " inside " stream)
665        (print-nested-name (%cdr name-list) stream)))))
666
667(defparameter *suppress-compiler-warnings* nil)
668
669(defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p)
670  (let ((muffled *suppress-compiler-warnings*)
671        (w-file (compiler-warning-file-name w))
672        (s *error-output*))
673    (unless muffled 
674      (restart-case (signal w)
675        (muffle-warning () (setq muffled t))))
676    (unless muffled
677      (setq any-p t)
678      (unless (typep w 'style-warning)
679        (unless (eq harsh-p :very)
680          (setq harsh-p t)
681          (when (and (typep w 'compiler-warning)
682                     (eq (compiler-warning-warning-type w) :program-error)
683                     (typep (car (compiler-warning-args w)) 'error))
684            (setq harsh-p :very))))
685      (when (or init-p (not (equalp w-file last-w-file)))
686        (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter"))
687        (if w-file (format s "for ~S :" w-file) (princ ":" s)))
688      (let* ((indenting-stream (make-indenting-string-output-stream #\; 4)))
689        (format indenting-stream "~%~a" w)
690        (format s "~a" (get-output-stream-string indenting-stream))))
691    (values harsh-p any-p w-file)))
692
693;;;; Assorted mumble-P type predicates.
694;;;; No functions have been in the kernel for the last year or so.
695;;;; (Just thought you'd like to know.)
696
697(defun sequencep (form)
698  "Not CL. SLISP Returns T if form is a sequence, NIL otherwise."
699   (or (listp form) (vectorp form)))
700
701;;; The following are not defined at user level, but are necessary for
702;;; internal use by TYPEP.
703
704(defun bitp (form)
705  "Not CL. SLISP"
706  (or (eq form 0) (eq form 1)))
707
708(defun unsigned-byte-p (form)
709  (and (integerp form) (not (< form 0))))
710
711;This is false for internal structures.
712;;; ---- look at defenv.structures, not defenv.structrefs
713
714(defun structure-class-p (form &optional env)
715  (and (symbolp form)
716       (let ((sd (or (and env
717                          (let ((defenv (definition-environment env)))
718                            (and defenv
719                                 (%cdr (assq form (defenv.structures defenv))))))
720                     (gethash form %defstructs%))))
721         (and sd
722              (null (sd-type sd))
723              sd))))
724
725
726
727
728
729(defun type-keyword-code (type-keyword &optional target)
730  (let* ((backend (if target (find-backend target) *target-backend*))
731         (alist (arch::target-uvector-subtags (backend-target-arch backend)))
732         (entry (assq type-keyword alist)))
733    (if entry
734      (let* ((code (cdr entry)))
735        (or code (error "Vector type ~s invalid," type-keyword)))
736      (error "Unknown type-keyword ~s. " type-keyword))))
737
738
739(defstruct id-map
740  (vector (make-array 1 :initial-element nil))
741  (free 0)
742  (lock (make-lock)))
743
744;;; Caller owns the lock on the id-map.
745(defun id-map-grow (id-map)
746  (without-interrupts
747   (let* ((old-vector (id-map-vector id-map))
748          (old-size (length old-vector))
749          (new-size (+ old-size old-size))
750          (new-vector (make-array new-size)))
751     (declare (fixnum old-size new-size))
752     (dotimes (i old-size)
753       (setf (svref new-vector i) (svref old-vector i)))
754     (let* ((limit (1- new-size)))
755       (declare (fixnum limit))
756       (do* ((i old-size (1+ i)))
757            ((= i limit) (setf (svref new-vector i) nil))
758         (declare (fixnum i))
759         (setf (svref new-vector i) (the fixnum (1+ i)))))
760     (setf (id-map-vector id-map) new-vector
761           (id-map-free id-map) old-size))))
762
763;;; Map an object to a small fixnum ID in id-map.
764;;; Object can't be NIL or a fixnum itself.
765(defun assign-id-map-id (id-map object)
766  (if (or (null object) (typep object 'fixnum))
767    (setq object (require-type object '(not (or null fixnum)))))
768  (with-lock-grabbed ((id-map-lock id-map))
769    (let* ((free (or (id-map-free id-map) (id-map-grow id-map)))
770           (vector (id-map-vector id-map))
771           (newfree (svref vector free)))
772      (setf (id-map-free id-map) newfree
773            (svref vector free) object)
774      free)))
775     
776;;; Referemce the object with id ID in ID-MAP.  Leave the object in
777;;; the map.
778(defun id-map-object (id-map id)
779  (let* ((object (with-lock-grabbed ((id-map-lock id-map))
780                   (svref (id-map-vector id-map) id))))
781    (if (or (null object) (typep object 'fixnum))
782      (error "invalid index ~d for ~s" id id-map)
783      object)))
784
785;;; Referemce the object with id ID in ID-MAP.  Remove the object from
786;;; the map.
787(defun id-map-free-object (id-map id)
788  (with-lock-grabbed ((id-map-lock id-map))
789    (let* ((vector (id-map-vector id-map))
790           (object (svref vector id)))
791      (if (or (null object) (typep object 'fixnum))
792        (error "invalid index ~d for ~s" id id-map))
793      (setf (svref vector id) (id-map-free id-map)
794            (id-map-free id-map) id)
795      object)))
796
797(defun id-map-modify-object (id-map id old-value new-value)
798  (with-lock-grabbed ((id-map-lock id-map))
799    (let* ((vector (id-map-vector id-map))
800           (object (svref vector id)))
801      (if (or (null object) (typep object 'fixnum))
802        (error "invalid index ~d for ~s" id id-map))
803      (if (eq object old-value)
804        (setf (svref vector id) new-value)))))
805
806
807   
808
809(setq *type-system-initialized* t)
810
811;;; Try to map from a CTYPE describing some array/stream
812;;; element-type to a target-specific typecode, catching
813;;; cases that CTYPE-SUBTYPE missed.
814
815(defun harder-ctype-subtype (ctype)
816  (cond ((csubtypep ctype (load-time-value (specifier-type 'bit)))
817         target::subtag-bit-vector)
818        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 8))))
819         target::subtag-u8-vector)
820        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 16))))
821         target::subtag-u16-vector)
822        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 32))))
823         target::subtag-u32-vector)
824        #+64-bit-target
825        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 64))))
826         target::subtag-u64-vector)
827        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 8))))
828         target::subtag-s8-vector)
829        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 16))))
830         target::subtag-s16-vector)
831        #+32-bit-target
832        ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum))))
833         target::subtag-fixnum-vector)
834        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 32))))
835         target::subtag-s32-vector)
836        #+64-bit-target
837        ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum))))
838         target::subtag-fixnum-vector)
839        #+64-bit-target
840        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 64))))
841         target::subtag-s64-vector)
842        (t target::subtag-simple-vector)))
843
844
845#+count-gf-calls
846(progn
847;;; Call-counting for generic functions.  We overload the
848;;; (previously unused
849(defmethod generic-function-call-count ((gf generic-function))
850  (gf.hash gf))
851
852
853(defun (setf generic-function-call-count) (count gf)
854  (setf (gf.hash gf) (require-type count 'fixnum)))
855
856(defun clear-all-generic-function-call-counts ()
857  (dolist (gf (population.data %all-gfs%))
858    (setf (gf.hash gf) 0)))
859);#+count-gf-calls
860
861
Note: See TracBrowser for help on using the repository browser.