source: trunk/ccl/level-1/sysutils.lisp @ 7247

Last change on this file since 7247 was 7247, checked in by palter, 13 years ago

Return all three values from CCL::PRINT-DEFERRED-WARNINGS

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 22.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;; sysutils.lisp - things which have outgrown l1-utils
19
20(in-package "CCL")
21
22(eval-when (:execute :compile-toplevel)
23  (require 'level-2)
24  (require 'optimizers)
25  (require 'backquote)
26  (require 'defstruct-macros)
27  )
28
29;;; things might be clearer if this stuff were in l1-typesys?
30;;; Translation from type keywords to specific predicates.
31(eval-when (:execute :compile-toplevel)
32
33(defconstant type-pred-pairs
34  '((array . arrayp)
35    (atom . atom)
36    (base-string . base-string-p)
37    (bignum . bignump)
38    (bit . bitp)
39    (bit-vector . bit-vector-p)
40    (character . characterp)
41    (compiled-function . compiled-function-p)
42    (complex . complexp)
43    (cons . consp)
44    (double-float . double-float-p)
45    (fixnum . fixnump) ;not cl
46    (float . floatp)
47    (function . functionp)
48    (hash-table . hash-table-p)
49    (integer . integerp)
50    (real . realp)
51    (keyword . keywordp)
52    (list . listp)
53    (long-float . double-float-p)
54    (nil . false)
55    (null . null)
56    (number . numberp)
57    (package . packagep)
58    (pathname . pathnamep)
59    (logical-pathname . logical-pathname-p)
60    (random-state . random-state-p)
61    (ratio . ratiop)
62    (rational . rationalp)
63    (readtable . readtablep)
64    (sequence . sequencep)
65    (short-float . short-float-p)
66    (signed-byte . integerp)
67    (simple-array . simple-array-p)
68    (simple-base-string . simple-base-string-p)
69    (simple-extended-string . simple-extended-string-p)
70    (simple-bit-vector . simple-bit-vector-p)
71    (simple-string . simple-string-p)
72    (simple-vector . simple-vector-p)
73    (single-float . short-float-p)
74    (stream . streamp)
75    (string . stringp)
76    (extended-string . extended-string-p)
77    (base-char . base-char-p)
78    (extended-char . extended-char-p)
79    (structure-object . structurep)
80    (symbol . symbolp)
81    (t . true)
82    (unsigned-byte . unsigned-byte-p)
83    (vector . vectorp)
84    ))
85
86(defmacro init-type-predicates ()
87  `(dolist (pair ',type-pred-pairs)
88     (setf (type-predicate (car pair)) (cdr pair))
89     (let ((ctype (info-type-builtin (car pair))))       
90       (if (typep ctype 'numeric-ctype)
91         (setf (numeric-ctype-predicate ctype) (cdr pair))))))
92
93)
94
95(init-type-predicates)
96
97(defun unsigned-byte-8-p (n)
98  (and (fixnump n)
99       (locally (declare (fixnum n))
100         (and 
101          (>= n 0)
102          (< n #x100)))))
103
104(defun signed-byte-8-p (n)
105  (and (fixnump n)
106       (locally (declare (fixnum n))
107         (and 
108          (>= n -128)
109          (<= n 127)))))
110
111(defun unsigned-byte-16-p (n)
112  (and (fixnump n)
113       (locally (declare (fixnum n))
114         (and 
115          (>= n 0)
116          (< n #x10000)))))
117
118(defun signed-byte-16-p (n)
119  (and (fixnump n)
120       (locally (declare (fixnum n))
121         (and 
122          (>= n -32768)
123          (<= n 32767)))))
124
125(defun unsigned-byte-32-p (n)
126  (and (integerp n)
127       (>= n 0)
128       (<= n #xffffffff)))
129
130(defun signed-byte-32-p (n)
131  (and (integerp n)
132       (>= n  -2147483648)
133       (<= n 2147483647)))
134
135(eval-when (:load-toplevel :execute)
136  (let ((more-pairs
137         '(((unsigned-byte 8) . unsigned-byte-8-p)
138           ((signed-byte 8) . signed-byte-8-p)
139           ((unsigned-byte 16) . unsigned-byte-16-p)
140           ((signed-byte 16) . signed-byte-16-p)
141           ((unsigned-byte 32) . unsigned-byte-32-p)
142           ((signed-byte 32) . signed-byte-32-p))))         
143    (dolist (pair more-pairs)
144      (let ((ctype (info-type-builtin (car pair))))       
145        (if (typep ctype 'numeric-ctype) (setf (numeric-ctype-predicate ctype) (cdr pair))))))
146  )
147
148
149(defun specifier-type-known (type) 
150  (let ((ctype (specifier-type type)))
151    (if (typep ctype 'unknown-ctype)
152      (error "Unknown type specifier ~s." type)
153      (if (and (typep ctype 'numeric-ctype) ; complexp??
154               (eq 'integer (numeric-ctype-class ctype))
155               (not (numeric-ctype-predicate ctype)))
156        (setf (numeric-ctype-predicate ctype)(make-numeric-ctype-predicate ctype))))
157    ctype))
158
159
160(defun find-builtin-cell (type  &optional (create t))
161  (let ((cell (gethash type %builtin-type-cells%)))
162    (or cell
163        (when create
164          (setf (gethash type %builtin-type-cells%)
165                (cons type (or (info-type-builtin type)(specifier-type-known type))))))))
166
167
168; for now only called for builtin types or car = unsigned-byte, signed-byte, mod or integer
169
170(defun builtin-typep (form cell)
171  (unless (listp cell)
172    (setq cell (require-type cell 'list)))
173  (locally (declare (type list cell))
174    (let ((ctype (cdr cell))
175          (name (car cell)))
176      (when (not ctype)
177        (setq ctype (or (info-type-builtin name)(specifier-type-known name)))
178        (when ctype (setf (gethash (car cell) %builtin-type-cells%) cell))
179        (rplacd cell ctype))
180      (if ctype 
181        (if (and (typep ctype 'numeric-ctype)
182                 (numeric-ctype-predicate ctype))
183          ; doing this inline is a winner - at least if true
184          (funcall (numeric-ctype-predicate ctype) form)
185          (%%typep form ctype))
186        (typep form name)))))
187
188#|
189(defvar %find-classes% (make-hash-table :test 'eq))
190
191(defun find-class-cell (name create?)
192  (let ((cell (gethash name %find-classes%)))
193    (or cell
194        (and create?
195             (setf (gethash name %find-classes%) (cons name nil))))))
196|#
197
198;(setq *type-system-initialized* t)
199
200
201;; Type-of, typep, and a bunch of other predicates.
202
203;;; Data type predicates.
204
205;;; things might be clearer if this stuff were in l1-typesys?
206;;; Translation from type keywords to specific predicates.
207
208
209
210
211;necessary since standard-char-p, by definition, errors if not passed a char.
212(setf (type-predicate 'standard-char)
213      #'(lambda (form) (and (characterp form) (standard-char-p form))))
214
215(defun type-of (form)
216  "Return the type of OBJECT."
217  (case form
218    ((t) 'boolean)
219    ((0 1) 'bit)
220    (t
221     (typecase form
222       (standard-char 'standard-char)
223       (keyword 'keyword)
224       ;; Partition integers so that the negative cases
225       ;; are SIGNED-BYTE and the positive are UNSIGNED-BYTE
226       (fixnum
227        (if (< (the fixnum form) 0)
228          'fixnum
229          '(integer 0 #.target::target-most-positive-fixnum)))
230       (bignum
231        (if (< form 0)
232          'bignum
233          '(integer  #.(1+ target::target-most-positive-fixnum))))
234       ((or array complex) (type-specifier (ctype-of form)))
235       (t
236        (if (eql (typecode form) target::subtag-istruct)
237          (%svref form 0)
238          (let* ((class (class-of form))
239                 (class-name (class-name class)))
240            (if (eq class (find-class class-name nil))
241              class-name
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  (declare (ignore env))
298  (let* ((pred (if (symbolp type) (type-predicate type))))
299    (if pred
300      (funcall pred object)
301      (values (%typep object type)))))
302
303
304
305;This is like check-type, except it returns the value rather than setf'ing
306;anything, and so can be done entirely out-of-line.
307(defun require-type (arg type) 
308  (if (typep  arg type)
309    arg
310    (%kernel-restart $xwrongtype arg type)))
311
312; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
313(defun %require-type (arg predsym)
314    (if (funcall predsym arg)
315    arg
316    (%kernel-restart $xwrongtype arg `(satisfies ,predsym))))
317
318(defun %require-type-builtin (arg type-cell) 
319  (if (builtin-typep arg type-cell)
320    arg
321    (%kernel-restart $xwrongtype arg (car type-cell))))
322
323
324
325
326
327
328; Subtypep.
329
330(defun subtypep (type1 type2 &optional env)
331  (declare (ignore env))
332  "Return two values indicating the relationship between type1 and type2.
333  If values are T and T, type1 definitely is a subtype of type2.
334  If values are NIL and T, type1 definitely is not a subtype of type2.
335  If values are NIL and NIL, it couldn't be determined."
336  (csubtypep (specifier-type type1) (specifier-type type2)))
337
338
339
340
341(defun preload-all-functions ()
342  nil)
343
344
345 ; used by arglist
346(defun temp-cons (a b)
347  (cons a b))
348
349
350
351
352(defun copy-into-float (src dest)
353  (%copy-double-float src dest))
354
355(queue-fixup
356 (defun fmakunbound (name)
357   "Make NAME have no global function definition."
358   (let* ((fname (validate-function-name name)))
359     (remhash fname %structure-refs%)
360     (%unfhave fname))
361   name))
362
363(defun frozen-definition-p (name)
364  (if (symbolp name)
365    (%ilogbitp $sym_fbit_frozen (%symbol-bits name))))
366
367(defun redefine-kernel-function (name)
368  (when (and *warn-if-redefine-kernel*
369             (frozen-definition-p name)
370             (or (lfunp (fboundp name))
371                 (and (not (consp name)) (macro-function name)))
372             (or (and (consp name) (neq (car name) 'setf))
373                 (let ((pkg (symbol-package (if (consp name) (cadr name) name))))
374                   (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg)))))
375    (cerror "Replace the definition of ~S."
376            "The function ~S is predefined in OpenMCL." name)
377    (unless (consp name)
378      (proclaim-inline nil name))))
379
380(defun fset (name function)
381  (setq function (require-type function 'function))
382  (when (symbolp name)
383    (when (special-operator-p name)
384      (error "Can not redefine a special-form: ~S ." name))
385    (when (macro-function name)
386      (cerror "Redefine the macro ~S as a function"
387              "The macro ~S is being redefined as a function." name)))
388; This lets us redefine %FHAVE.  Big fun.
389  (let ((fhave #'%fhave))
390    (redefine-kernel-function name)
391    (fmakunbound name)
392    (funcall fhave name function)
393    function))
394
395(defsetf symbol-function fset)
396(defsetf fdefinition fset)
397
398(defun (setf macro-function) (macro-fun name &optional env)
399  (declare (ignore env))
400  (unless (typep macro-fun 'function)
401    (report-bad-arg macro-fun 'function))
402  (if (special-operator-p name)
403    (error "Can not redefine a special-form: ~S ." name))
404  (when (and (fboundp name) (not (macro-function name)))
405    (warn "The function ~S is being redefined as a macro." name))
406  (redefine-kernel-function name)
407  (fmakunbound name)
408  (%macro-have name macro-fun)
409  macro-fun)
410
411(defun set-macro-function (name def)
412  (setf (macro-function name) def))
413
414
415
416
417;;; Arrays and vectors, including make-array.
418
419
420
421
422
423
424
425(defun char (string index)
426  "Given a string and a non-negative integer index less than the length of
427  the string, returns the character object representing the character at
428  that position in the string."
429 (if (stringp string)
430  (aref string index)
431  (report-bad-arg string 'string)))
432
433(defun set-char (string index new-el)
434  (if (stringp string)
435    (aset string index new-el)
436    (report-bad-arg string 'string)))
437
438(defun equalp (x y)
439  "Just like EQUAL, but more liberal in several respects.
440  Numbers may be of different types, as long as the values are identical
441  after coercion.  Characters may differ in alphabetic case.  Vectors and
442  arrays must have identical dimensions and EQUALP elements, but may differ
443  in their type restriction.
444  If one of x or y is a pathname and one is a string with the name of the
445  pathname then this will return T."
446  (cond ((eql x y) t)
447        ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y))))
448        ((numberp x) (and (numberp y) (= x y)))
449        ((consp x)
450         (and (consp y)
451              (equalp (car x) (car y))
452              (equalp (cdr x) (cdr y))))       
453        ((pathnamep x) (equal x y))
454        ((vectorp x)
455         (and (vectorp y)
456              (let ((length (length x)))
457                (when (eq length (length y))
458                  (dotimes (i length t)
459                    (declare (fixnum i))
460                    (let ((x-el (aref x i))
461                          (y-el (aref y i)))
462                      (unless (or (eq x-el y-el) (equalp x-el y-el))
463                        (return nil))))))))
464        ((arrayp x)
465         (and (arrayp y)
466              (let ((rank (array-rank x)) x-el y-el)
467                (and (eq (array-rank y) rank)
468                     (if (%izerop rank) (equalp (aref x) (aref y))
469                         (and
470                          (dotimes (i rank t)
471                            (declare (fixnum i))
472                            (unless (eq (array-dimension x i)
473                                        (array-dimension y i))
474                              (return nil)))
475                          (multiple-value-bind (x0 i) (array-data-and-offset x)
476                            (multiple-value-bind (y0 j) (array-data-and-offset y)
477                              (dotimes (count (array-total-size x) t)
478                                (declare (fixnum count))
479                                (setq x-el (uvref x0 i) y-el (uvref y0 j))
480                                (unless (or (eq x-el y-el) (equalp x-el y-el))
481                                  (return nil))
482                                (setq i (%i+ i 1) j (%i+ j 1)))))))))))
483        ((and (structurep x) (structurep y))
484         (let ((size (uvsize x)))
485           (and (eq size (uvsize y))
486                (dotimes (i size t)
487                  (declare (fixnum i))
488                  (unless (equalp (uvref x i) (uvref y i))
489                    (return nil))))))
490        ((and (hash-table-p x) (hash-table-p y))
491         (%hash-table-equalp x y))
492        (t nil)))
493
494
495; The compiler (or some transforms) might want to do something more interesting
496; with these, but they have to exist as functions anyhow.
497
498
499
500(defun complement (function)
501  "Return a new function that returns T whenever FUNCTION returns NIL and
502   NIL whenever FUNCTION returns non-NIL."
503  (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell
504  #'(lambda (&rest args)
505      (declare (dynamic-extent args)) ; not tail-recursive anyway
506      (not (apply f args)))))
507
508; Special variables are evil, but I can't think of a better way to do this.
509
510(defparameter *outstanding-deferred-warnings* nil)
511(def-accessors (deferred-warnings) %svref
512  nil
513  deferred-warnings.parent
514  deferred-warnings.warnings
515  deferred-warnings.defs
516  deferred-warnings.flags ; might use to distinguish interactive case/compile-file
517)
518
519(defun %defer-warnings (override &optional flags)
520  (%istruct 'deferred-warnings (unless override *outstanding-deferred-warnings*) nil nil flags))
521
522(defun report-deferred-warnings ()
523  (let* ((current *outstanding-deferred-warnings*)
524         (parent (deferred-warnings.parent current))
525         (defs (deferred-warnings.defs current))
526         (warnings (deferred-warnings.warnings current))
527         (any nil)
528         (harsh nil))
529    (if parent
530      (setf (deferred-warnings.warnings parent) (append warnings (deferred-warnings.warnings parent))
531            (deferred-warnings.defs parent) (append defs (deferred-warnings.defs parent))
532            parent t)
533      (let* ((file nil)
534             (init t))
535        (dolist (w warnings)
536          (let ((wfname (car (compiler-warning-args w))))
537            (when (if (typep w 'undefined-function-reference)
538                    (not (or (fboundp wfname)
539                             (assq wfname defs))))
540              (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any))
541              (setq init nil))))))
542    (values any harsh parent)))
543
544(defun print-nested-name (name-list stream)
545  (if (null name-list)
546    (princ "a toplevel form" stream)
547    (progn
548      (if (car name-list)
549        (prin1 (%car name-list) stream)
550        (princ "an anonymous lambda form" stream))
551      (when (%cdr name-list)
552        (princ " inside " stream)
553        (print-nested-name (%cdr name-list) stream)))))
554
555(defparameter *suppress-compiler-warnings* nil)
556
557(defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p)
558  (let ((muffled *suppress-compiler-warnings*)
559        (w-file (compiler-warning-file-name w))
560        (s *error-output*))
561    (unless muffled 
562      (restart-case (signal w)
563        (muffle-warning () (setq muffled t))))
564    (unless muffled
565      (setq any-p t)
566      (unless (typep w 'style-warning) (setq harsh-p t))
567      (when (or init-p (not (equalp w-file last-w-file)))
568        (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter"))
569        (if w-file (format s "for ~S :" w-file) (princ ":" s)))
570      (format s "~&;   ~A" w))
571    (values harsh-p any-p w-file)))
572
573;;;; Assorted mumble-P type predicates.
574;;;; No functions have been in the kernel for the last year or so.
575;;;; (Just thought you'd like to know.)
576
577(defun sequencep (form)
578  "Not CL. SLISP Returns T if form is a sequence, NIL otherwise."
579   (or (listp form) (vectorp form)))
580
581;;; The following are not defined at user level, but are necessary for
582;;; internal use by TYPEP.
583
584(defun bitp (form)
585  "Not CL. SLISP"
586  (or (eq form 0) (eq form 1)))
587
588(defun unsigned-byte-p (form)
589  (and (integerp form) (not (< form 0))))
590
591;This is false for internal structures.
592;;; ---- look at defenv.structures, not defenv.structrefs
593
594(defun structure-class-p (form &optional env)
595  (and (symbolp form)
596       (let ((sd (or (and env
597                          (let ((defenv (definition-environment env)))
598                            (and defenv
599                                 (%cdr (assq form (defenv.structures defenv))))))
600                     (gethash form %defstructs%))))
601         (and sd
602              (null (sd-type sd))
603              sd))))
604
605
606
607
608
609(defun type-keyword-code (type-keyword &optional target)
610  (let* ((backend (if target (find-backend target) *target-backend*))
611         (alist (arch::target-uvector-subtags (backend-target-arch backend)))
612         (entry (assq type-keyword alist)))
613    (if entry
614      (let* ((code (cdr entry)))
615        (or code (error "Vector type ~s invalid," type-keyword)))
616      (error "Unknown type-keyword ~s. " type-keyword))))
617
618
619(defstruct id-map
620  (vector (make-array 1 :initial-element nil))
621  (free 0)
622  (lock (make-lock)))
623
624;;; Caller owns the lock on the id-map.
625(defun id-map-grow (id-map)
626  (without-interrupts
627   (let* ((old-vector (id-map-vector id-map))
628          (old-size (length old-vector))
629          (new-size (+ old-size old-size))
630          (new-vector (make-array new-size)))
631     (declare (fixnum old-size new-size))
632     (dotimes (i old-size)
633       (setf (svref new-vector i) (svref old-vector i)))
634     (let* ((limit (1- new-size)))
635       (declare (fixnum limit))
636       (do* ((i old-size (1+ i)))
637            ((= i limit) (setf (svref new-vector i) nil))
638         (declare (fixnum i))
639         (setf (svref new-vector i) (the fixnum (1+ i)))))
640     (setf (id-map-vector id-map) new-vector
641           (id-map-free id-map) old-size))))
642
643;;; Map an object to a small fixnum ID in id-map.
644;;; Object can't be NIL or a fixnum itself.
645(defun assign-id-map-id (id-map object)
646  (if (or (null object) (typep object 'fixnum))
647    (setq object (require-type object '(not (or null fixnum)))))
648  (with-lock-grabbed ((id-map-lock id-map))
649    (let* ((free (or (id-map-free id-map) (id-map-grow id-map)))
650           (vector (id-map-vector id-map))
651           (newfree (svref vector free)))
652      (setf (id-map-free id-map) newfree
653            (svref vector free) object)
654      free)))
655     
656;;; Referemce the object with id ID in ID-MAP.  Leave the object in
657;;; the map.
658(defun id-map-object (id-map id)
659  (let* ((object (with-lock-grabbed ((id-map-lock id-map))
660                   (svref (id-map-vector id-map) id))))
661    (if (or (null object) (typep object 'fixnum))
662      (error "invalid index ~d for ~s" id id-map)
663      object)))
664
665;;; Referemce the object with id ID in ID-MAP.  Remove the object from
666;;; the map.
667(defun id-map-free-object (id-map id)
668  (with-lock-grabbed ((id-map-lock id-map))
669    (let* ((vector (id-map-vector id-map))
670           (object (svref vector id)))
671      (if (or (null object) (typep object 'fixnum))
672        (error "invalid index ~d for ~s" id id-map))
673      (setf (svref vector id) (id-map-free id-map)
674            (id-map-free id-map) id)
675      object)))
676
677(defun id-map-modify-object (id-map id old-value new-value)
678  (with-lock-grabbed ((id-map-lock id-map))
679    (let* ((vector (id-map-vector id-map))
680           (object (svref vector id)))
681      (if (or (null object) (typep object 'fixnum))
682        (error "invalid index ~d for ~s" id id-map))
683      (if (eq object old-value)
684        (setf (svref vector id) new-value)))))
685
686
687   
688
689(setq *type-system-initialized* t)
690
691
692
693
Note: See TracBrowser for help on using the repository browser.