/[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.22 by camm, Wed Sep 7 02:49:59 2005 UTC revision 1.23 by camm, Sun Sep 18 02:04:16 2005 UTC
# Line 80  Line 80 
80      (boolean (or (eq object 't) (eq object 'nil)))      (boolean (or (eq object 't) (eq object 'nil)))
81      (bignum (member (type-of-c object) '(bignum non-negative-bignum negative-bignum)))      (bignum (member (type-of-c object) '(bignum non-negative-bignum negative-bignum)))
82      (ratio (eq (type-of-c object) 'ratio))      (ratio (eq (type-of-c object) 'ratio))
83      ((base-char string-char)      ((base-char) (characterp object))
      (and (characterp object) (string-char-p object)))  
84      (integer      (integer
85       (and (integerp object) (in-interval-p object i)))       (and (integerp object) (in-interval-p object i)))
86      (rational      (rational
# Line 185  Line 184 
184                (match-dimensions (cdr dim) (cdr pat))))))                (match-dimensions (cdr dim) (cdr pat))))))
185    
186    
187    (defun subtypep1 (t1 t2)
188      (or (not t1) (eq t2 t)
189          (not (car (resolve-type `(and ,t1 ,(negate t2)))))))
190    
191  (defun subtypep (t1 t2 &optional env)  (defun subtypep (t1 t2 &optional env)
192    (declare (ignore env) (optimize (safety 1)))    (declare (ignore env) (optimize (safety 1)))
# Line 320  Line 320 
320  (deftype unsigned-short ()`(unsigned-byte ,short-length))  (deftype unsigned-short ()`(unsigned-byte ,short-length))
321  (deftype short ()`(signed-short))  (deftype short ()`(signed-short))
322    
323    (deftype non-negative-int () `(non-negative-byte ,int-length))
324    (deftype negative-int () `(negative-byte ,int-length))
325    (deftype signed-int ()`(signed-byte ,int-length))
326    (deftype unsigned-int ()`(unsigned-byte ,int-length))
327    (deftype int ()`(signed-int))
328    
329  (deftype non-negative-fixnum () `(non-negative-byte ,fixnum-length))  (deftype non-negative-fixnum () `(non-negative-byte ,fixnum-length))
330  (deftype negative-fixnum () `(negative-byte ,fixnum-length))  (deftype negative-fixnum () `(negative-byte ,fixnum-length))
331  (deftype signed-fixnum ()`(signed-byte ,fixnum-length))  (deftype signed-fixnum ()`(signed-byte ,fixnum-length))
# Line 336  Line 342 
342  (deftype vector (&optional element-type size)  (deftype vector (&optional element-type size)
343    `(array ,element-type (,size)))    `(array ,element-type (,size)))
344  (deftype string (&optional size)  (deftype string (&optional size)
345    `(array string-char (,size)))    `(array character (,size)))
346  (deftype base-string (&optional size)  (deftype base-string (&optional size)
347    `(array base-char (,size)))    `(array base-char (,size)))
348  (deftype bit-vector (&optional size)  (deftype bit-vector (&optional size)
# Line 345  Line 351 
351  (deftype simple-vector (&optional size)  (deftype simple-vector (&optional size)
352    `(array t (,size)))    `(array t (,size)))
353  (deftype simple-string (&optional size)  (deftype simple-string (&optional size)
354    `(array string-char (,size)))    `(array character (,size)))
355  (deftype simple-base-string (&optional size)  (deftype simple-base-string (&optional size)
356    `(array base-char (,size)))    `(array base-char (,size)))
357  (deftype simple-bit-vector (&optional size)  (deftype simple-bit-vector (&optional size)
# Line 363  Line 369 
369  (deftype extended-char () nil)  (deftype extended-char () nil)
370  (deftype base-char () `(or standard-char non-standard-base-char))  (deftype base-char () `(or standard-char non-standard-base-char))
371  (deftype character () `(or base-char extended-char))  (deftype character () `(or base-char extended-char))
 (deftype string-char () `character)  
372    
373  (deftype stream () `(or broadcast-stream concatenated-stream echo-stream  (deftype stream () `(or broadcast-stream concatenated-stream echo-stream
374                          file-stream string-stream synonym-stream two-way-stream))                          file-stream string-stream synonym-stream two-way-stream))
# Line 445  Line 450 
450            (non-keyword-symbol . non-keyword-symbol-p)            (non-keyword-symbol . non-keyword-symbol-p)
451            (standard-char . standard-char-p)            (standard-char . standard-char-p)
452            (non-standard-base-char . non-standard-base-char-p)            (non-standard-base-char . non-standard-base-char-p)
           (string-char . string-char-p);;FIXME  
453            (interpreted-function . interpreted-function-p)            (interpreted-function . interpreted-function-p)
454            (atom . atom)            (atom . atom)
455            (cons . consp)            (cons . consp)
# Line 486  Line 490 
490    
491    
492  (defconstant +range-types+ `(integer ratio short-float long-float))  (defconstant +range-types+ `(integer ratio short-float long-float))
493  (defconstant +array-types+ '(nil character bit ;FIXME try to live with unsigned alone if can work out the C casting  
494                                         non-negative-char signed-char unsigned-char  (defconstant +array-types+ (si::aelttype-list))
495                                         non-negative-short signed-short unsigned-short  (defconstant +array-types-with-nil-for-ansi+ (append '(nil) +array-types+))
                                        non-negative-fixnum fixnum  
                                        short-float long-float t))  
496    
497  (defconstant +known-types+ (append +range-types+  (defconstant +known-types+ (append +range-types+
498                                     (mapcar (lambda (x) `(complex ,x)) +range-types+)                                     (mapcar (lambda (x) `(complex ,x)) +range-types+)
499                                     +singleton-types+                                     +singleton-types+
500                                     (mapcar (lambda (x) `(array ,x)) +array-types+)))                                     (mapcar (lambda (x) `(array ,x)) +array-types-with-nil-for-ansi+)))
501    
502  (defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "ARRAY-" (string x)))))  (defconstant +array-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "ARRAY-" (string x)))))
503                                          +array-types+))                                          +array-types-with-nil-for-ansi+))
504  (defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "COMPLEX-" (string x)))))  (defconstant +complex-type-alist+ (mapcar (lambda (x) (cons x (intern (string-concatenate "COMPLEX-" (string x)))))
505                                          +range-types+))                                          +range-types+))
506    
# Line 792  Line 794 
794    
795  (defun elgt (x y)  (defun elgt (x y)
796    (cond ((or (eq (car x) '*) (eq (cdr y) '*)) nil)    (cond ((or (eq (car x) '*) (eq (cdr y) '*)) nil)
797            ((and (integerp (car x)) (integerp (cdr y))) (> (car x) (1+ (cdr y))))
798            ((and (integerp (range-num (car x)))
799                  (integerp (range-num (cdr y)))) (>= (range-num (car x)) (1+ (range-num (cdr y)))))
800          ((and (numberp (car x)) (numberp (cdr y))) (> (car x) (cdr y)))          ((and (numberp (car x)) (numberp (cdr y))) (> (car x) (cdr y)))
801          ((>= (range-num (car x)) (range-num (cdr y))))))          ((>= (range-num (car x)) (range-num (cdr y))))))
802    
# Line 890  Line 895 
895  ;; ARRAY TYPES  ;; ARRAY TYPES
896    
897  (defun array-load (ntp type)  (defun array-load (ntp type)
898    (let* ((z (if (eq (cadr type) 'string-char) 'character (cadr type)));FIXME    (let* ((z (cadr type))
899           (z (if (eq z '*) z (car (member z +array-types+)))))           (z (if (eq z '*) z (car (member z +array-types-with-nil-for-ansi+)))))
900      (unless (or z (not (cadr type))) (error "Bad array type ~a~%" (cadr type)))      (unless (or z (not (cadr type))) (error "Bad array type ~a~%" (cadr type)))
901      (let* ((dim (caddr type))      (let* ((dim (caddr type))
902             (dim (cond ((eq dim '*) t)             (dim (cond ((eq dim '*) t)
# Line 934  Line 939 
939                (not (negate (cadr x))))))                (not (negate (cadr x))))))
940    
941  (defun array-recon (x)  (defun array-recon (x)
942    `(array ,(car (rassoc (car x) +array-type-alist+)) ,(cadr x)))    `(array ,(car (rassoc (car x) +array-type-alist+)) ,(cond ((eq (cadr x) t) '*) ((atom (cadr x)) (cadr x)) ((mapcar (lambda (x) (if (eq x t) '* x)) (cadr x))))))
943    
944  ;; STRUCTURES  ;; STRUCTURES
945    

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

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