/[gcl]/gcl/cmpnew/gcl_cmptype.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmptype.lsp

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

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
1    ;;; CMPTYPE  Type information.
2    ;;;
3    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4    
5    ;; This file is part of GNU Common Lisp, herein referred to as GCL
6    ;;
7    ;; GCL is free software; you can redistribute it and/or modify it under
8    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9    ;; the Free Software Foundation; either version 2, or (at your option)
10    ;; any later version.
11    ;;
12    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
13    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
15    ;; License for more details.
16    ;;
17    ;; You should have received a copy of the GNU Library General Public License
18    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
19    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20    
21    
22    (in-package 'compiler)
23    
24    ;;; CL-TYPE is any valid type specification of Common Lisp.
25    ;;;
26    ;;; TYPE is a representation type used by KCL.  TYPE is one of:
27    ;;;
28    ;;;                             T(BOOLEAN)
29    ;;;
30    ;;;     FIXNUM  CHARACTER  SHORT-FLOAT  LONG-FLOAT
31    ;;;     (VECTOR T)  STRING  BIT-VECTOR  (VECTOR FIXNUM)
32    ;;;     (VECTOR SHORT-FLOAT)  (VECTOR LONG-FLOAT)
33    ;;;     (ARRAY T)  (ARRAY STRING-CHAR)  (ARRAY BIT)
34    ;;;     (ARRAY FIXNUM)
35    ;;;     (ARRAY SHORT-FLOAT)  (ARRAY LONG-FLOAT)
36    ;;;     UNKNOWN
37    ;;;
38    ;;;                             NIL
39    ;;;
40    ;;;
41    ;;; immediate-type:
42    ;;;     FIXNUM          int
43    ;;;     CHARACTER       char
44    ;;;     SHORT-FLOAT     float
45    ;;;     LONG-FLOAT      double
46    
47    
48    ;;; Check if THING is an object of the type TYPE.
49    ;;; Depends on the implementation of TYPE-OF.
50    (defun object-type (thing)
51      (let ((type (type-of thing)))
52        (case type
53          ((fixnum short-float long-float) type)
54          ((string-char standard-char character) 'character)
55          ((string bit-vector) type)
56          (vector (list 'vector (array-element-type thing)))
57          (array (list 'array (array-element-type thing)))
58          (t t))))   ;   'unknown ;; I can't see any use of this
59    
60    (defun type-filter (type)
61      (case type
62            ((fixnum character short-float long-float) type)
63            (single-float 'long-float)
64            (boolean 'boolean)
65            (double-float 'long-float)
66            ((simple-string string) 'string)
67            ((simple-bit-vector bit-vector) 'bit-vector)
68            ((nil t) t)
69            (t (let ((type (si::normalize-type type)) element-type)
70                 (case (car type)
71                   ((simple-array array)
72                    (cond ((or (endp (cdr type))
73                               (not (setq element-type
74                                          (cond ((eq '*  (cadr type)) nil)
75                                                ((si::best-array-element-type
76                                                   (cadr type)))
77                                                (t t)))))
78                           t)       ; I don't know.
79                          ((and (not (endp (cddr type)))
80                                (not (eq (caddr type) '*))
81                                (or (eql (caddr type) 1)
82                                    (and (consp (caddr type))
83                                         (= (length (caddr type)) 1))))
84                           (case element-type
85                             (string-char 'string)
86                             (bit 'bit-vector)
87                             (t (list 'vector element-type))))
88                          (t (list 'array element-type))))
89                   (integer
90                    (if (si::sub-interval-p (cdr type)
91                                            (list most-negative-fixnum
92                                                  most-positive-fixnum))
93                        'fixnum
94                        'integer))
95                   ((short-float) 'short-float)
96                   ((long-float double-float single-float) 'long-float)
97                   ((stream) 'stream)
98                   (t (cond ((subtypep type 'fixnum) 'fixnum)
99                            ((subtypep type 'integer) 'integer)
100                            ((subtypep type 'character) 'character)
101                            ((subtypep type 'short-float) 'short-float)
102                            ((subtypep type 'long-float) 'long-float)
103                            ((subtypep type '(vector t)) '(vector t))
104                            ((subtypep type 'string) 'string)
105                            ((subtypep type 'bit-vector) 'bit-vector)
106                            ((subtypep type '(vector fixnum)) '(vector fixnum))
107                            ((subtypep type '(vector short-float))
108                             '(vector short-float))
109                            ((subtypep type '(vector long-float))
110                             '(vector long-float))
111                            ((subtypep type '(array t)) '(array t))
112                            ((subtypep type '(array string-char))
113                             '(array string-char))
114                            ((subtypep type '(array bit)) '(array bit))
115                            ((subtypep type '(array fixnum)) '(array fixnum))
116                            ((subtypep type '(array short-float))
117                             '(array short-float))
118                            ((subtypep type '(array long-float))
119                             '(array long-float))
120                            ((eq (car type) 'values)
121                             (if  (null (cddr type))
122                                 (list 'values (type-filter (second type)))
123                               t))
124                            ((and (eq (car type) 'satisfies)
125                                (symbolp (second type))
126                                (get (second type) 'type-filter)))
127                            (t t)))
128                   )))))
129    
130    
131    
132    (defun type-and (type1 type2)
133      
134      (cond ((equal type1 type2) type1)
135            ((eq type1 t) type2)
136            ((eq type1 '*) type2)
137            ((eq type1 'object) type2)
138            ((eq type2 'object) type1)
139            ((eq type2 t) type1)
140            ((eq type2 '*) type1)
141            ((and (consp type2) (eq (car type2) 'values))
142             (type-and type1 (second type2)))
143            ((consp type1)
144             (case (car type1)
145                   (array
146                    (case (cadr type1)
147                          (string-char (if (eq type2 'string) type2 nil))
148                          (bit (if (eq type2 'bit-vector) type2 nil))
149                          (t (if (and (consp type2)
150                                      (eq (car type2) 'vector)
151                                      (eq (cadr type1) (cadr type2)))
152                                 type2 nil))))
153                   (vector
154                    (if (and (consp type2) (eq (car type2) 'array)
155                             (eq (cadr type1) (cadr type2)))
156                        type1 nil))
157                   (values (type-and (second type1) type2))
158                   (t nil)))
159            (t (case type1
160                     (string
161                      (if (and (consp type2) (eq (car type2) 'array)
162                               (eq (cadr type2) 'string-char))
163                          type1 nil))
164                     (bit-vector
165                      (if (and (consp type2) (eq (car type2) 'array)
166                               (eq (cadr type2) 'bit))
167                          type1 nil))
168                     (fixnum-float
169                      (if (member type2 '(fixnum float short-float long-float))
170                          type2 nil))
171                     (float
172                      (if (member type2 '(short-float long-float))
173                          type2 nil))
174                     ((long-float short-float)
175                      (if (member type2 '(fixnum-float float))
176                          type1 nil))
177                     ((signed-char unsigned-char signed-short)
178                      (if (eq type2 'fixnum) type1 nil))
179                     ((unsigned-short)
180                      (if (subtypep type1 type2) type1 nil))
181                     (integer
182                      (case type2
183                        (fixnum type2)))
184                     (fixnum
185                       (case type2
186                         ((integer fixnum-float) 'fixnum)
187                         ((signed-char unsigned-char signed-short bit)
188                          type2)
189                         ((unsigned-short)
190                          (if (subtypep type2 type1) type2 nil))))
191                     ))))
192    
193    (defun type>= (type1 type2)
194      (equal (type-and type1 type2) type2))
195    
196    (defun reset-info-type (info)
197      (if (info-type info)
198          (let ((info1 (copy-info info)))
199               (setf (info-type info1) t)
200               info1)
201          info))
202    
203    (defun and-form-type (type form original-form &aux type1)
204      (setq type1 (type-and type (info-type (cadr form))))
205      (when (null type1)
206            (cmpwarn "The type of the form ~s is not ~s." original-form type))
207      (if (eq type1 (info-type (cadr form)))
208          form
209          (let ((info (copy-info (cadr form))))
210               (setf (info-type info) type1)
211               (list* (car form) info (cddr form)))))
212    
213    (defun check-form-type (type form original-form)
214      (when (null (type-and type (info-type (cadr form))))
215            (cmpwarn "The type of the form ~s is not ~s." original-form type)))
216    
217    (defun default-init (type)
218      (case type
219            (fixnum (cmpwarn "The default value of NIL is not FIXNUM."))
220            (character (cmpwarn "The default value of NIL is not CHARACTER."))
221            (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT."))
222            (short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT."))
223            (integer (cmpwarn "The default value of NIL is not INTEGER"))
224            
225            )
226      (c1nil))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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