← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to comp/comptype.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
comp/comptype.lsp
 
1
(in-package "BCOMP")
 
2
 
 
3
 
 
4
(defvar *immediate-types*
 
5
  '(fixnum character short-float double-float boolean))
 
6
 
 
7
(dolist (v
 
8
         '((t   array                           package         
 
9
                atom            float           pathname        
 
10
                bignum          function        random-state    
 
11
                hash-table      ratio           single-float
 
12
                rational        standard-char
 
13
                keyword         readtable       stream
 
14
                common          list            sequence        
 
15
                compiled-function               
 
16
                complex         nil             signed-byte     symbol
 
17
                cons            null            unsigned-byte   t
 
18
                number          simple-array    vector
 
19
                )
 
20
           (bit bit)
 
21
           (integer integer)
 
22
           (double-float long-float single-float)
 
23
           (character string-char)
 
24
           ((vector character) string simple-string)
 
25
           ((vector bit) bit-vector  simple-bit-vector)
 
26
           ((vector t) simple-vector)
 
27
           (stream stream)
 
28
           (dynamic-extent dynamic-extent )
 
29
           (fix-or-sf-or-df fix-or-sf-or-df)
 
30
           ))
 
31
  (dolist (w (cdr v))
 
32
    (setf (get w 'comp-type) (car v))))
 
33
(dolist (v *immediate-types*) (setf (get v 'comp-type) v))
 
34
 
 
35
(deftype fix-or-sf-or-df nil '(or fixnum short-float double-float))
 
36
(deftype boolean nil t)
 
37
(proclaim '(declaration dynamic-extent))
 
38
;(deftype dynamic-extent nil t)
 
39
 
 
40
(defun grab-1-decl (x decls &aux type l tem place)
 
41
  (tagbody
 
42
   (go begin)
 
43
   ERROR
 
44
   (comp-warn "bad declaration ~a" x)
 
45
   (return-from grab-1-decl decls)
 
46
   BEGIN
 
47
  (or (consp x) (go error))
 
48
  (setq type  (car x) l (cdr x))
 
49
  (or (null l) (consp l) (go error))
 
50
  (unless
 
51
   (symbolp type)
 
52
   (comp-warn "bad declaration ~a" x)
 
53
   (return-from grab-1-decl decls)
 
54
   )
 
55
  (cond ((or (setq tem (get type 'comp-type))
 
56
             (and (eq type 'type)
 
57
                  (consp l)
 
58
                  (setq tem (comp-type (car l)))
 
59
                  (setq l (cdr l))))
 
60
         (unless (eq t (setq tem (comp-type tem)))
 
61
                 (or decls (setq decls (list nil)))
 
62
                 (dolist-safe (v l)
 
63
                   (or (symbolp v) (go error))
 
64
                   (push (cons v tem) (car decls)))))
 
65
        ((eq type 'special)
 
66
         (cond ((null decls) (setq decls (list nil nil)))
 
67
               ((null (cdr decls))
 
68
                (setf (cdr decls) (list nil))))
 
69
         (setq place (cdr decls))
 
70
         (dolist-safe (v l)
 
71
           (or (symbolp v) (go error))
 
72
           (push v  (car place))
 
73
           ))
 
74
        ((or (eq type 'inline)
 
75
             (eq type 'not-inline)
 
76
             (and (eq type 'ftype)
 
77
                  (progn (desetq (type . l) l) t)))
 
78
         (dolist-safe (v l) (push
 
79
                             (cons v (increment-function-decl
 
80
                                      type (function-declaration v)))
 
81
                             *function-decls*)))
 
82
        (t nil)))
 
83
  ; (((v1 . type1) (v2 . type2) ..)(special-var1 special-var2 ..))
 
84
  decls)
 
85
           
 
86
(defun best-array-element-type (type)
 
87
  (cond ((or (eql t type) (null type)) t)
 
88
        ((memq type '(bit unsigned-char signed-char
 
89
                                    unsigned-short
 
90
                                    signed-short fixnum
 
91
                                    character
 
92
                                    ))
 
93
               type)
 
94
        ((subtypep type 'fixnum)
 
95
         (dolist (v '(bit unsigned-char signed-char
 
96
                                    unsigned-short
 
97
                                    signed-short)
 
98
                    'fixnum)
 
99
                 (cond ((subtypep type v)
 
100
                        (return v)))))
 
101
        ((eql type 'string-char) 'character)
 
102
        (t (or (dolist (v '(string-char bit short-float
 
103
                                    long-float))
 
104
                   (cond ((subtypep type v)
 
105
                          (return v))))
 
106
               t))))
 
107
 
 
108
(deftype type-of (x)
 
109
  (cond (*in-pass-1*
 
110
         (let ((tem (b1-walk x 'type-of)))
 
111
           (result-type tem)))
 
112
        (t t)))
 
113
 
 
114
(defun assure-list (x)
 
115
  (loop
 
116
   (if (null x) (return t))
 
117
   (if (consp x) (setq x (cdr x))
 
118
     (error "expected a list ~a" x))))
 
119
 
 
120
(deftype struct (x) 'structure)
 
121
(defun comp-type (type &aux tem element-type sizes)
 
122
;; coerce type to ones understood by compiler  
 
123
  (cond ;((member type *immediate-types*)
 
124
         ;(return-from comp-type type))
 
125
        ((and (symbolp type)
 
126
              (setq tem (get type 'comp-type)))
 
127
         (return-from comp-type tem))
 
128
        ((and(symbolp type)
 
129
             (setq tem (get type 'si::deftype-definition)))
 
130
         (comp-type (funcall tem)))
 
131
        ((consp type)
 
132
         (cond
 
133
          ((eq (car type) 'struct)
 
134
                (list 'struct (best-array-element-type (cadr type))))
 
135
          ((progn               (setq type (si::normalize-type type)) nil))
 
136
          ((member (car type) '(array simple-array vector simple-vector))
 
137
           (when (consp (cdr type))
 
138
             (setq element-type (best-array-element-type (cadr type)))
 
139
             (when(consp (cddr type))
 
140
               (setq sizes (caddr type))
 
141
               (cond ((consp sizes)
 
142
                      (assure-list sizes)
 
143
                      (unless (typep (second sizes) 'fixnum) (setq sizes nil)))
 
144
                     ((typep sizes 'fixnum) )
 
145
                     (t (setq sizes nil))))
 
146
             (cond ((or (eql sizes 1) (null (cdr sizes)))
 
147
                    (setq tem 'vector) (setq sizes nil))
 
148
                   (t (setq tem 'array)))
 
149
           (list*  tem  element-type  (if sizes (list sizes)))))
 
150
          ((eq (car type) 'integer)
 
151
           (if (si::sub-interval-p (cdr type)
 
152
                                   (list most-negative-fixnum
 
153
                                         most-positive-fixnum))
 
154
               'fixnum
 
155
             'integer))
 
156
          ((eq (car type) 'values)
 
157
           (if  (null (cddr type))
 
158
               (comp-type (second type))
 
159
             (cons 'values (mapcar 'comp-type (cdr (the-list type))))))
 
160
          (t   t)))
 
161
        (t t)))
 
162
 
 
163
(setf (get 'var 'result-type-b1) 'result-type-b1-var)
 
164
(defun result-type-b1-var (x) (or (third x) t))
 
165
 
 
166
(defun result-type (form &aux fd)
 
167
;; compute the result type of form , where FORM is somethign
 
168
;; returned by b1-walk   
 
169
  (cond ((consp form)
 
170
         (cond ((and (symbolp (car form))
 
171
                     (setq fd (get (car form) 'result-type-b1)))
 
172
                (funcall fd form))
 
173
               ((and (atom (second form))
 
174
                     (typep (second form) 'desk))
 
175
                (desk-result-type (second form)))
 
176
               (t t)))
 
177
        ((typep form 'var)
 
178
         (var-type  form))
 
179
        (t
 
180
         (wfs-error)
 
181
         )))
 
182
 
 
183
(setf (get 'dv 'result-type-b1) 'dv-result-type)
 
184
(defun dv-result-type (x)
 
185
  (let ((val (third x)))
 
186
    (cond ((typep val 'fixnum) 'fixnum)
 
187
          ((typep val 'short-float) 'short-float)
 
188
          ((typep val 'double-float) 'double-float)
 
189
          ((typep val 'character) 'character)
 
190
          ((typep val 'character) 'character)
 
191
          (t t))))
 
192
 
 
193
(defun comp-subtypep (x y &aux xa xb)
 
194
;  (cond ((and (atom x) (not (eq y t)) (not (eq x y))
 
195
;             (subtypep x y))(comp-warn "subtypep ~a ~a" x y)))
 
196
  (cond ((eq y t) t)
 
197
        ((atom x)
 
198
         (subtypep x y))
 
199
        ((atom y)
 
200
         (subtypep x y))
 
201
        ((member (car x) '(array struct))
 
202
         (and (eq (car y) (car y)) (subtypep (cdr x) (cdr y))))
 
203
        (t (subtypep x y))))
 
204
 
 
205
(defun type-and (a b)
 
206
  (if (eq a b) (return-from type-and a))
 
207
  (if (eq a t) (return-from type-and b))
 
208
  (if (eq b t) (return-from type-and a))
 
209
  (multiple-value-bind (typ sure)
 
210
                       (subtypep a b)
 
211
                       sure
 
212
                       (cond (typ (return-from type-and a))))
 
213
  (multiple-value-bind (typ sure)
 
214
                       (subtypep b a)
 
215
                       sure
 
216
                       (cond (typ (return-from type-and b))))
 
217
  t)
 
218
    
 
219
  
 
220
  
 
221
  
 
222
        
 
223
              
 
224
             
 
225
             
 
226
  
 
227