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

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

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

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