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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 36.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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           ((complex single-float) . complex-single-float-p)
142           ((complex double-float) . complex-double-float-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
314
315;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
316(defun %require-type (arg predsym)
317  (if (funcall predsym arg)
318    arg
319    (%kernel-restart $xwrongtype arg (type-for-predicate predsym))))
320
321(defun %require-type-builtin (arg type-cell) 
322  (if (builtin-typep arg type-cell)
323    arg
324    (%kernel-restart $xwrongtype arg (car type-cell))))
325
326
327
328;;; In lieu of an inverted mapping, at least try to find cases involving
329;;; builtin numeric types and predicates associated with them.
330(defun type-for-predicate (pred)
331  (or (block find
332        (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype)
333                                                   (eq (numeric-ctype-predicate ctype)
334                                                       pred))
335                                          (return-from find type)))
336                 *builtin-type-info*))
337      `(satisfies ,pred)))
338
339
340
341; Subtypep.
342
343(defun subtypep (type1 type2 &optional env)
344  "Return two values indicating the relationship between type1 and type2.
345  If values are T and T, type1 definitely is a subtype of type2.
346  If values are NIL and T, type1 definitely is not a subtype of type2.
347  If values are NIL and NIL, it couldn't be determined."
348  (csubtypep (specifier-type type1 env) (specifier-type type2 env)))
349
350(defun types-disjoint-p (type1 type2 &optional env)
351  ;; Return true if types are guaranteed to be disjoint, nil if not disjoint or unknown.
352  (let ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
353        (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env))))
354    (eq *empty-type* (type-intersection ctype1 ctype2))))
355
356
357
358(defun preload-all-functions ()
359  nil)
360
361
362 ; used by arglist
363(defun temp-cons (a b)
364  (cons a b))
365
366
367
368
369(defun copy-into-float (src dest)
370  (%copy-double-float src dest))
371
372(queue-fixup
373 (defun fmakunbound (name)
374   "Make NAME have no global function definition."
375   (let* ((fname (validate-function-name name)))
376     (remhash fname %structure-refs%)
377     (%unfhave fname))
378   name))
379
380(defun frozen-definition-p (name)
381  (if (symbolp name)
382    (%ilogbitp $sym_fbit_frozen (%symbol-bits name))))
383
384(defun redefine-kernel-function (name)
385  (when (and *warn-if-redefine-kernel*
386             (frozen-definition-p name)
387             (or (lfunp (fboundp name))
388                 (and (not (consp name)) (macro-function name)))
389             (or (and (consp name) (neq (car name) 'setf))
390                 (let ((pkg (symbol-package (if (consp name) (cadr name) name))))
391                   (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg)))))
392    (restart-case
393        (progn ;; work around ticket:865
394          (cerror "Replace the definition of ~S."
395                  "The function ~S is predefined in Clozure CL." name))
396      (never-complain ()
397        :report (lambda (stream)
398                  (format stream "Replace the definition of ~S and allow such redefinitions in the future" name))
399        (setq *warn-if-redefine-kernel* nil)))
400    (unless (consp name)
401      (proclaim-inline nil name))))
402
403(defun fset (name function)
404  (setq function (require-type function 'function))
405  (when (symbolp name)
406    (when (special-operator-p name)
407      (error "Can not redefine a special-form: ~S ." name))
408    (when (macro-function name)
409      (cerror "Redefine the macro ~S as a function"
410              "The macro ~S is being redefined as a function." name)))
411; This lets us redefine %FHAVE.  Big fun.
412  (let ((fhave #'%fhave))
413    (redefine-kernel-function name)
414    (fmakunbound name)
415    (funcall fhave name function)
416    function))
417
418(defsetf symbol-function fset-symbol)
419(defsetf fdefinition fset)
420
421(defun (setf macro-function) (macro-fun name &optional env)
422  (declare (ignore env))
423  (unless (typep macro-fun 'function)
424    (report-bad-arg macro-fun 'function))
425  (if (special-operator-p name)
426    (error "Can not redefine a special-form: ~S ." name))
427  (when (and (fboundp name) (not (macro-function name)))
428    (warn "The function ~S is being redefined as a macro." name))
429  (redefine-kernel-function name)
430  (fmakunbound name)
431  (%macro-have name macro-fun)
432  macro-fun)
433
434(defun set-macro-function (name def)
435  (setf (macro-function name) def))
436
437
438
439
440;;; Arrays and vectors, including make-array.
441
442
443
444
445
446
447
448(defun char (string index)
449  "Given a string and a non-negative integer index less than the length of
450  the string, returns the character object representing the character at
451  that position in the string."
452  (if (typep string 'simple-string)
453    (schar (the simple-string string) index)
454    (if (stringp string)
455      (multiple-value-bind (data offset) (array-data-and-offset string)
456        (schar (the simple-string data) (+ index offset)))
457      (report-bad-arg string 'string))))
458
459(defun set-char (string index new-el)
460  (if (typep string 'simple-string)
461    (setf (schar string index) new-el)
462    (if (stringp string)
463      (multiple-value-bind (data offset) (array-data-and-offset string)
464        (setf (schar (the simple-string data) (+ index offset)) new-el))
465      (report-bad-arg string 'string))))
466
467(defun equalp (x y)
468  "Just like EQUAL, but more liberal in several respects.
469  Numbers may be of different types, as long as the values are identical
470  after coercion.  Characters may differ in alphabetic case.  Vectors and
471  arrays must have identical dimensions and EQUALP elements, but may differ
472  in their type restriction.
473  If one of x or y is a pathname and one is a string with the name of the
474  pathname then this will return T."
475  (cond ((eql x y) t)
476        ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y))))
477        ((numberp x) (and (numberp y) (= x y)))
478        ((consp x)
479         (and (consp y)
480              (equalp (car x) (car y))
481              (equalp (cdr x) (cdr y))))       
482        ((pathnamep x) (equal x y))
483        ((vectorp x)
484         (and (vectorp y)
485              (let ((length (length x)))
486                (when (eq length (length y))
487                  (dotimes (i length t)
488                    (declare (fixnum i))
489                    (let ((x-el (aref x i))
490                          (y-el (aref y i)))
491                      (unless (or (eq x-el y-el) (equalp x-el y-el))
492                        (return nil))))))))
493        ((arrayp x)
494         (and (arrayp y)
495              (let ((rank (array-rank x)) x-el y-el)
496                (and (eq (array-rank y) rank)
497                     (if (%izerop rank) (equalp (aref x) (aref y))
498                         (and
499                          (dotimes (i rank t)
500                            (declare (fixnum i))
501                            (unless (eq (array-dimension x i)
502                                        (array-dimension y i))
503                              (return nil)))
504                          (multiple-value-bind (x0 i) (array-data-and-offset x)
505                            (multiple-value-bind (y0 j) (array-data-and-offset y)
506                              (dotimes (count (array-total-size x) t)
507                                (declare (fixnum count))
508                                (setq x-el (uvref x0 i) y-el (uvref y0 j))
509                                (unless (or (eq x-el y-el) (equalp x-el y-el))
510                                  (return nil))
511                                (setq i (%i+ i 1) j (%i+ j 1)))))))))))
512        ((and (structurep x) (structurep y))
513         (let ((size (uvsize x)))
514           (and (eq size (uvsize y))
515                (dotimes (i size t)
516                  (declare (fixnum i))
517                  (unless (equalp (uvref x i) (uvref y i))
518                    (return nil))))))
519        ((and (hash-table-p x) (hash-table-p y))
520         (%hash-table-equalp x y))
521        ((and (random-state-p x) (random-state-p y))
522         (%random-state-equalp x y))
523        (t nil)))
524
525
526; The compiler (or some transforms) might want to do something more interesting
527; with these, but they have to exist as functions anyhow.
528
529
530
531(defun complement (function)
532  "Return a new function that returns T whenever FUNCTION returns NIL and
533   NIL whenever FUNCTION returns non-NIL."
534  (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell
535  #'(lambda (&rest args)
536      (declare (dynamic-extent args)) ; not tail-recursive anyway
537      (not (apply f args)))))
538
539; Special variables are evil, but I can't think of a better way to do this.
540
541(defparameter *outstanding-deferred-warnings* nil)
542
543(defun call-with-compilation-unit (thunk &key override)
544  (let* ((*outstanding-deferred-warnings* (%defer-warnings override)))
545    (multiple-value-prog1 (funcall thunk)
546      (report-deferred-warnings))))
547
548(defun %defer-warnings (override &aux (parent *outstanding-deferred-warnings*))
549  (when parent
550    (ensure-merged-deferred-warnings parent))
551  (%istruct 'deferred-warnings
552            (unless override parent)
553            nil
554            (make-hash-table :test #'eq)
555            nil))
556
557(defun ensure-merged-deferred-warnings (parent &aux (last (deferred-warnings.last-file parent)))
558  (when last
559    (setf (deferred-warnings.last-file parent) nil)
560    (let* ((child (car last)) ;; last = (deferred-warnings . file)
561           (warnings (deferred-warnings.warnings child))
562           (defs (deferred-warnings.defs child))
563           (parent-defs (deferred-warnings.defs parent))
564           (parent-warnings (deferred-warnings.warnings parent)))
565      (maphash (lambda (key val) (setf (gethash key parent-defs) val)) defs)
566      (setf (deferred-warnings.warnings parent) (append warnings parent-warnings))))
567  parent)
568
569
570;; Should be a generic function but compiler-warning class not defined yet.
571(defun verify-deferred-warning (w)
572  (etypecase w
573    (undefined-type-reference (verify-deferred-type-warning w))
574    (undefined-function-reference (verify-deferred-function-warning w))
575    (undefined-keyword-reference (verify-deferred-keyword-warning w))
576    (compiler-warning nil)))
577
578(defun verify-deferred-type-warning (w)
579  (let* ((args (compiler-warning-args w))
580         (typespec (car args))
581         (defs (deferred-warnings.defs *outstanding-deferred-warnings*)))
582    (handler-bind ((parse-unknown-type
583                    (lambda (c)
584                      (let* ((type (parse-unknown-type-specifier c))
585                             (spec (if (consp type) (car type) type))
586                             (cell (and (symbolp spec) (gethash spec defs))))
587                        (unless (and cell (def-info.deftype (cdr cell)))
588                          (when (and args (neq type typespec))
589                            (setf (car args) type))
590                          (return-from verify-deferred-type-warning w))
591                        ;; Else got defined.  TODO: Should check syntax, but don't have enuff info.
592                        ;; TODO: should note if got defined as a deftype (rather than class or struct) and
593                        ;; warn about forward reference, akin to the macro warning?  Might be missing out on
594                        ;; some intended optimizations.
595                        )))
596                   (program-error ;; got defined, but turns out it's being used wrong
597                    (lambda (c)
598                      (let ((w2 (make-condition 'invalid-type-warning
599                                  :function-name (compiler-warning-function-name w)
600                                  :source-note (compiler-warning-source-note w)
601                                  :warning-type :invalid-type
602                                  :args (list typespec c))))
603                        (return-from verify-deferred-type-warning w2)))))
604      (values-specifier-type typespec)
605      nil)))
606
607
608(defun deferred-function-def (name)
609  (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*))
610         (def (or (let ((cell (gethash name defs)))
611                    (and cell (def-info.function-p (cdr cell)) cell))
612                 (let* ((global (fboundp name)))
613                   (and (typep global 'function) global)))))
614    def))
615
616(defun check-deferred-call-args (w def wargs)
617  (destructuring-bind (arglist spread-p) wargs
618    (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p)
619      (when (and (eq deftype :deferred-mismatch)
620                 (eq (car reason) :unknown-gf-keywords)
621                 (consp def)
622                 (not (logbitp $lfbits-gfn-bit (def-info.lfbits (cdr def)))))
623        ;; If didn't have a defgeneric, check against global defn
624        (let* ((global-def (fboundp (car def)))
625               (bad-keys (cadr reason)))
626          (when (typep global-def 'generic-function)
627            (setq bad-keys
628                  (multiple-value-bind (bits keyvect) (innermost-lfun-bits-keyvect global-def)
629                    (when (and bits
630                               (logbitp  $lfbits-keys-bit bits)
631                               (not (logbitp $lfbits-aok-bit bits)))
632                      (loop for key in bad-keys
633                        unless (or (find key keyvect)
634                                   (nx1-valid-gf-keyword-p global-def key))
635                        collect key)))))
636          (if bad-keys
637            (setq reason (list* :unknown-gf-keywords bad-keys (cddr reason)))
638            (setq deftype nil))))
639      (when deftype
640        (when (eq deftype :deferred-mismatch)
641          (setq deftype (if (consp def) :environment-mismatch :global-mismatch)))
642        (make-condition
643         'invalid-arguments
644         :function-name (compiler-warning-function-name w)
645         :source-note (compiler-warning-source-note w)
646         :warning-type deftype
647         :args (list (car (compiler-warning-args w)) reason arglist spread-p))))))
648
649(defun verify-deferred-function-warning (w)
650  (let* ((args (compiler-warning-args w))
651         (wfname (car args))
652         (def (deferred-function-def wfname)))
653    (cond ((null def) w)
654          ((or (typep def 'function)
655               (and (consp def)
656                    (def-info.lfbits (cdr def))))
657           ;; Check args in call to forward-referenced function.
658           (when (cdr args)
659             (check-deferred-call-args w def (cdr args))))
660          ((def-info.macro-p (cdr def))
661           (let* ((w2 (make-condition
662                       'macro-used-before-definition
663                       :function-name (compiler-warning-function-name w)
664                       :source-note (compiler-warning-source-note w)
665                       :warning-type :macro-used-before-definition
666                       :args (list (car args)))))
667             w2)))))
668
669(defun verify-deferred-keyword-warning (w)
670  (let* ((args (compiler-warning-args w))
671         (wfname (car args))
672         (def (deferred-function-def wfname)))
673    (when def
674      (check-deferred-call-args w def (cddr args)))))
675
676
677(defun report-deferred-warnings (&optional (file nil))
678  (let* ((current (ensure-merged-deferred-warnings *outstanding-deferred-warnings*))
679         (parent (deferred-warnings.parent current))
680         (warnings (deferred-warnings.warnings current))
681         (any nil)
682         (harsh nil))
683    (if parent
684      (progn
685        (setf (deferred-warnings.last-file parent) (cons current file))
686        (unless file ;; don't defer merge for non-file units.
687          (ensure-merged-deferred-warnings parent))
688        (setq parent t))
689      (let* ((file nil)
690             (init t))
691        (dolist (w warnings)
692          (when (setq w (verify-deferred-warning w))
693            (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
694            (setq init nil)))))
695    (values any harsh parent)))
696
697(defun print-nested-name (name-list stream)
698  (if (null name-list)
699    (princ "a toplevel form" stream)
700    (progn
701      (if (car name-list)
702        (prin1 (%car name-list) stream)
703        (princ "an anonymous lambda form" stream))
704      (when (%cdr name-list)
705        (princ " inside " stream)
706        (print-nested-name (%cdr name-list) stream)))))
707
708(defparameter *suppress-compiler-warnings* nil)
709
710
711(defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p)
712  (let ((muffled *suppress-compiler-warnings*)
713        (w-file (compiler-warning-file-name w))
714        (s *error-output*))
715    (unless muffled 
716      (restart-case (signal w)
717        (muffle-warning () (setq muffled t))))
718    (unless muffled
719      (setq any-p t)
720      (unless (typep w 'style-warning)
721        (unless (eq harsh-p :very)
722          (setq harsh-p t)
723          (when (and (typep w 'compiler-warning)
724                     (eq (compiler-warning-warning-type w) :program-error)
725                     (typep (car (compiler-warning-args w)) 'error))
726            (setq harsh-p :very))))
727      (when (or init-p (not (equalp w-file last-w-file)))
728        (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter"))
729        (if w-file (format s "for ~S :" w-file) (princ ":" s)))
730      (let* ((indenting-stream (make-indenting-string-output-stream #\; 4)))
731        (format indenting-stream ";~4t~a" w)
732        (format s "~&~a~&" (get-output-stream-string indenting-stream))))
733    (values harsh-p any-p w-file)))
734
735;;;; Assorted mumble-P type predicates.
736;;;; No functions have been in the kernel for the last year or so.
737;;;; (Just thought you'd like to know.)
738
739(defun sequencep (form)
740  "Not CL. SLISP Returns T if form is a sequence, NIL otherwise."
741   (or (listp form) (vectorp form)))
742
743;;; The following are not defined at user level, but are necessary for
744;;; internal use by TYPEP.
745
746(defun bitp (form)
747  "Not CL. SLISP"
748  (or (eq form 0) (eq form 1)))
749
750(defun unsigned-byte-p (form)
751  (and (integerp form) (not (< form 0))))
752
753;This is false for internal structures.
754;;; ---- look at defenv.structures, not defenv.structrefs
755
756(defun structure-class-p (form &optional env)
757  (and (symbolp form)
758       (let ((sd (or (and env
759                          (let ((defenv (definition-environment env)))
760                            (and defenv
761                                 (%cdr (assq form (defenv.structures defenv))))))
762                     (gethash form %defstructs%))))
763         (and sd
764              (null (sd-type sd))
765              sd))))
766
767
768
769
770
771(defun type-keyword-code (type-keyword &optional target)
772  ;; Don't really care about speed, but turn off typechecking for bootstrapping reasons
773  (declare (optimize (speed 3) (safety 0)))
774  (let* ((backend (if target (find-backend target) *target-backend*))
775         (alist (arch::target-uvector-subtags (backend-target-arch backend)))
776         (entry (assq type-keyword alist)))
777    (if entry
778      (let* ((code (cdr entry)))
779        (or code (error "Vector type ~s invalid," type-keyword)))
780      (error "Unknown type-keyword ~s. " type-keyword))))
781
782
783(defstruct id-map
784  (vector (make-array 1 :initial-element nil))
785  (free 0)
786  (lock (make-lock)))
787
788;;; Caller owns the lock on the id-map.
789(defun id-map-grow (id-map)
790  (without-interrupts
791   (let* ((old-vector (id-map-vector id-map))
792          (old-size (length old-vector))
793          (new-size (+ old-size old-size))
794          (new-vector (make-array new-size)))
795     (declare (fixnum old-size new-size))
796     (dotimes (i old-size)
797       (setf (svref new-vector i) (svref old-vector i)))
798     (let* ((limit (1- new-size)))
799       (declare (fixnum limit))
800       (do* ((i old-size (1+ i)))
801            ((= i limit) (setf (svref new-vector i) nil))
802         (declare (fixnum i))
803         (setf (svref new-vector i) (the fixnum (1+ i)))))
804     (setf (id-map-vector id-map) new-vector
805           (id-map-free id-map) old-size))))
806
807;;; Map an object to a small fixnum ID in id-map.
808;;; Object can't be NIL or a fixnum itself.
809(defun assign-id-map-id (id-map object)
810  (if (or (null object) (typep object 'fixnum))
811    (setq object (require-type object '(not (or null fixnum)))))
812  (with-lock-grabbed ((id-map-lock id-map))
813    (let* ((free (or (id-map-free id-map) (id-map-grow id-map)))
814           (vector (id-map-vector id-map))
815           (newfree (svref vector free)))
816      (setf (id-map-free id-map) newfree
817            (svref vector free) object)
818      free)))
819     
820;;; Referemce the object with id ID in ID-MAP.  Leave the object in
821;;; the map.
822(defun id-map-object (id-map id)
823  (let* ((object (with-lock-grabbed ((id-map-lock id-map))
824                   (svref (id-map-vector id-map) id))))
825    (if (or (null object) (typep object 'fixnum))
826      (error "invalid index ~d for ~s" id id-map)
827      object)))
828
829;;; Referemce the object with id ID in ID-MAP.  Remove the object from
830;;; the map.
831(defun id-map-free-object (id-map id)
832  (with-lock-grabbed ((id-map-lock id-map))
833    (let* ((vector (id-map-vector id-map))
834           (object (svref vector id)))
835      (if (or (null object) (typep object 'fixnum))
836        (error "invalid index ~d for ~s" id id-map))
837      (setf (svref vector id) (id-map-free id-map)
838            (id-map-free id-map) id)
839      object)))
840
841(defun id-map-modify-object (id-map id old-value new-value)
842  (with-lock-grabbed ((id-map-lock id-map))
843    (let* ((vector (id-map-vector id-map))
844           (object (svref vector id)))
845      (if (or (null object) (typep object 'fixnum))
846        (error "invalid index ~d for ~s" id id-map))
847      (if (eq object old-value)
848        (setf (svref vector id) new-value)))))
849
850
851   
852
853(setq *type-system-initialized* t)
854
855;;; Try to map from a CTYPE describing some array/stream
856;;; element-type to a target-specific typecode, catching
857;;; cases that CTYPE-SUBTYPE missed.
858
859(defun harder-ctype-subtype (ctype)
860  (cond ((csubtypep ctype (load-time-value (specifier-type 'bit)))
861         target::subtag-bit-vector)
862        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 8))))
863         target::subtag-u8-vector)
864        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 16))))
865         target::subtag-u16-vector)
866        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 32))))
867         target::subtag-u32-vector)
868        #+64-bit-target
869        ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 64))))
870         target::subtag-u64-vector)
871        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 8))))
872         target::subtag-s8-vector)
873        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 16))))
874         target::subtag-s16-vector)
875        #+32-bit-target
876        ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum))))
877         target::subtag-fixnum-vector)
878        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 32))))
879         target::subtag-s32-vector)
880        #+64-bit-target
881        ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum))))
882         target::subtag-fixnum-vector)
883        #+64-bit-target
884        ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 64))))
885         target::subtag-s64-vector)
886        (t target::subtag-simple-vector)))
887
888
889#+count-gf-calls
890(progn
891;;; Call-counting for generic functions.  We overload the
892;;; (previously unused
893(defmethod generic-function-call-count ((gf generic-function))
894  (gf.hash gf))
895
896
897(defun (setf generic-function-call-count) (count gf)
898  (setf (gf.hash gf) (require-type count 'fixnum)))
899
900(defun clear-all-generic-function-call-counts ()
901  (dolist (gf (population.data %all-gfs%))
902    (setf (gf.hash gf) 0)))
903);#+count-gf-calls
904
905
906;;; Sparse vectors, or at least a certain kind of sparse-vector.
907;;; This kind is oriented strongly towards maintaining character
908;;; attributes for Unicode characters (for the reader, Hemlock,etc.)
909(defstruct (sparse-vector (:constructor %make-sparse-vector)
910                          (:copier nil))
911  size
912  element-type
913  default
914  table
915  (lock (make-lock)))
916
917(defun make-sparse-vector (size element-type default)
918  (unless (and (typep size 'fixnum)
919               (locally (declare (fixnum size))
920                 (and (> size 0)
921                      (< size array-total-size-limit))))
922    (report-bad-arg size `(integer 1 ,array-total-size-limit)))
923  (setq element-type (upgraded-array-element-type element-type))
924  (unless (typep default element-type)
925    (report-bad-arg default element-type))
926  (%make-sparse-vector :size size
927                       :element-type element-type
928                       :default default
929                       :table (make-array 1
930                                          :element-type t
931                                          :initial-element nil)))
932
933(defun sparse-vector-ref (sv i)
934  (unless (and (typep i 'fixnum)
935               (>= (the fixnum i) 0)
936               (< (the fixnum i) (the fixnum (sparse-vector-size sv))))
937    (error "~s is not a valid index for ~s" i sv))
938  (locally (declare (fixnum i))
939    (let* ((major (ash i -8))
940           (table (sparse-vector-table sv))
941           (v (if (< major (length table))
942                (svref table major))))
943      (declare (fixnum major))
944      (if (null v)
945        (sparse-vector-default sv)
946        (uvref v (logand i #xff))))))
947
948(defun sparse-vector-count (sv)
949  "Returns number of entries in sparse vector.
950  (Actually, it just counts how many elements are not the default value.
951  So this can be fooled because it can't distinguish the default value from a valid value that happens to be eql to default.)"
952  (with-lock-grabbed ((sparse-vector-lock sv))
953    (let* ((table (sparse-vector-table sv))
954           (majormax (length table))
955           (default (sparse-vector-default sv))
956           (total 0))
957      (declare (fixnum total))
958      (flet ((tally-vector (v)
959               (dotimes (i 256)
960                 (declare (fixnum i))
961                 (unless (eql default (uvref v i))
962                   (incf total)))))
963        (dotimes (i majormax)
964          (declare (fixnum i))
965          (let ((v (svref table i)))
966            (when v (tally-vector v))))
967        total))))
968
969(defun (setf sparse-vector-ref) (new sv i)
970  (unless (and (typep i 'fixnum)
971               (>= (the fixnum i) 0)
972               (< (the fixnum i) (the fixnum (sparse-vector-size sv))))
973    (%err-disp $xarroob sv i))
974  (let* ((default (sparse-vector-default sv)))
975    (with-lock-grabbed ((sparse-vector-lock sv))
976      (locally (declare (fixnum i))
977        (let* ((major (ash i -8))
978               (minor (logand i #xff))
979               (table (sparse-vector-table sv))
980               (tablen (length table))
981               (v (if (< major tablen)
982                    (svref table major))))
983          (unless v
984            (unless (eql new default)
985              (when (>= major tablen)
986                (let* ((newtab (make-array (the fixnum (1+ major)) :initial-element nil)))
987                  (%copy-gvector-to-gvector table 0 newtab 0 tablen)
988                  (setf (sparse-vector-table sv) (setq table newtab))))
989              (setq v (setf (svref table major) (make-array 256 :element-type (sparse-vector-element-type sv) :initial-element default)))))
990          (when v
991            (uvset v minor new))))))
992  new)
993
994(defun copy-sparse-vector (in)
995  (let* ((intab (sparse-vector-table in))
996         (tabsize (length intab )))
997    (declare (fixnum tabsize) (simple-vector intab))
998    (let* ((out (%make-sparse-vector :size (sparse-vector-size in)
999                                     :element-type (sparse-vector-element-type in)
1000                                     :default (sparse-vector-default in)
1001                                     :table (make-array tabsize :initial-element nil)))
1002           (outtab (sparse-vector-table out)))
1003      (declare (simple-vector outtab))
1004      (dotimes (i tabsize out)
1005        (let* ((v (svref intab i)))
1006          (when v
1007            (setf (svref outtab i) (copy-seq v))))))))
1008
1009(defmethod print-object ((sv sparse-vector) stream)
1010  (print-unreadable-object (sv stream :type t :identity t)
1011    (format stream "~d ~s" (sparse-vector-size sv) (sparse-vector-element-type sv))))
Note: See TracBrowser for help on using the repository browser.