/[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.10 by camm, Thu Sep 16 21:16:47 2004 UTC revision 1.11 by camm, Fri Jan 7 17:58:34 2005 UTC
# Line 24  Line 24 
24    
25  (in-package 'system)  (in-package 'system)
26    
27  (export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce) 'lisp)  (export '(lisp::deftype lisp::typep lisp::subtypep lisp::coerce lisp::upgraded-array-element-type) 'lisp)
28    
29  (eval-when (compile)  (eval-when (compile)
30  (proclaim '(optimize (safety 2) (space 3)))  (proclaim '(optimize (safety 2) (space 3)))
# Line 53  Line 53 
53                            '(deftype ,name ,lambda-list ,@body)                            '(deftype ,name ,lambda-list ,@body)
54                            'deftype-form)                            'deftype-form)
55                (si:putprop ',name                (si:putprop ',name
56                            #'(lambda ,lambda-list ,@body)                            (if (null ',lambda-list)
57                                  (let ((tem (progn ,@body)))
58                                    (lambda ,lambda-list tem))
59                                (lambda ,lambda-list ,@body))
60                            'deftype-definition)                            'deftype-definition)
61                (si:putprop ',name                (si:putprop ',name
62                            ,(find-documentation body)                            ,(find-documentation body)
# Line 62  Line 65 
65    
66    
67  ;;; Some DEFTYPE definitions.  ;;; Some DEFTYPE definitions.
68  (deftype fixnum ()  ;(deftype fixnum ()
69    `(integer ,most-negative-fixnum ,most-positive-fixnum))  ;  `(integer ,most-negative-fixnum ,most-positive-fixnum))
70  (deftype positive-fixnum ()  (deftype seqind ()
71    `(integer 0 ,most-positive-fixnum))    `(integer 0 ,array-dimension-limit))
72  (deftype fixnum ()  (deftype rnkind ()
73    `(integer ,most-negative-fixnum ,most-positive-fixnum))    `(integer 0 ,array-rank-limit))
74    ;(deftype non-negative-fixnum ()
75    ;  `(integer 0 ,most-positive-fixnum))
76    ;(deftype negative-fixnum ()
77    ;  `(integer ,most-negative-fixnum -1))
78    ;(deftype fixnum ()
79    ;  `(integer ,most-negative-fixnum ,most-positive-fixnum))
80  (deftype bit () '(integer 0 1))  (deftype bit () '(integer 0 1))
81  (deftype mod (n)  (deftype mod (n)
82    `(integer 0 ,(1- n)))    `(integer 0 ,(1- n)))
83  (deftype positive-byte (&optional s)  (deftype non-negative-byte (&optional s)
84    (if (eq s '*)    (if (eq s '*)
85        `(integer * *)        `(integer * *)
86        `(integer 0 ,(1- (expt 2 (1- s))))))        `(integer 0 ,(1- (expt 2 (1- s))))))
87    (deftype negative-byte (&optional s)
88      (if (eq s '*)
89          `(integer * *)
90          `(integer ,(- (expt 2 (1- s))) -1)))
91  (deftype signed-byte (&optional s)  (deftype signed-byte (&optional s)
92    (if (eq s '*)    (if (eq s '*)
93        `(integer * *)        `(integer * *)
# Line 83  Line 96 
96    (if (eq s '*)    (if (eq s '*)
97        `(integer 0 *)        `(integer 0 *)
98        `(integer 0 ,(1- (expt 2 s)))))        `(integer 0 ,(1- (expt 2 s)))))
 (deftype positive-char () `(positive-byte ,char-size))  
 (deftype signed-char ()`(signed-byte ,char-size))  
 (deftype unsigned-char ()`(unsigned-byte ,char-size))  
 (deftype positive-short () `(positive-byte ,short-size))  
 (deftype signed-short ()`(signed-byte ,short-size))  
 (deftype unsigned-short ()`(unsigned-byte ,short-size))  
99    
100    (deftype non-negative-char () `(non-negative-byte ,char-length))
101    (deftype negative-char () `(negative-byte ,char-length))
102    (deftype signed-char ()`(signed-byte ,char-length))
103    (deftype unsigned-char ()`(unsigned-byte ,char-length))
104    (deftype char ()`(signed-char))
105    
106    (deftype non-negative-short () `(non-negative-byte ,short-length))
107    (deftype negative-short () `(negative-byte ,short-length))
108    (deftype signed-short ()`(signed-byte ,short-length))
109    (deftype unsigned-short ()`(unsigned-byte ,short-length))
110    (deftype short ()`(signed-short))
111    
112    (deftype non-negative-fixnum () `(non-negative-byte ,fixnum-length))
113    (deftype negative-fixnum () `(negative-byte ,fixnum-length))
114    (deftype signed-fixnum ()`(signed-byte ,fixnum-length))
115    (deftype unsigned-fixnum ()`(unsigned-byte ,fixnum-length))
116    (deftype fixnum ()`(signed-fixnum))
117    
118    (deftype non-negative-lfixnum () `(non-negative-byte ,lfixnum-length))
119    (deftype negative-lfixnum () `(negative-byte ,lfixnum-length))
120    (deftype signed-lfixnum ()`(signed-byte ,lfixnum-length))
121    (deftype unsigned-lfixnum ()`(unsigned-byte ,lfixnum-length))
122    (deftype lfixnum ()`(signed-lfixnum))
123    
124    
125  (deftype vector (&optional element-type size)  (deftype vector (&optional element-type size)
# Line 298  Line 328 
328    
329  ;;; KNOWN-TYPE-P answers if the given type is a known base type.  ;;; KNOWN-TYPE-P answers if the given type is a known base type.
330  ;;; The type may not be normalized.  ;;; The type may not be normalized.
331    
332    ;;FIXME -- get rid of this list.  And those in subtypep.  CM 20050106
333  (defun known-type-p (type)  (defun known-type-p (type)
334    (when (consp type) (setq type (car type)))    (when (consp type) (setq type (car type)))
335    (if (or (equal (string type) "ERROR")    (if (or (equal (string type) "ERROR")
336            (member type            (member type
337                    '(t nil boolean null symbol keyword atom cons list sequence                    '(t nil boolean null symbol keyword atom cons list sequence
338                        positive-char negative-char signed-char unsigned-char                        non-negative-char negative-char signed-char unsigned-char
339                        positive-short negative-short signed-short unsigned-short                        non-negative-short negative-short signed-short unsigned-short
340                        positive-fixnum negative-fixnum                        non-negative-fixnum negative-fixnum
341                        number integer bignum rational ratio float method-combination                        number integer bignum rational ratio float method-combination
342                        short-float single-float double-float long-float complex                        short-float single-float double-float long-float complex
343                        character standard-char string-char real                        character standard-char string-char real
# Line 338  Line 370 
370          ((let ((a (car a))) (or (eq a '*) (eq a t)))          ((let ((a (car a))) (or (eq a '*) (eq a t)))
371           (implicit-symbol (cdr a) b))))           (implicit-symbol (cdr a) b))))
372    
373    (defun upgraded-array-element-type (type &optional environment)
374      (declare (ignore environment))
375      (best-array-element-type type))
376    
377  ;;; SUBTYPEP predicate.  ;;; SUBTYPEP predicate.
378  (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)  (defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)
379    (declare (ignore env))    (declare (ignore env))
# Line 668  Line 704 
704                         (let* ((at1 (ty i1))                         (let* ((at1 (ty i1))
705                                (at2 (ty i2))                                (at2 (ty i2))
706                                (at2 (or (and (eq at2 'string-char) 'character) at2)))                                (at2 (or (and (eq at2 'string-char) 'character) at2)))
707                           (unless (equal at1 at2)                           (unless (eq (upgraded-array-element-type at1) (upgraded-array-element-type at2))
708                             (return-from subtypep (values nil t))))                             (return-from subtypep (values nil t))))
709                         (let ((ad1 (di i1))                         (let ((ad1 (di i1))
710                               (ad2 (di i2)))                               (ad2 (di i2)))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

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