← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/lsp/predlib.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2007-04-09 11:51:51 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070409115151-ql8cr0kalzx1jmla
Tags: 0.9i-20070324-2
Upload to unstable. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/lsp/predlib.lsp
77
77
 
78
78
(deftype real (&rest foo) '(OR RATIONAL FLOAT))
79
79
 
80
 
(deftype single-float (&rest args)
 
80
#-short-float
 
81
(deftype short-float (&rest args)
81
82
  (if args
82
 
      `(short-float ,@args)
83
 
      'short-float))
 
83
      `(single-float ,@args)
 
84
      'single-float))
84
85
 
85
 
(deftype double-float (&rest args)
 
86
#-long-float
 
87
(deftype long-float (&rest args)
86
88
  (if args
87
 
      `(long-float ,@args)
88
 
      'long-float))
 
89
      `(double-float ,@args)
 
90
      'double-float))
89
91
 
90
92
(deftype bit ()
91
93
  "A BIT is either integer 0 or 1."
150
152
characters with double quotes.  Some strings may be displaced to another
151
153
string, may have a fill-pointer, or may be adjustable.  Other strings are
152
154
called simple-strings."
153
 
  (if size `(array character (,size)) '(array character (*))))
 
155
  #-unicode
 
156
  (if size `(array character (,size)) '(array character (*)))
 
157
  #+unicode
 
158
  (if size
 
159
      `(or (array base-char (,size))
 
160
           (array character (,size)))
 
161
      '(or (array base-char (*)) (array character (*)))))
154
162
 
155
163
(deftype base-string (&optional size)
156
164
  (if size `(array base-char (,size)) '(array base-char (*))))
165
173
(deftype simple-string (&optional size)
166
174
  "A simple-string is a string that is not displaced to another array, has no
167
175
fill-pointer, and is not adjustable."
168
 
  (if size `(simple-array character (,size)) '(simple-array character (*))))
 
176
  #-unicode
 
177
  (if size
 
178
    `(simple-array character (,size))
 
179
    '(simple-array character (*)))
 
180
  #+unicode
 
181
  (if size
 
182
      `(or (simple-array base-char (,size))
 
183
           (simple-array character (,size)))
 
184
      '(or (simple-array base-char (*)) (simple-array character (*)))))
169
185
 
170
186
(deftype simple-base-string (&optional size)
171
187
  (if size `(simple-array base-char (,size)) '(simple-array base-char (*))))
195
211
             (ATOM . ATOM)
196
212
             #-unicode
197
213
             (EXTENDED-CHAR . CONSTANTLY-NIL)
198
 
             #-unicode
199
 
             (BASE-CHAR . CHARACTERP)
200
 
             #+unicode
201
214
             (BASE-CHAR . BASE-CHAR-P)
202
215
             (CHARACTER . CHARACTERP)
203
216
             (COMPILED-FUNCTION . COMPILED-FUNCTION-P)
233
246
  (put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
234
247
 
235
248
(defconstant +upgraded-array-element-types+
236
 
  '(NIL BASE-CHAR CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SHORT-FLOAT LONG-FLOAT T))
 
249
  '(NIL BASE-CHAR CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
237
250
 
238
251
(defun upgraded-array-element-type (element-type &optional env)
239
252
  (dolist (v +upgraded-array-element-types+ 'T)
243
256
(defun upgraded-complex-part-type (real-type &optional env)
244
257
  ;; ECL does not have specialized complex types. If we had them, the
245
258
  ;; code would look as follows
246
 
  ;;   (dolist (v '(INTEGER RATIO RATIONAL SHORT-FLOAT LONG-FLOAT FLOAT REAL)
 
259
  ;;   (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
247
260
  ;;       (error "~S is not a valid part type for a complex." real-type))
248
261
  ;;     (when (subtypep real-type v)
249
262
  ;;       (return v))))
326
339
     (and (floatp object) (in-interval-p object i)))
327
340
    (REAL
328
341
     (and (or (rationalp object) (floatp object)) (in-interval-p object i)))
329
 
    ((SINGLE-FLOAT SHORT-FLOAT)
 
342
    ((SINGLE-FLOAT #-short-float SHORT-FLOAT)
 
343
     (and (eq (type-of object) 'SINGLE-FLOAT) (in-interval-p object i)))
 
344
    ((DOUBLE-FLOAT #-long-float LONG-FLOAT)
 
345
     (and (eq (type-of object) 'DOUBLE-FLOAT) (in-interval-p object i)))
 
346
    #+long-float
 
347
    (LONG-FLOAT
 
348
     (and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
 
349
    #+short-float
 
350
    (SHORT-FLOAT
330
351
     (and (eq (type-of object) 'SHORT-FLOAT) (in-interval-p object i)))
331
 
    ((DOUBLE-FLOAT LONG-FLOAT)
332
 
     (and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
333
352
    (COMPLEX
334
353
     (and (complexp object)
335
354
          (or (null i)
342
361
    (CONS (and (consp object)
343
362
               (or (endp i) (typep (car object) (first i)))
344
363
               (or (endp (cdr i)) (typep (cdr object) (second i)))))
 
364
    (BASE-STRING
 
365
     (and (base-string-p object)
 
366
          (or (null i) (match-dimensions object i))))
345
367
    (STRING
346
368
     (and (stringp object)
347
369
          (or (null i) (match-dimensions object i))))
348
 
    #+unicode
349
 
    (BASE-STRING
350
 
     (and (stringp object)
351
 
          (typep (array-element-type object) 'base-char)
352
 
          (or (null i) (match-dimensions object i))))
353
370
    (BIT-VECTOR
354
371
     (and (bit-vector-p object)
355
372
          (or (null i) (match-dimensions object i))))
 
373
    (SIMPLE-BASE-STRING
 
374
     (and (base-string-p object)
 
375
          (simple-string-p object)
 
376
          (or (null i) (match-dimensions object i))))
356
377
    (SIMPLE-STRING
357
378
     (and (simple-string-p object)
358
379
          (or (null i) (match-dimensions object i))))
359
 
    #+unicode
360
 
    (SIMPLE-BASE-STRING
361
 
     (and (simple-string-p object)
362
 
          (base-string-p object)
363
 
          (or (null i) (match-dimensions object i))))
364
380
    (SIMPLE-BIT-VECTOR
365
381
     (and (simple-bit-vector-p object)
366
382
          (or (null i) (match-dimensions object i))))
482
498
                ((null io) l)))
483
499
           ((CHARACTER BASE-CHAR) (character object))
484
500
           (FLOAT (float object))
485
 
           ((SINGLE-FLOAT SHORT-FLOAT) (float object 0.0S0))
486
 
           ((DOUBLE-FLOAT LONG-FLOAT) (float object 0.0L0))
 
501
           (SINGLE-FLOAT (float object 0.0F0))
 
502
           (SHORT-FLOAT (float object 0.0S0))
 
503
           (DOUBLE-FLOAT (float object 0.0D0))
 
504
           (LONG-FLOAT (float object 0.0L0))
487
505
           (COMPLEX (complex (realpart object) (imagpart object)))
488
506
           (FUNCTION (coerce-to-function object))
489
507
           ((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING #+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
905
923
        tag))
906
924
  #+(or)
907
925
  (case real-type
908
 
    ((SHORT-FLOAT LONG-FLOAT INTEGER RATIO)
 
926
    ((SINGLE-FLOAT DOUBLE-FLOAT INTEGER RATIO #+long-float LONG-FLOAT
 
927
      #+short-float SHORTF-FLOAT)
909
928
     (let ((tag (new-type-tag)))
910
929
       (push-type `(COMPLEX ,real-type) tag)
911
930
       tag))
912
931
    ((RATIONAL) (canonical-type '(OR (COMPLEX INTEGER) (COMPLEX RATIO))))
913
 
    ((FLOAT) (canonical-type '(OR (COMPLEX SHORT-FLOAT) (COMPLEX LONG-FLOAT))))
 
932
    ((FLOAT) (canonical-type '(OR (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT)
 
933
                               #+long-float (COMPLEX LONG-FLOAT)
 
934
                               #+short-float (COMPLEX SHORT-FLOAT))))
914
935
    ((* NIL REAL) (canonical-type
915
936
                   '(OR (COMPLEX INTEGER) (COMPLEX RATIO)
916
 
                        (COMPLEX SHORT-FLOAT) (COMPLEX LONG-FLOAT))))
 
937
                        (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT)
 
938
                     #+long-float (COMPLEX LONG-FLOAT)
 
939
                     #+short-float (COMPLEX SHORT-FLOAT)
 
940
                     )))
917
941
    (otherwise (canonical-complex-type (upgraded-complex-part-type real-type)))))
918
942
 
919
943
;;----------------------------------------------------------------------
955
979
               (FUNCTION (OR COMPILED-FUNCTION GENERIC-FUNCTION))
956
980
 
957
981
               (INTEGER (INTEGER * *))
 
982
               #+short-float
958
983
               (SHORT-FLOAT (SHORT-FLOAT * *))
 
984
               (SINGLE-FLOAT (SINGLE-FLOAT * *))
 
985
               (DOUBLE-FLOAT (DOUBLE-FLOAT * *))
 
986
               #+long-float
959
987
               (LONG-FLOAT (LONG-FLOAT * *))
960
988
               (RATIO (RATIO * *))
961
989
 
962
990
               (RATIONAL (OR INTEGER RATIO))
963
 
               (FLOAT (OR SHORT-FLOAT LONG-FLOAT))
964
 
               (REAL (OR INTEGER SHORT-FLOAT LONG-FLOAT RATIO))
 
991
               (FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT
 
992
                       #+long-float LONG-FLOAT
 
993
                       #+short-float SHORT-FLOAT))
 
994
               (REAL (OR INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO))
965
995
               (COMPLEX (COMPLEX REAL))
966
996
 
967
997
               (NUMBER (OR REAL COMPLEX))
1009
1039
               (READTABLE)
1010
1040
               #+threads (MP::PROCESS)
1011
1041
               #+threads (MP::LOCK)
 
1042
               #+ffi (FOREIGN-DATA)
1012
1043
               ))
1013
1044
 
1014
1045
(defun find-built-in-tag (name)
1097
1128
           (NOT (lognot (canonical-type (second type))))
1098
1129
           ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type))))
1099
1130
           (SATISFIES (register-satisfies-type type))
1100
 
           ((INTEGER SHORT-FLOAT LONG-FLOAT RATIO)
 
1131
           ((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO
 
1132
             #+long-float LONG-FLOAT #+short-float SHORT-FLOAT)
1101
1133
            (register-interval-type type))
1102
1134
           ((FLOAT)
1103
 
            (canonical-type `(OR (SHORT-FLOAT ,@(rest type))
1104
 
                              (LONG-FLOAT ,@(rest type)))))
 
1135
            (canonical-type `(OR (SINGLE-FLOAT ,@(rest type))
 
1136
                              (DOUBLE-FLOAT ,@(rest type)))))
1105
1137
           ((REAL)
1106
1138
            (canonical-type `(OR (INTEGER ,@(rest type))
1107
1139
                              (RATIO ,@(rest type))
1108
 
                              (SHORT-FLOAT ,@(rest type))
1109
 
                              (LONG-FLOAT ,@(rest type)))))
 
1140
                              (SINGLE-FLOAT ,@(rest type))
 
1141
                              (DOUBLE-FLOAT ,@(rest type)))))
1110
1142
           ((RATIONAL)
1111
1143
            (canonical-type `(OR (INTEGER ,@(rest type))
1112
1144
                              (RATIO ,@(rest type)))))