[db2925]: src / cmp / cmptype-arith.lsp Maximize Restore History

Download this file

cmptype-arith.lsp    316 lines (295 with data), 10.3 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; CMPTYPE-ARITH -- Operations upon and among types
(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES")
;;; CL-TYPE is any valid type specification of Common Lisp.
;;;
;;; TYPE is a representation type used by ECL. TYPE is one of:
;;;
;;; T(BOOLEAN)
;;;
;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT
;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM)
;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT)
;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT)
;;; (ARRAY FIXNUM)
;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT)
;;; STANDARD-OBJECT STRUCTURE-OBJECT
;;; SYMBOL
;;; UNKNOWN
;;;
;;; NIL
;;;
;;;
;;; immediate-type:
;;; FIXNUM int
;;; CHARACTER char
;;; SINGLE-FLOAT float
;;; DOUBLE-FLOAT double
(deftype any () 't)
(defun member-type (type disjoint-supertypes)
(member type disjoint-supertypes :test #'subtypep))
;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
;;; (only used for saving constants?)
#-new-cmp
(defun object-type (thing)
(let ((type (if thing (type-of thing) 'SYMBOL)))
(case type
((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type)
((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
((STRING BASE-STRING BIT-VECTOR) type)
(VECTOR (list 'VECTOR (array-element-type thing)))
(ARRAY (list 'ARRAY (array-element-type thing)))
#+clos
(STANDARD-OBJECT 'STANDARD-OBJECT)
#+clos
(STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
#+sse2
((EXT:SSE-PACK EXT:INT-SSE-PACK EXT:FLOAT-SSE-PACK EXT:DOUBLE-SSE-PACK) type)
(t t))))
(defun valid-type-specifier (type)
(handler-case
(if (subtypep type 'T)
(values t type)
(values nil nil))
(error (c) (values nil nil))))
(defun known-type-p (type)
(subtypep type T))
(defun trivial-type-p (type)
(subtypep T type))
(defun-equal-cached type-and (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-and t1))
(when (eq t1 '*)
(return-from type-and t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
NIL)
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t1)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
t2)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
t1)
((null tag1)
;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1))))
(defun values-number-from-type (type)
(cond ((or (eq type 'T) (eq type '*))
(values 0 MULTIPLE-VALUES-LIMIT))
((or (atom type) (not (eq (first type) 'VALUES)))
(values 1 1))
((or (member '&rest type) (member '&optional type))
(values 0 MULTIPLE-VALUES-LIMIT))
(t
(let ((l (1- (length type))))
(values l l)))))
(defun-equal-cached values-type-primary-type (type)
;; Extract the type of the first value returned by this form. We are
;; pragmatic and thus (VALUES) => NULL [CHECKME!]
(let (aux)
(cond ((or (atom type)
(not (eq (first type) 'VALUES)))
type)
((null (setf aux (rest type)))
'NULL)
((member (setf aux (first aux))
'(&optional &rest &allow-other-keys))
(setf aux (do-values-type-to-n-types type 1))
(if aux (first aux) 'null))
(t
aux))))
(defun-equal-cached values-type-to-n-types (type length)
(when (plusp length)
(do-values-type-to-n-types type length)))
(defun do-values-type-to-n-types (type length)
(declare (si::c-local))
(multiple-value-bind (required optional rest)
(split-values-type type)
(let* ((optional (loop for i in optional
collect (if (eq i t) i `(or null ,i))))
(output (nconc required optional))
(l (length output)))
(if (< l length)
(nconc output (make-list (- length l)
:initial-element (if rest (first rest) t)))
(subseq output 0 length)))))
(defun split-values-type (type)
(if (or (atom type) (not (eq (first type) 'VALUES)))
(values (list type) nil nil nil)
(loop with required = '()
with optional-flag = nil
with optional = '()
with rest = '()
with a-o-k = nil
with l = (rest type)
while l
do (let ((typespec (pop l)))
(case typespec
(&allow-other-keys
(setf a-o-k t)
(when l
(cmperr "Syntax error in type expression ~S" type)))
(&optional
(when optional-flag
(cmperr "Syntax error in type expression ~S" type))
(setf optional-flag t))
(&rest
(when (or (null l)
(not (member (rest l) '(() (&allow-other-keys))
:test #'equal)))
(cmperr "Syntax error in type expression ~S" type))
(setf rest (list (car l))))
(otherwise
(if optional-flag
(push typespec optional)
(push typespec required)))))
finally
(return (values required (nreverse optional) rest a-o-k)))))
(defun-equal-cached values-type-or (t1 t2)
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-or t2))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
(return-from values-type-or t1))
(unless t1
(return-from values-type-or t2))
(unless t2
(return-from values-type-or t1))
(multiple-value-bind (req1 opt1 rest1)
(split-values-type t1)
(multiple-value-bind (req2 opt2 rest2)
(split-values-type t2)
(let ((req '())
(opt '())
(rest '()))
(loop for t1 in req1
do (cond (req2
(push (type-or t1 (pop req2)) req))
(opt2
(push (type-or t1 (pop opt2)) opt))
(rest2
(push (type-or t1 (first rest2)) opt))
(t
(push t1 opt))))
(loop for t1 in opt1
do (cond (req2
(push (type-or t1 (pop req2)) opt))
(opt2
(push (type-or t1 (pop opt2)) opt))
(rest2
(push (type-or t1 (first rest2)) opt))
(t
(push t1 opt))))
(let ((t1 (if rest1 (first rest1) t)))
(loop for t2 in req2
do (push (type-or t1 t2) opt))
(loop for t2 in opt2
do (push (type-or t1 t2) opt))
(if rest2
(setf rest (list (type-or t1 (first rest2))))
(setf rest rest1)))
`(VALUES ,@(nreverse req)
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached values-type-and (t1 t2)
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-and t1))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
(return-from values-type-and t2))
(when (or (null t1) (null t2))
(return-from values-type-and nil))
(multiple-value-bind (req1 opt1 rest1)
(split-values-type t1)
(multiple-value-bind (req2 opt2 rest2)
(split-values-type t2)
(let ((req '())
(opt '())
(rest '()))
(loop for t1 in req1
do (cond (req2 (push (type-and t1 (pop req2)) req))
(opt2 (push (type-and t1 (pop opt2)) req))
(rest2 (push (type-and t1 (first rest2)) req))
(t (setf opt1 nil rest1 nil) (return))))
(loop for t1 in opt1
do (cond (req2 (push (type-and t1 (pop req2)) req))
(opt2 (push (type-and t1 (pop opt2)) opt))
(rest2 (push (type-and t1 (first rest2)) opt))
(t (setf opt1 nil rest1 nil) (return))))
(when rest
(let ((t1 (first rest)))
(loop for t2 in req2
do (push (type-and t1 t2) req))
(loop for t2 in opt2
do (push (type-and t1 t2) opt))
(when rest2
(setf rest (list (type-and t1 (first rest2)))))))
`(VALUES ,@(nreverse req)
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached type-or (t1 t2)
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-or t1))
(when (eq t1 '*)
(return-from type-or t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1))
(tag2 (si::safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1)
tag2 (si::safe-canonical-type t2))
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t2)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
T)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
;(break)
(cmpnote "Unknown type ~S" t1)
T)
(t
;(break)
(cmpnote "Unknown type ~S" t2)
T))))
(defun type>= (type1 type2)
(subtypep type2 type1))