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

Last change on this file since 14756 was 14756, checked in by gb, 9 years ago

sysutils.lisp: REQUIRE-STRUCTURE-TYPE; basically inlines a
STRUCTURE-TYPEP test and allows the error signalling to happen
out-of-line if the test fails.

optimizers.lisp: if REQUIRE-STRUCTURE-TYPE is defined, transform
(REQUIRE-TYPE thing 'structure-class-name) into a call to
REQUIRE-STRUCTURE-TYPE.

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