/[gcl]/gcl/lsp/gcl_predlib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_predlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.21 by pfdietz, Wed Aug 24 02:55:33 2005 UTC revision 1.22 by camm, Wed Sep 7 02:49:59 2005 UTC
# Line 25  Line 25 
25    
26  (in-package 'system)  (in-package 'system)
27    
28  (export '(lisp::upgraded-complex-part-type  (export '(lisp::upgraded-complex-part-type lisp::type-of
29            lisp::deftype lisp::typep lisp::subtypep            lisp::deftype lisp::typep lisp::subtypep
30            lisp::coerce lisp::upgraded-array-element-type) 'lisp)            lisp::coerce lisp::upgraded-array-element-type) 'lisp)
31    
# Line 37  Line 37 
37  (eval-when (compile)  (eval-when (compile)
38             (proclaim '(optimize (safety 0) (space 3) (speed 3))))             (proclaim '(optimize (safety 0) (space 3) (speed 3))))
39    
40    (defun type-of (object)
41      (or (and (typep object 'standard-object)
42               (let* ((c (class-of object))
43                      (n (class-name c)))
44                 (if (and n (eq c (find-class n nil))) n c)))
45          (let ((tp (type-of-c object)))
46            (if (member tp '(vector array));FIXME
47                `(,tp ,(upgraded-array-element-type (array-element-type object)))
48              tp))))
49    
50  (defun typep-int (object type &aux tp i tem)  (defun typep-int (object type &aux tp i tem)
51    (if (atom type)    (if (atom type)
52        (setq tp type i nil)        (setq tp type i nil)
53        (setq tp (car type) i (cdr type)))        (setq tp (car type) i (cdr type)))
54      (when (or (eq tp 'values) (and (eq tp 'function) i))
55        (error "Bad type to typep: ~S" type))
56    (if (eq tp 'structure-object) (setq tp 'structure))    (if (eq tp 'structure-object) (setq tp 'structure))
57    (when (and (eq tp 'structure) (typep-int object 'standard-object))    (when (and (member tp '(structure compiled-function)) (typep-int object 'standard-object))
58      (return-from typep-int nil))      (return-from typep-int nil))
59    (let ((f (and (not i) (symbolp tp) (get tp 'type-predicate))))    (let ((f (and (not i) (symbolp tp) (get tp 'type-predicate))))
60      (when f (return-from typep-int (let ((z (funcall f object))) z))))      (when f (return-from typep-int (let ((z (funcall f object))) z))))
61    (case tp    (case tp
62      (cons (and (consp object)      (cons (and (consp object)
63                 (or (endp i)                 (or (not i)
64                     (and (typep-int (car object) (car i))                     (and (typep-int (car object) (car i))
65                          (or (endp (cdr i))                          (or (endp (cdr i))
66                              (typep-int (cdr object) (cadr i)))))))                              (typep-int (cdr object) (cadr i)))))))
# Line 66  Line 78 
78      ((t) t)      ((t) t)
79      ((nil) nil)      ((nil) nil)
80      (boolean (or (eq object 't) (eq object 'nil)))      (boolean (or (eq object 't) (eq object 'nil)))
81      (fixnum (eq (type-of object) 'fixnum))      (bignum (member (type-of-c object) '(bignum non-negative-bignum negative-bignum)))
82      (bignum (eq (type-of object) 'bignum))      (ratio (eq (type-of-c object) 'ratio))
     (ratio (eq (type-of object) 'ratio))  
     (standard-char  
      (and (characterp object) (standard-char-p object)))  
83      ((base-char string-char)      ((base-char string-char)
84       (and (characterp object) (string-char-p object)))       (and (characterp object) (string-char-p object)))
85      (integer      (integer
# Line 82  Line 91 
91      (float      (float
92       (and (floatp object) (in-interval-p object i)))       (and (floatp object) (in-interval-p object i)))
93      ((short-float)      ((short-float)
94       (and (eq (type-of object) 'short-float) (in-interval-p object i)))       (and (eq (type-of-c object) 'short-float) (in-interval-p object i)))
95      ((single-float double-float long-float)      ((single-float double-float long-float)
96       (and (eq (type-of object) 'long-float) (in-interval-p object i)))       (and (eq (type-of-c object) 'long-float) (in-interval-p object i)))
97      (complex      (complex
98       (and (complexp object)       (and (complexp object)
99                        (or (null i)
100      (or (null i)                (and   (typep-int (realpart object) (car i))
101         (and   (typep-int (realpart object) (car i))                       ;;wfs--should only have to check one.
102              ;;wfs--should only have to check one.                       ;;Illegal to mix real and imaginary types!
103              ;;Illegal to mix real and imaginary types!                       (typep-int (imagpart object) (car i))))))
               (typep-int (imagpart object) (car i))))  
      ))  
104      (sequence (or (listp object) (vectorp object)))      (sequence (or (listp object) (vectorp object)))
105      ((base-string string) ;FIXME      ((base-string string simple-base-string simple-string) ;FIXME
106       (and (stringp object)       (and (stringp object)
107            (or (endp i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (match-dimensions (array-dimensions object) i))))
108      (bit-vector      ((bit-vector simple-bit-vector)
109       (and (bit-vector-p object)       (and (bit-vector-p object)
110            (or (endp i) (match-dimensions (array-dimensions object) i))))            (or (endp i) (match-dimensions (array-dimensions object) i))))
111      ((simple-base-string simple-string) ;FIXME      ((vector simple-vector)
      (and (simple-string-p object)  
           (or (endp i) (match-dimensions (array-dimensions object) i))))  
     (simple-bit-vector  
      (and (simple-bit-vector-p object)  
           (or (endp i) (match-dimensions (array-dimensions object) i))))  
     (simple-vector  
      (and (simple-vector-p object)  
           (or (endp i) (eq (car i) '*)  
               (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))  
               (equal (array-element-type object) (best-array-element-type (car i))))  
           (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))  
     (vector  
112       (and (vectorp object)       (and (vectorp object)
113            (or (endp i) (eq (car i) '*)            (let ((at (upgraded-array-element-type (or (car i) (if (eq tp 'vector) '* t)))))
114                (and (eq (car i) t) (not (stringp object)) (not (bit-vector-p object)))              (or (eq at '*) (eq at (upgraded-array-element-type (array-element-type object)))))
115                (equal (array-element-type object) (best-array-element-type (car i))))            (or (not (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))
116            (or (endp (cdr i)) (match-dimensions (array-dimensions object) (cdr i)))))      ((array simple-array)
     (simple-array  
      (and (simple-array-p object)  
           (or (endp i) (eq (car i) '*)  
               (equal (array-element-type object)(best-array-element-type (car i))))  
           (or (endp (cdr i)) (eq (cadr i) '*)  
               (if (listp (cadr i))  
                   (match-dimensions (array-dimensions object) (cadr i))  
                 (eql (array-rank object) (cadr i))))))  
     (array  
117       (and (arrayp object)       (and (arrayp object)
118            (or (endp i) (eq (car i) '*)            (let ((at (upgraded-array-element-type (or (car i) '*))))
119                ;; Or the element type of object should be EQUAL to (car i).              (or (eq at '*) (eq at (upgraded-array-element-type (array-element-type object)))))
120                ;; Is this too strict?            (or (not (cdr i)) (eq (cadr i) '*)
               (equal (array-element-type object) (best-array-element-type (car i))))  
           (or (endp (cdr i)) (eq (cadr i) '*)  
121                (if (listp (cadr i))                (if (listp (cadr i))
122                    (match-dimensions (array-dimensions object) (cadr i))                    (match-dimensions (array-dimensions object) (cadr i))
123                  (eql (array-rank object) (cadr i))))))                  (eql (array-rank object) (cadr i))))))
124      (file-stream (eq (type-of object) 'file-stream))      ((file-stream string-stream synonym-stream concatenated-stream
125      (string-stream (eq (type-of object) 'string-stream))                    broadcast-stream two-way-stream echo-stream) (eq (type-of-c object) tp))
     (synonym-stream (eq (type-of object) 'synonym-stream))  
     (concatenated-stream (eq (type-of object) 'concatenated-stream))  
     (two-way-stream (eq (type-of object) 'two-way-stream))  
     (echo-stream (eq (type-of object) 'echo-stream))  
     (logical-pathname  
       (and (pathnamep object)  
            (not (endp (si:pathname-lookup (pathname-host object)  
                                           si:*pathname-logical*)))))  
126      (t (cond      (t (cond
127           ((setq tem (when (symbolp tp) (get tp 'deftype-definition)))           ((setq tem (when (symbolp tp) (get tp 'deftype-definition)))
128            (typep-int object (apply tem i)))            (typep-int object (apply tem i)))
129           ((if (symbolp tp) (get tp 'si::s-data) (typep-int tp 's-data))           ((if (symbolp tp) (get tp 's-data) (typep-int tp 's-data))
130            (let ((z (structure-subtype-p object tp))) z))            (let ((z (structure-subtype-p object tp))) z))
131           ((typep tp 'class)           ((classp tp)
132            (values (subtypep (type-of object) tp)))))))            (values (subtypep (class-of object) tp)))))))
133                    
134    
135  ;;; TYPEP predicate.  ;;; TYPEP predicate.
# Line 216  Line 192 
192    (declare (ignore env) (optimize (safety 1)))    (declare (ignore env) (optimize (safety 1)))
193    (if (or (not t1) (eq t2 t))    (if (or (not t1) (eq t2 t))
194        (values t t)        (values t t)
195      (values (not (resolve-type `(and ,t1 ,(negate t2)))) t)))      (let ((rt (resolve-type `(and ,t1 ,(negate t2)))))
196          (values (not (car rt)) (not (cadr rt))))))
197    
198  (defun upgraded-complex-part-type (type &optional environment)  (defun upgraded-complex-part-type (type &optional environment)
199    (declare (ignore environment) (optimize (safety 1)) )    (declare (ignore environment) (optimize (safety 1)) )
# Line 239  Line 216 
216    (if (atom type) (setq type (list type)))    (if (atom type) (setq type (list type)))
217    (case (car type)    (case (car type)
218          (function          (function
219           (assert-type object 'symbol)           (cond ((symbolp object) (symbol-function object))
220           (symbol-function object))                 ((and (consp object) (eq (car object) 'lambda)) (eval `(function ,object)))
221                   ((function-identifierp object) (get (cadr object) 'setf-function))));FIXME
222          (list          (list
223           (do ((l nil (cons (elt object i) l))           (do ((l nil (cons (elt object i) l))
224                (i (1- (length object)) (1- i)))                (i (1- (length object)) (1- i)))
225               ((< i 0) l)))               ((< i 0) l)))
226          ((array simple-array vector simple-vector bit-vector string simple-string)          ((array simple-array vector simple-vector bit-vector simple-bit-vector string simple-string)
227           (when (cdr type) ;;FIXME           (when (cdr type) ;;FIXME
228             (assert-type (cdr type) 'cons)             (assert-type (cdr type) 'cons)
229             (when (cddr type)             (when (cddr type)
# Line 269  Line 247 
247          (t (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type))))          (t (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S." object type))))
248    
249  ;;; DEFTYPE macro.  ;;; DEFTYPE macro.
250  (defmacro deftype (name lambda-list &rest body)  (defmacro deftype (name lambda-list &rest body &aux decls)
251    ;; Replace undefaultized optional parameter X by (X '*).    ;; Replace undefaultized optional parameter X by (X '*).
252    (declare (optimize (safety 1)))    (declare (optimize (safety 1)))
253      (do ((b body body)) ((or (not b) (not (consp (car b))) (not (eq 'declare (caar b)))) (nreverse decls))
254          (let ((d (pop body)))
255            (unless (member-if (lambda (x) (and (consp x) (eq (car x) 'special))) (cdr d)) ;FIXME
256              (push d decls))))
257    (do ((l lambda-list (cdr l))    (do ((l lambda-list (cdr l))
258         (m nil (cons (car l) m)))         (m nil (cons (car l) m)))
259        ((null l))        ((null l))
260      (when (member (car l) lambda-list-keywords)      (when (member (car l) lambda-list-keywords)
261            (unless (eq (car l) '&optional) (return nil))            (unless (member (car l) '(&optional &key)) (return nil))
262            (setq m (cons '&optional m))            (setq m (cons (car l) m))
263            (setq l (cdr l))            (setq l (cdr l))
264            (do ()            (do ()
265                ((or (null l) (member (car l) lambda-list-keywords)))                ((or (null l) (member (car l) lambda-list-keywords)))
# Line 288  Line 270 
270            (setq lambda-list (nreconc m l))            (setq lambda-list (nreconc m l))
271            (return nil)))            (return nil)))
272    `(eval-when (compile eval load)    `(eval-when (compile eval load)
273                (si:putprop ',name                (putprop ',name
274                            '(deftype ,name ,lambda-list ,@body)                            '(deftype ,name ,lambda-list ,@body)
275                            'deftype-form)                            'deftype-form)
276                (si:putprop ',name                (putprop ',name
277                            (if (null ',lambda-list)                         (if (null ',lambda-list)
278                                (let ((tem (progn ,@body)))                             (lambda nil ,@decls (block ,name ,`(progn ,@body)))
279                                  (lambda ,lambda-list tem))                           (lambda ,lambda-list ,@decls (block ,name ,@body)))
                             (lambda ,lambda-list ,@body))  
280                            'deftype-definition)                            'deftype-definition)
281                (si:putprop ',name                (putprop ',name
282                            ,(find-documentation body)                            ,(find-documentation body)
283                            'type-documentation)                            'type-documentation)
284                ',name))                ',name))
# Line 312  Line 293 
293    `(integer 0 ,(1- n)))    `(integer 0 ,(1- n)))
294  (deftype non-negative-byte (&optional s)  (deftype non-negative-byte (&optional s)
295    (if (eq s '*)    (if (eq s '*)
296        `(integer * *)        `(integer 0 *)
297        `(integer 0 ,(1- (expt 2 (1- s))))))        `(integer 0 ,(1- (expt 2 (1- s))))))
298  (deftype negative-byte (&optional s)  (deftype negative-byte (&optional s)
299    (if (eq s '*)    (if (eq s '*)
300        `(integer * *)        `(integer * -1)
301        `(integer ,(- (expt 2 (1- s))) -1)))        `(integer ,(- (expt 2 (1- s))) -1)))
302  (deftype signed-byte (&optional s)  (deftype signed-byte (&optional s)
303    (if (eq s '*)    (if (eq s '*)
# Line 355  Line 336 
336  (deftype vector (&optional element-type size)  (deftype vector (&optional element-type size)
337    `(array ,element-type (,size)))    `(array ,element-type (,size)))
338  (deftype string (&optional size)  (deftype string (&optional size)
339    `(vector string-char ,size))    `(array string-char (,size)))
340  (deftype base-string (&optional size)  (deftype base-string (&optional size)
341    `(vector base-char ,size))    `(array base-char (,size)))
342  (deftype bit-vector (&optional size)  (deftype bit-vector (&optional size)
343    `(vector bit ,size))    `(array bit (,size)))
344    
345  (deftype simple-vector (&optional size)  (deftype simple-vector (&optional size)
346    `(simple-array t (,size)))    `(array t (,size)))
347  (deftype simple-string (&optional size)  (deftype simple-string (&optional size)
348    `(simple-array string-char (,size)))    `(array string-char (,size)))
349  (deftype simple-base-string (&optional size)  (deftype simple-base-string (&optional size)
350    `(simple-array base-char (,size)))    `(array base-char (,size)))
351  (deftype simple-bit-vector (&optional size)  (deftype simple-bit-vector (&optional size)
352    `(simple-array bit (,size)))    `(array bit (,size)))
353    
354  (deftype function-identifier () `(satisfies si::function-identifierp))  (deftype function-identifier () `(satisfies function-identifierp))
355    
356    
357  (deftype list () `(or cons null))  (deftype list () `(or cons null))
358  (deftype sequence () `(or list vector))  (deftype sequence () `(or list vector))
359    
360    (defun non-standard-base-char-p (x)
361      (and (characterp x) (not (standard-char-p x))))
362    
363    (deftype extended-char () nil)
364    (deftype base-char () `(or standard-char non-standard-base-char))
365  (deftype character () `(or base-char extended-char))  (deftype character () `(or base-char extended-char))
366  (deftype string-char () `(or base-char extended-char))  (deftype string-char () `character)
367    
368  (deftype stream () `(or broadcast-stream concatenated-stream echo-stream  (deftype stream () `(or broadcast-stream concatenated-stream echo-stream
369                          file-stream string-stream synonym-stream two-way-stream))                          file-stream string-stream synonym-stream two-way-stream))
370    
371  (deftype bignum () `(and integer (not fixnum)))  (deftype bignum () `(and integer (not fixnum)))
372    (deftype non-negative-bignum () `(and non-negative-byte (not non-negative-fixnum)))
373    (deftype negative-bignum () `(and negative-byte (not negative-fixnum)))
374  ;;FIXME adjust integer bounds here?  ;;FIXME adjust integer bounds here?
375  (deftype rational (&optional (low '*) (high '*)) `(or (integer ,low ,high) (ratio ,low ,high)))  (deftype rational (&optional (low '*) (high '*)) `(or (integer ,low ,high) (ratio ,low ,high)))
376  (deftype float (&optional (low '*) (high '*)) `(or (short-float ,low ,high) (long-float ,low ,high)))  (deftype float (&optional (low '*) (high '*)) `(or (short-float ,low ,high) (long-float ,low ,high)))
# Line 389  Line 379 
379  (deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high)))  (deftype real (&optional (low '*) (high '*)) `(or (rational ,low ,high) (float ,low ,high)))
380  (deftype number () `(or real complex))  (deftype number () `(or real complex))
381  (deftype atom () `(not cons))  (deftype atom () `(not cons))
382  (deftype function (&optional as vs) `(or interpreted-function compiled-function))  (deftype function (&optional as vs) `(or interpreted-function compiled-function generic-function))
 (deftype base-char () `(or standard-char non-standard-base-char))  
383    
384  (deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))  (deftype integer (&optional (low '*) (high '*)) `(integer ,low ,high))
385  (deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))  (deftype ratio (&optional (low '*) (high '*)) `(ratio ,low ,high))
# Line 400  Line 389 
389  (deftype array (&optional (et '*) (dims '*))  (deftype array (&optional (et '*) (dims '*))
390    `(array ,et ,(if (not dims) 0 dims)))    `(array ,et ,(if (not dims) 0 dims)))
391  (deftype simple-array (&optional (et '*) (dims '*))  (deftype simple-array (&optional (et '*) (dims '*))
392    `(simple-array ,et ,(if (not dims) 0 dims)))    `(array ,et ,(if (not dims) 0 dims)))
393    
394  (deftype eql (&optional (x nil xp)) (when xp `(member ,x)))  (deftype eql (&optional (x nil xp)) (when xp `(member ,x)))
395    
# Line 414  Line 403 
403  (deftype complex (&optional (rp 'real)) `(complex ,(if (eq rp '*) 'real rp)))  (deftype complex (&optional (rp 'real)) `(complex ,(if (eq rp '*) 'real rp)))
404  (deftype cons (&optional (car t) (cdr t)) `(cons ,(if (eq car '*) t car)  ,(if (eq cdr '*) t cdr)))  (deftype cons (&optional (car t) (cdr t)) `(cons ,(if (eq car '*) t car)  ,(if (eq cdr '*) t cdr)))
405  (deftype structure-object () `(structure))  (deftype structure-object () `(structure))
406    (deftype pathname () `(or non-logical-pathname logical-pathname))
407    
408    (defun non-logical-pathname-p (x)
409      (and (pathnamep x) (not (logical-pathname-p x))))
410    
411  (defun non-keyword-symbol-p (x)  (defun non-keyword-symbol-p (x)
412    (and (symbolp x) (not (keywordp x))))    (and (symbolp x) (not (keywordp x))))
413    
414  (defun function-identifierp (tp)  (defun function-identifierp (tp)
415    (or (symbolp tp)    (or (symbolp tp)
416          (and (consp tp) (eq (car tp) 'lambda))
417        (and (consp tp)        (and (consp tp)
418             (eq (car tp) 'setf)             (eq (car tp) 'setf)
419             (consp (cdr tp))             (consp (cdr tp))
420             (symbolp (cadr tp))             (symbolp (cadr tp))
421             (not (cddr tp)))))             (not (cddr tp)))))
422    
423  (defun simple-array-p (x)  ;(defun simple-array-p (x)
424    (and (arrayp x)  ;  (and (arrayp x)
425         ;; should be (not (expressly-adjustable-p x))         ;; should be (not (expressly-adjustable-p x))
426         ;; since the following will always return T         ;; since the following will always return T
427         ;; (not (adjustable-array-p x))         ;; (not (adjustable-array-p x))
428         (not (array-has-fill-pointer-p x))  ;       (not (array-has-fill-pointer-p x))
429         (not (si:displaced-array-p x))))  ;       (not (displaced-array-p x))))
430    
431    
432  (defun non-standard-base-char-p (x)  ;(defun extended-char-p (x) (declare (ignore x)) nil)
   (and (characterp x) (not (standard-char-p x))))  
   
 (defun extended-char-p (x) (declare (ignore x)) nil)  
433    
434  (defun interpreted-function-p (x)  ;(defun interpreted-function-p (x)
435    (and (function-p x) (not (compiled-function-p x))))  ;  (and (function-p x) (not (compiled-function-p x))))
436    
437  (defun function-p (x)  ;(defun function-p (x)
438    (and (not (symbolp x)) (functionp x)))  ;  (and (not (symbolp x)) (functionp x)))
439    
440  (do ((l '((null . null)  (do ((l '((null . null)
441            (symbol . symbolp)            (symbol . symbolp)
442            (keyword . keywordp)            (keyword . keywordp)
443            (is-t . is-t-p)            (non-logical-pathname . non-logical-pathname-p)
444              (logical-pathname . logical-pathname-p)
445            (non-keyword-symbol . non-keyword-symbol-p)            (non-keyword-symbol . non-keyword-symbol-p)
446            (standard-char . standard-char-p)            (standard-char . standard-char-p)
447            (non-standard-base-char . non-standard-base-char-p)            (non-standard-base-char . non-standard-base-char-p)
           (extended-char . extended-char-p)  
448            (string-char . string-char-p);;FIXME            (string-char . string-char-p);;FIXME
449            (interpreted-function . interpreted-function-p)            (interpreted-function . interpreted-function-p)
450            (atom . atom)            (atom . atom)
# Line 470  Line 461 
461            (readtable . readtablep)            (readtable . readtablep)
462            (hash-table . hash-table-p)            (hash-table . hash-table-p)
463            (random-state . random-state-p)            (random-state . random-state-p)
464            (structure . si:structurep)            (structure . structurep)
465            (function . function-p)            (function . functionp)
466            (compiled-function . compiled-function-p)            (compiled-function . compiled-function-p)
467            (common . commonp)            (common . commonp)
468            )            )
469          (cdr l)))          (cdr l)))
470      ((endp l))      ((endp l))
471    (si:putprop (caar l) (cdar l) 'type-predicate)    (putprop (caar l) (cdar l) 'type-predicate)
472    (when (symbolp (cdar l))    (when (symbolp (cdar l))
473      (si:putprop (cdar l) (caar l) 'predicate-type)      (putprop (cdar l) (caar l) 'predicate-type)
474      (proclaim `(ftype (function (t) t) ,(cdar l)))))      (proclaim `(ftype (function (t) t) ,(cdar l)))))
475    
476    
477  (defconstant +singleton-types+ '(non-keyword-symbol keyword standard-char  (defconstant +singleton-types+ '(non-keyword-symbol keyword standard-char
478                                        non-standard-base-char extended-char                                        non-standard-base-char
479                                        package cons-member                                        package cons-member
480                                        broadcast-stream concatenated-stream echo-stream file-stream string-stream                                        broadcast-stream concatenated-stream echo-stream file-stream string-stream
481                                        synonym-stream two-way-stream                                        synonym-stream two-way-stream
482                                        pathname readtable hash-table random-state standard-object structure                                        non-logical-pathname logical-pathname
483                                          readtable hash-table random-state standard-object structure
484                                        interpreted-function                                        interpreted-function
485                                        compiled-function))                                        compiled-function))
486    
487    
488  (defconstant +range-types+ `(integer ratio short-float long-float))  (defconstant +range-types+ `(integer ratio short-float long-float))
489  (defconstant +array-types+ '(character bit signed-char unsigned-char signed-short unsigned-short  (defconstant +array-types+ '(nil character bit ;FIXME try to live with unsigned alone if can work out the C casting
490                                         fixnum short-float long-float t))                                         non-negative-char signed-char unsigned-char
491                                           non-negative-short signed-short unsigned-short
492                                           non-negative-fixnum fixnum
493                                           short-float long-float t))
494    
495  (defconstant +known-types+ (append +range-types+  (defconstant +known-types+ (append +range-types+
496                                     (mapcar (lambda (x) `(complex ,x)) +range-types+)                                     (mapcar (lambda (x) `(complex ,x)) +range-types+)
497                                     +singleton-types+                                     +singleton-types+
498                                     (mapcar (lambda (x) `(array ,x)) +array-types+)))                                     (mapcar (lambda (x) `(array ,x)) +array-types+)))
499    
500  (defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (si::string-concatenate "ARRAY-" (string x)))))  (defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "ARRAY-" (string x)))))
501                                          +array-types+))                                          +array-types+))
502  (defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (si::string-concatenate "COMPLEX-" (string x)))))  (defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "COMPLEX-" (string x)))))
503                                          +range-types+))                                          +range-types+))
504    
505  (defconstant +kindom-logic-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-op)) +range-types+)  (defconstant +kindom-logic-ops-alist+ `(,@(mapcar (lambda (x) `(,x . range-op)) +range-types+)
# Line 529  Line 524 
524                                           (standard-object . standard-load)                                           (standard-object . standard-load)
525                                           (structure . structure-load)                                           (structure . structure-load)
526                                           (array . array-load)                                           (array . array-load)
527                                           (simple-array . array-load)  ;                                        (simple-array . array-load)
528                                           ,@(mapcar (lambda (x) `(,x . single-load)) +singleton-types+)))                                           ,@(mapcar (lambda (x) `(,x . single-load)) +singleton-types+)))
529    
530    
# Line 612  Line 607 
607             (cond ((member (car zn) '(and or not)) (distribute-complex zn))             (cond ((member (car zn) '(and or not)) (distribute-complex zn))
608                   ((and (not (cddr type)) (eq z zn)) type)                   ((and (not (cddr type)) (eq z zn)) type)
609                   (`(,(car type) ,zn)))))                   (`(,(car type) ,zn)))))
610          ((member (car type) '(array simple-array))          ((eq (car type) 'array)
611           (let* ((tp (cadr type))           (let* ((tp (cadr type))
612                  (tpn (if (cdr type) (maybe-eval tp) '*))                  (tpn (if (cdr type) (maybe-eval tp) '*))
613                  (tpn (if ar (upgraded-array-element-type tpn) tpn))                  (tpn (if ar (upgraded-array-element-type tpn) tpn))
# Line 621  Line 616 
616                  (dmn (or dmn 0)))                  (dmn (or dmn 0)))
617             (if (and (not (cdddr type)) (eq tp tpn) (eq dm dmn)) type `(,(car type) ,tpn ,dmn))))             (if (and (not (cdddr type)) (eq tp tpn) (eq dm dmn)) type `(,(car type) ,tpn ,dmn))))
618          ((eq (car type) 'member) type)          ((eq (car type) 'member) type)
         ((and (not (cdr type)) (member (car type) +singleton-types+)) type)  
619          ((eq (car type) 'cons)          ((eq (car type) 'cons)
620           (let* ((def '(t))           (let* ((def '(t))
621                  (car (cadr type))                  (car (cadr type))
# Line 635  Line 629 
629             (if (and (not (cdddr type)) (eq car carn) (eq cdr cdrn)) type `(,(car type) ,carn ,cdrn))))             (if (and (not (cdddr type)) (eq car carn) (eq cdr cdrn)) type `(,(car type) ,carn ,cdrn))))
630          ((setq tem (coerce-to-standard-class (car type))) (if (eq (car type) tem) type `(,tem ,@(cdr type))))          ((setq tem (coerce-to-standard-class (car type))) (if (eq (car type) tem) type `(,tem ,@(cdr type))))
631          ((classp (car type)) (normalize-type-int `(,(class-name (car type)) ,@(cdr type)) ar))          ((classp (car type)) (normalize-type-int `(,(class-name (car type)) ,@(cdr type)) ar))
632            ((and (not (cdr type)) (member (car type) +singleton-types+)) type)
633          ((and (eq (car type) 'satisfies)          ((and (eq (car type) 'satisfies)
634                (setq tem (get (cadr type) 'predicate-type)))                (setq tem (get (cadr type) 'predicate-type)))
635           (normalize-type-int tem ar))           (normalize-type-int tem ar))
# Line 644  Line 639 
639                          (mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x))                          (mapcar (lambda (x) (if (and (consp x) (eq (car x) 'load-time-value)) (eval (cadr x)) x))
640                                  (cdr type))                                  (cdr type))
641                        (cdr type)))                        (cdr type)))
642                  (nt (and dt (apply dt rr))))                  (nt (and dt (or (apply dt rr) '(nil)))))
643             (when (and nt (not (equal type nt)))             (when (and nt (not (equal type nt)))
644               (normalize-type-int nt ar))))               (normalize-type-int nt ar))))
645          ((member (car type) '(and or not))          ((member (car type) '(and or not))
# Line 719  Line 714 
714             (funcall tem ntp type))             (funcall tem ntp type))
715            ((setq tem (coerce-to-standard-class (car type)))            ((setq tem (coerce-to-standard-class (car type)))
716             (ntp-ld ntp `(standard-object ,tem)))             (ntp-ld ntp `(standard-object ,tem)))
717            ((and (symbolp (car type)) (setq tem (get (car type) 'si::s-data)))            ((and (symbolp (car type)) (setq tem (get (car type) 's-data)))
718             (ntp-ld ntp `(structure ,tem)))             (ntp-ld ntp `(structure ,tem)))
719            ((eq (car type) 'member)            ((eq (car type) 'member)
720             (let ((els (cdr type)))             (let ((els (cdr type)))
# Line 897  Line 892 
892  (defun array-load (ntp type)  (defun array-load (ntp type)
893    (let* ((z (if (eq (cadr type) 'string-char) 'character (cadr type)));FIXME    (let* ((z (if (eq (cadr type) 'string-char) 'character (cadr type)));FIXME
894           (z (if (eq z '*) z (car (member z +array-types+)))))           (z (if (eq z '*) z (car (member z +array-types+)))))
895      (unless z (error "Bad array type ~a~%" (cadr type)))      (unless (or z (not (cadr type))) (error "Bad array type ~a~%" (cadr type)))
896      (let* ((dim (caddr type))      (let* ((dim (caddr type))
897             (dim (cond ((eq dim '*) t)             (dim (cond ((eq dim '*) t)
898                        ((integerp dim) (if (= 0 dim) dim (make-list dim :initial-element t)))                        ((integerp dim) (if (= 0 dim) dim (make-list dim :initial-element t)))
899                        ((listp dim) (substitute t '* dim))))) ;FIXME consing                        ((listp dim) (substitute t '* dim))))) ;FIXME consing
900        (if (eq z '*)        (if (eq z '*)
901            (dolist (l +array-type-alist+)            (dolist (l +array-type-alist+)
902              (ntp-ld ntp `(,(cdr l) ,dim)))              (ntp-ld ntp `(,(cdr l) ,(when z dim))))
903          (ntp-ld ntp `(,(cdr (assoc z +array-type-alist+)) ,dim))))))          (ntp-ld ntp `(,(cdr (assoc z +array-type-alist+)) ,dim))))))
904      
905  (defun array-atm (x)  (defun array-atm (x)
906    (cond ((atom x))    (cond ((atom x))
907          ((eq (car x) 'not) (array-atm (cadr x)))          ((eq (car x) 'not) (array-atm (cadr x)))
# Line 964  Line 959 
959                ((and or) (sigalg-op op (cadr x) (cadr y) 'structure^ 'structure-atm))                ((and or) (sigalg-op op (cadr x) (cadr y) 'structure^ 'structure-atm))
960                (not (negate (cadr x))))))                (not (negate (cadr x))))))
961    
962  (defun structure-recon (x) (single-recon x))  (defun structure-recon (x) (cadr x))
963    
964  ;; STANDARD-OBJECTS  ;; STANDARD-OBJECTS
965    
# Line 984  Line 979 
979             (when q `(member ,@q))))             (when q `(member ,@q))))
980          ((and (consp y) (eq (car y) 'member)) (standard^ y x))          ((and (consp y) (eq (car y) 'member)) (standard^ y x))
981          ((member y (class-precedence-list x)) x)          ((member y (class-precedence-list x)) x)
982          ((member x (class-precedence-list y)) y)))          ((member x (class-precedence-list y)) y)
983            ((reduce (lambda (&rest xy) (when xy (standard^ (car xy) (cadr xy))))
984                     (intersection (class-direct-subclasses x) (class-direct-subclasses y) :test 'eq)))))
985    ;       ((reduce (lambda (&rest xy) (when xy (standard^ (car xy) (cadr xy))))
986    ;                (intersection (class-direct-subclasses x) (class-direct-subclasses y)
987    ;                                :test 'standard^)))))
988    
989  (defun standard-op (op x y)  (defun standard-op (op x y)
990    (setf (cadr x)    (setf (cadr x)
# Line 992  Line 992 
992                ((and or) (sigalg-op op (cadr x) (cadr y) 'standard^ 'standard-atm))                ((and or) (sigalg-op op (cadr x) (cadr y) 'standard^ 'standard-atm))
993                (not (negate (cadr x))))))                (not (negate (cadr x))))))
994    
995  (defun standard-recon (x) (single-recon x))  (defun standard-recon (x) (cadr x))
996    
997  ;; CONS  ;; CONS
998    
# Line 1053  Line 1053 
1053    (cond ((eq t (cadr x)) `(cons t t))    (cond ((eq t (cadr x)) `(cons t t))
1054          ((atom (cadr x)) nil)          ((atom (cadr x)) nil)
1055          ((cons-atm (cadr x))          ((cons-atm (cadr x))
1056           (let ((car (nreconstruct-type (caadr x)))           (let ((car (nreconstruct-type-int (caadr x)))
1057                 (cdr (nreconstruct-type (cdadr x))))                 (cdr (nreconstruct-type-int (cdadr x))))
1058             (and car cdr `(cons ,car ,cdr))))             (and car cdr `(cons ,car ,cdr))))
1059          ((eq (caadr x) 'or)          ((eq (caadr x) 'or)
1060           (let ((z (lremove-if 'not (mapcar (lambda (x) (cons-recon `(cons ,x))) (cdadr x)))))           (let ((z (lremove-if 'not (mapcar (lambda (x) (cons-recon `(cons ,x))) (cdadr x)))))
# Line 1178  Line 1178 
1178        
1179    
1180    
1181  (defun nreconstruct-type (x)  (defun nreconstruct-type-int (x)
1182    (if (ntp-ukn x) t    (if (ntp-ukn x) t
1183      (if (ntp-def x)      (if (ntp-def x)
1184          (let ((z (nreconstruct-type (ntp-not x))))          (let ((z (nreconstruct-type-int (ntp-not x))))
1185            (or (not z) `(not ,z)))            (or (not z) `(not ,z)))
1186        (let ((z (lremove-if        (let ((z (lremove-if
1187                  'not                  'not
# Line 1190  Line 1190 
1190                              (funcall op x))) (ntp-tps x)))))                              (funcall op x))) (ntp-tps x)))))
1191          (if (cdr z) `(or ,@z) (car z))))))          (if (cdr z) `(or ,@z) (car z))))))
1192    
1193    (defun nreconstruct-type (x)
1194      (list (nreconstruct-type-int x) (ntp-ukn x)))
1195    
1196    
1197  ;; CLASS HACKS  ;; CLASS HACKS
# Line 1200  Line 1202 
1202  (defun class-precedence-list (object) (declare (ignore object)) nil)  (defun class-precedence-list (object) (declare (ignore object)) nil)
1203  (defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil)  (defun find-class (object &optional errorp environment) (declare (ignore object errorp environment))nil)
1204  (defun class-name (class) (declare (ignore class)) nil)  (defun class-name (class) (declare (ignore class)) nil)
1205    (defun class-of (object) (declare (ignore object)) nil)
1206    (defun class-direct-subclasses (object) (declare (ignore object)) nil)
1207    
1208  (defun is-standard-class-symbol (sym)  (defun is-standard-class-symbol (sym)
1209    (let* ((z (get sym 'deftype-definition))    (let* ((z (get sym 'deftype-definition))

Legend:
Removed from v.1.21  
changed lines
  Added in v.1.22

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26