[a74fe1]: src / lsp / predlib.lsp Maximize Restore History

Download this file

predlib.lsp    1451 lines (1339 with data), 50.9 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
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; 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.
;;;; predicate routines
(in-package "SYSTEM")
(defun constantly-t (&rest foo)
(declare (ignore foo))
t)
(defun constantly-nil (&rest foo)
(declare (ignore foo))
nil)
(defun constantly (n)
"Args: (n)
Builds a new function which accepts any number of arguments but always outputs N."
(case n
((nil) #'constantly-nil)
((t) #'constantly-t)
(t #'(lambda (&rest x) (declare (ignore x)) n))))
(defparameter *subtypep-cache* (si:make-vector t 256 nil nil nil 0))
(defparameter *upgraded-array-element-type-cache* (si:make-vector t 128 nil nil nil 0))
(defun subtypep-clear-cache ()
(ext:fill-array-with-elt *subtypep-cache* nil 0 nil)
(ext:fill-array-with-elt *upgraded-array-element-type-cache* nil 0 nil))
(defun create-type-name (name)
(when (member name *alien-declarations*)
(error "Symbol ~s is a declaration specifier and cannot be used to name a new type" name)))
(defun do-deftype (name form function)
(unless (symbolp name)
(error "~s is not a valid type specifier" name))
(create-type-name name)
(put-sysprop name 'DEFTYPE-FORM form)
(put-sysprop name 'DEFTYPE-DEFINITION
(if (functionp function) function (constantly function)))
(subtypep-clear-cache)
name)
;;; DEFTYPE macro.
(defmacro deftype (name lambda-list &rest body &environment env)
"Syntax: (deftype name lambda-list {decl | doc}* {form}*)
Defines a new type-specifier abbreviation in terms of an 'expansion' function
(lambda lambda-list1 {DECL}* {FORM}*)
where LAMBDA-LIST1 is identical to LAMBDA-LIST except that all optional
parameters with no default value specified in LAMBDA-LIST defaults to the
symbol '*', but not to NIL. When the type system of ECL encounters a type
specifier (NAME arg1 ... argn), it calls the expansion function with the
arguments ARG1 ... ARGn, and uses the returned value instead of the original
type specifier. When the symbol NAME is used as a type specifier, the
expansion function is called with no argument.
The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved
by (documentation 'NAME 'type)."
(multiple-value-bind (body doc)
(remove-documentation body)
(setf lambda-list (copy-list lambda-list))
(dolist (x '(&optional &key))
(do ((l (rest (member x lambda-list)) (rest l)))
((null l))
(let ((variable (first l)))
(when (and (symbolp variable)
(not (member variable lambda-list-keywords)))
(setf (first l) `(,variable '*))))))
(let ((function `#'(LAMBDA-BLOCK ,name ,lambda-list ,@body)))
(when (and (null lambda-list) (consp body) (null (rest body)))
(let ((form (first body)))
(when (constantp form env)
(setf function (ext:maybe-quote (ext:constant-form-value form env))))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(si::expand-set-documentation name 'type doc)
(do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body)
,function)))))
;;; Some DEFTYPE definitions.
(deftype boolean ()
"A BOOLEAN is an object which is either NIL or T."
'(member nil t))
(deftype index ()
'(INTEGER 0 #.array-dimension-limit))
(deftype fixnum ()
"A FIXNUM is an integer between MOST-NEGATIVE-FIXNUM (= - 2^29 in ECL) and
MOST-POSITIVE-FIXNUM (= 2^29 - 1 in ECL) inclusive. Other integers are
bignums."
'(INTEGER #.most-negative-fixnum #.most-positive-fixnum))
(deftype bignum ()
'(OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
(deftype ext::byte8 () '(INTEGER 0 255))
(deftype ext::integer8 () '(INTEGER -128 127))
(deftype ext::byte16 () '(INTEGER 0 #xFFFF))
(deftype ext::integer16 () '(INTEGER #x-8000 #x7FFF))
(deftype ext::byte32 () '(INTEGER 0 #xFFFFFFFF))
(deftype ext::integer32 () '(INTEGER #x-80000000 #x7FFFFFFF))
(deftype ext::byte64 () '(INTEGER 0 #xFFFFFFFFFFFFFFFF))
(deftype ext::integer64 () '(INTEGER #x-8000000000000000 #x7FFFFFFFFFFFFFFF))
(deftype ext::cl-fixnum () '(SIGNED-BYTE #.CL-FIXNUM-BITS))
(deftype ext::cl-index () '(UNSIGNED-BYTE #.CL-FIXNUM-BITS))
(deftype real (&optional (start '* start-p) (end '*))
(if start-p
(let (rat-start
real-start
rat-end
real-end)
(cond ((consp start)
(setf start (first start)
rat-start (list (rational start))
real-start (list (float start))))
((numberp start)
(setf rat-start (rational start)
real-start (float start)))
(t
(setf rat-start start
real-start start)))
(cond ((consp end)
(setf end (first end)
rat-end (list (rational end))
real-end (list (float end))))
((numberp end)
(setf rat-end (rational end)
real-end (float end)))
(t
(setf rat-end end
real-end end)))
`(OR (RATIONAL ,rat-start ,rat-end) (FLOAT ,real-start ,real-end)))
'(OR RATIONAL FLOAT)))
#-short-float
(deftype short-float (&rest args)
(if args
`(single-float ,@args)
'single-float))
#-long-float
(deftype long-float (&rest args)
(if args
`(double-float ,@args)
'double-float))
(deftype bit ()
"A BIT is either integer 0 or 1."
'(INTEGER 0 1))
(deftype mod (n)
`(INTEGER 0 ,(1- n)))
(deftype signed-byte (&optional s)
"As a type specifier, (SIGNED-BYTE n) specifies those integers that can be
represented with N bits in 2's complement representation."
(if (or (null s) (eq s '*))
'(INTEGER * *)
`(INTEGER ,(- (expt 2 (1- s))) ,(1- (expt 2 (1- s))))))
(deftype unsigned-byte (&optional s)
"As a type specifier, (UNSIGNED-BYTE n) specifies non-negative integers that
can be represented with N bits."
(if (or (null s) (eq s '*))
'(INTEGER 0 *)
`(INTEGER 0 ,(1- (expt 2 s)))))
(deftype null ()
"The type to which only NIL belongs."
'(MEMBER NIL))
(deftype sequence ()
"A sequence is either a list or a vector."
'(OR CONS NULL (ARRAY * (*))))
(deftype list ()
"As a type specifier, LIST is used to specify the type consisting of NIL and
cons objects. In our ordinary life with Lisp, however, a list is either NIL
or a cons whose cdr is a list, and is notated by its elements surrounded with
parentheses.
The backquote macro is sometimes useful to construct a complicated list
structure. When evaluating `(...)
,form embeds the value of FORM,
,@form and ,.form embed all elements of the list value of FORM,
and other things embed itself
into the structure at their position. For example,
`(a b ,c d e) expands to (list* 'a 'b c '(d e))
`(a b ,@c d e) expands to (list* 'a 'b (append c '(d e)))
`(a b ,.c d e) expands to (list* 'a 'b (nconc c '(d e)))"
'(OR CONS NULL))
(deftype proper-list ()
'(OR (CONS T PROPER-LIST) NULL))
(deftype property-list ()
'(OR (CONS T (CONS T PROPERTY-LIST)) NULL))
(deftype atom ()
"An ATOM is an object that is not a CONS."
'(NOT CONS))
;(deftype null () '(MEMBER NIL))
(deftype vector (&optional (element-type '*) (size '*))
"A vector is a one-dimensional array. Strings and bit-vectors are kinds of
vectors. Other vectors are called general vectors and are notated as
#(elem ... elem)
Some vectors may be displaced to another array, may have a fill-pointer, or
may be adjustable. Other vectors are called simple-vectors."
`(array ,element-type (,size)))
(deftype extended-char ()
"A character which is not of type BASE-CHAR."
'(and character (not base-char)))
(deftype string (&optional size)
"A string is a vector of characters. A string is notated by surrounding the
characters with double quotes. Some strings may be displaced to another
string, may have a fill-pointer, or may be adjustable. Other strings are
called simple-strings."
#-unicode
(if (eq size '*)
'(array character (*))
`(array character (,size)))
#+unicode
(if (eq size '*)
'(or (array base-char (*)) (array character (*)))
`(or (array base-char (,size))
(array character (,size)))))
(deftype base-string (&optional (size '*))
"A string which is made of BASE-CHAR."
(if (eq size '*) '(array base-char (*)) `(array base-char (,size))))
(deftype extended-string (&optional (size '*))
"A string which is nt a base string"
#-unicode
NIL
#+unicode
(if (eq size '*) '(array character (*)) `(array character (,size))))
(deftype bit-vector (&optional (size '*))
"A bit-vector is a vector of bits. A bit-vector is notated by '#*' followed
by its elements (0 or 1). Bit-vectors may be displaced to another array, may
have a fill-pointer, or may be adjustable. Other bit-vectors are called
simple-bit-vectors. Only simple-bit-vectors can be input in the above format
using '#*'."
(if (eq size '*) '(array bit (*)) `(array bit (,size))))
(deftype simple-vector (&optional (size '*))
"A simple-vector is a vector that is not displaced to another array, has no
fill-pointer, and is not adjustable."
(if (eq size '*) '(simple-array t (*)) `(simple-array t (,size))))
(deftype simple-string (&optional size)
"A simple-string is a string that is not displaced to another array, has no
fill-pointer, and is not adjustable."
#-unicode
(if size
`(simple-array character (,size))
'(simple-array character (*)))
#+unicode
(if size
`(or (simple-array base-char (,size))
(simple-array character (,size)))
'(or (simple-array base-char (*)) (simple-array character (*)))))
(deftype simple-base-string (&optional size)
"A base-string which cannot be adjusted nor displaced."
(if size `(simple-array base-char (,size)) '(simple-array base-char (*))))
(deftype simple-bit-vector (&optional size)
"A bit-vector that is not displaced to another array, has no fill-pointer,
and is not adjustable."
(if size `(simple-array bit (,size)) '(simple-array bit (*))))
(deftype array-index ()
'(integer 0 #.(1- array-dimension-limit)))
;;************************************************************
;; TYPEP
;;************************************************************
(defun simple-array-p (x)
(and (arrayp x)
(not (adjustable-array-p x))
(not (array-has-fill-pointer-p x))
(not (array-displacement x))))
(defun complex-array-p (x)
(and (arrayp x)
(or (adjustable-array-p x)
(array-has-fill-pointer-p x)
(array-displacement x))))
(eval-when (:execute :load-toplevel :compile-toplevel)
(defconstant +known-typep-predicates+
'((ARRAY . ARRAYP)
(ATOM . ATOM)
#-unicode
(EXTENDED-CHAR . CONSTANTLY-NIL)
(BASE-CHAR . BASE-CHAR-P)
(BASE-STRING . BASE-STRING-P)
(BIT-VECTOR . BIT-VECTOR-P)
(CHARACTER . CHARACTERP)
(COMPILED-FUNCTION . COMPILED-FUNCTION-P)
(COMPLEX . COMPLEXP)
(COMPLEX-ARRAY . COMPLEX-ARRAY-P)
(CONS . CONSP)
(FLOAT . FLOATP)
(SI:FOREIGN-DATA . SI:FOREIGN-DATA-P)
(FUNCTION . FUNCTIONP)
(HASH-TABLE . HASH-TABLE-P)
(INTEGER . INTEGERP)
(FIXNUM . SI::FIXNUMP)
(KEYWORD . KEYWORDP)
(LIST . LISTP)
(LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
(NIL . CONSTANTLY-NIL)
(NULL . NULL)
(NUMBER . NUMBERP)
(PACKAGE . PACKAGEP)
(RANDOM-STATE . RANDOM-STATE-P)
(RATIONAL . RATIONALP)
(PATHNAME . PATHNAMEP)
(READTABLE . READTABLEP)
(REAL . REALP)
(SIMPLE-ARRAY . SIMPLE-ARRAY-P)
(SIMPLE-STRING . SIMPLE-STRING-P)
(SIMPLE-VECTOR . SIMPLE-VECTOR-P)
(STREAM . STREAMP)
(STRING . STRINGP)
(STRUCTURE . SYS:STRUCTUREP)
(SYMBOL . SYMBOLP)
#+sse2 (EXT:SSE-PACK . EXT:SSE-PACK-P)
#+sse2 (EXT:INT-SSE-PACK . EXT:SSE-PACK-P)
#+sse2 (EXT:FLOAT-SSE-PACK . EXT:SSE-PACK-P)
#+sse2 (EXT:DOUBLE-SSE-PACK . EXT:SSE-PACK-P)
(T . CONSTANTLY-T)
(VECTOR . VECTORP))))
(dolist (l +known-typep-predicates+)
(put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
(defconstant +upgraded-array-element-types+
'#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT EXT:BYTE8 EXT:INTEGER8)
#+:uint16-t '(EXT:BYTE16 EXT:INTEGER16)
#+:uint32-t '(EXT:BYTE32 EXT:INTEGER32)
(when (< 32 cl-fixnum-bits 64) '(EXT::CL-INDEX FIXNUM))
#+:uint64-t '(EXT:BYTE64 EXT:INTEGER64)
(when (< 64 cl-fixnum-bits) '(EXT::CL-INDEX FIXNUM))
'(SINGLE-FLOAT DOUBLE-FLOAT T)))
(defun upgraded-array-element-type (element-type &optional env)
(declare (ignore env))
(let* ((hash (logand 127 (si:hash-eql element-type)))
(record (aref *upgraded-array-element-type-cache* hash)))
(declare (type (integer 0 127) hash))
(if (and record (eq (car record) element-type))
(cdr record)
(let ((answer (if (member element-type +upgraded-array-element-types+
:test #'eq)
element-type
(dolist (v +upgraded-array-element-types+ 'T)
(when (subtypep element-type v)
(return v))))))
(setf (aref *upgraded-array-element-type-cache* hash)
(cons element-type answer))
answer))))
(defun upgraded-complex-part-type (real-type &optional env)
(declare (ignore env))
;; ECL does not have specialized complex types. If we had them, the
;; code would look as follows
;; (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
;; (error "~S is not a valid part type for a complex." real-type))
;; (when (subtypep real-type v)
;; (return v))))
(unless (subtypep real-type 'REAL)
(error "~S is not a valid part type for a complex." real-type))
'REAL)
(defun in-interval-p (x interval)
(declare (si::c-local))
(let* (low high)
(if (endp interval)
(setq low '* high '*)
(if (endp (cdr interval))
(setq low (car interval) high '*)
(setq low (car interval) high (second interval))))
(cond ((eq low '*))
((consp low)
(when (<= x (car low)) (return-from in-interval-p nil)))
((when (< x low) (return-from in-interval-p nil))))
(cond ((eq high '*))
((consp high)
(when (>= x (car high)) (return-from in-interval-p nil)))
((when (> x high) (return-from in-interval-p nil))))
(return-from in-interval-p t)))
(defun error-type-specifier (type)
(declare (si::c-local))
(error "~S is not a valid type specifier." type))
(defun match-dimensions (array pat)
(declare (si::c-local))
(or (eq pat '*)
(let ((rank (array-rank array)))
(cond ((numberp pat) (= rank pat))
((listp pat)
(dotimes (i rank (null pat))
(unless (and (consp pat)
(or (eq (car pat) '*)
(eql (array-dimension array i) (car pat))))
(return nil))
(setq pat (cdr pat))))
((atom pat)
(error "~S does not describe array dimensions." pat))))))
(defun typep (object type &optional env &aux tp i c)
"Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
(declare (ignore env))
(cond ((symbolp type)
(let ((f (get-sysprop type 'TYPE-PREDICATE)))
(cond (f (return-from typep (funcall f object)))
((eq (type-of object) type) (return-from typep t))
(t (setq tp type i nil)))))
((consp type)
(setq tp (car type) i (cdr type)))
#+clos
((sys:instancep type)
(return-from typep (si::subclassp (class-of object) type)))
(t
(error-type-specifier type)))
(case tp
((EQL MEMBER) (and (member object i) t))
(NOT (not (typep object (car i))))
(OR (dolist (e i)
(when (typep object e) (return t))))
(AND (dolist (e i t)
(unless (typep object e) (return nil))))
(SATISFIES (funcall (car i) object))
((T) t)
((NIL) nil)
(BIGNUM (and (integerp object) (not (si::fixnump object))))
(RATIO (eq (type-of object) 'RATIO))
(STANDARD-CHAR
(and (characterp object) (standard-char-p object)))
(INTEGER
(and (integerp object) (in-interval-p object i)))
(RATIONAL
(and (rationalp object) (in-interval-p object i)))
(FLOAT
(and (floatp object) (in-interval-p object i)))
(REAL
(and (or (rationalp object) (floatp object)) (in-interval-p object i)))
((SINGLE-FLOAT #-short-float SHORT-FLOAT)
(and (eq (type-of object) 'SINGLE-FLOAT) (in-interval-p object i)))
((DOUBLE-FLOAT #-long-float LONG-FLOAT)
(and (eq (type-of object) 'DOUBLE-FLOAT) (in-interval-p object i)))
#+long-float
(LONG-FLOAT
(and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
(COMPLEX
(and (complexp object)
(or (null i)
(and (typep (realpart object) (car i))
;;wfs--should only have to check one.
;;Illegal to mix real and imaginary types!
(typep (imagpart object) (car i))))
))
(SEQUENCE (or (listp object) (vectorp object)))
(CONS (and (consp object)
(or (endp i)
(let ((car-type (first i)))
(or (eq car-type '*) (typep (car object) car-type))))
(or (endp (cdr i))
(let ((cdr-type (second i)))
(or (eq cdr-type '*) (typep (cdr object) cdr-type))))))
(BASE-STRING
(and (base-string-p object)
(or (null i) (match-dimensions object i))))
(STRING
(and (stringp object)
(or (null i) (match-dimensions object i))))
(BIT-VECTOR
(and (bit-vector-p object)
(or (null i) (match-dimensions object i))))
(SIMPLE-BASE-STRING
(and (base-string-p object)
(simple-string-p object)
(or (null i) (match-dimensions object i))))
(SIMPLE-STRING
(and (simple-string-p object)
(or (null i) (match-dimensions object i))))
(SIMPLE-BIT-VECTOR
(and (simple-bit-vector-p object)
(or (null i) (match-dimensions object i))))
(SIMPLE-VECTOR
(and (simple-vector-p object)
(or (null i) (match-dimensions object i))))
(COMPLEX-ARRAY
(and (complex-array-p object)
(or (endp i) (eq (car i) '*)
;; (car i) needs expansion
(eq (array-element-type object)
(upgraded-array-element-type (car i))))
(or (endp (cdr i)) (match-dimensions object (second i)))))
(SIMPLE-ARRAY
(and (simple-array-p object)
(or (endp i) (eq (car i) '*)
;; (car i) needs expansion
(eq (array-element-type object)
(upgraded-array-element-type (car i))))
(or (endp (cdr i)) (match-dimensions object (second i)))))
(ARRAY
(and (arrayp object)
(or (endp i) (eq (car i) '*)
;; Or the element type of object should be EQUAL to (car i).
;; Is this too strict?
(eq (array-element-type object)
(upgraded-array-element-type (car i))))
(or (endp (cdr i)) (match-dimensions object (second i)))))
(t
(cond
((get-sysprop tp 'DEFTYPE-DEFINITION)
(typep object (apply (get-sysprop tp 'DEFTYPE-DEFINITION) i)))
((consp i)
(error-type-specifier type))
#+clos
((setq c (find-class type nil))
;; Follow the inheritance chain
(si::subclassp (class-of object) c))
#-clos
((get-sysprop tp 'IS-A-STRUCTURE)
(when (sys:structurep object)
;; Follow the chain of structure-include.
(do ((stp (sys:structure-name object)
(get-sysprop stp 'STRUCTURE-INCLUDE)))
((eq tp stp) t)
(when (null (get-sysprop stp 'STRUCTURE-INCLUDE))
(return nil)))))
(t
(error-type-specifier type))))))
#+clos
(defun subclassp (low high)
(or (eq low high)
(member high (sys:instance-ref low clos::+class-precedence-list-ndx+)
:test #'eq))) ; (class-precedence-list low)
#+clos
(defun of-class-p (object class)
(declare (optimize (speed 3) (safety 0)))
(macrolet ((class-precedence-list (x)
`(si::instance-ref ,x clos::+class-precedence-list-ndx+))
(class-name (x)
`(si::instance-ref ,x clos::+class-name-ndx+)))
(let* ((x-class (class-of object)))
(declare (class x-class))
(if (eq x-class class)
t
(let ((x-cpl (class-precedence-list x-class)))
(if (instancep class)
(member class x-cpl :test #'eq)
(dolist (c x-cpl)
(declare (class c))
(when (eq (class-name c) class)
(return t)))))))))
#+(and clos ecl-min)
(defun clos::classp (foo)
(declare (ignore foo))
nil)
;;************************************************************
;; NORMALIZE-TYPE
;;************************************************************
;; NORMALIZE-TYPE normalizes the type using the DEFTYPE definitions.
;; The result is a pair of values
;; VALUE-1 = normalized type name or object
;; VALUE-2 = normalized type arguments or nil
(defun normalize-type (type &aux tp i fd)
;; Loops until the car of type has no DEFTYPE definition.
(cond ((symbolp type)
(if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION))
(normalize-type (funcall fd))
(values type nil)))
#+clos
((clos::classp type) (values type nil))
((atom type)
(error-type-specifier type))
((progn
(setq tp (car type) i (cdr type))
(setq fd (get-sysprop tp 'DEFTYPE-DEFINITION)))
(normalize-type (apply fd i)))
((and (eq tp 'INTEGER) (consp (cadr i)))
(values tp (list (car i) (1- (caadr i)))))
(t (values tp i))))
(defun expand-deftype (type)
(cond ((symbolp type)
(let ((fd (get-sysprop type 'DEFTYPE-DEFINITION)))
(if fd
(expand-deftype (funcall fd))
type)))
((and (consp type)
(symbolp type))
(let ((fd (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
(if fd
(expand-deftype (funcall fd (rest type)))
type)))
(t
type)))
;;************************************************************
;; COERCE
;;************************************************************
(defun error-coerce (object type)
(error "Cannot coerce ~S to type ~S." object type))
(defun coerce (object type &aux aux)
"Args: (x type)
Coerces X to an object of the specified type, if possible. Signals an error
if not possible."
(when (typep object type)
;; Just return as it is.
(return-from coerce object))
(setq type (expand-deftype type))
(cond ((atom type)
(case type
((T) object)
(LIST
(do ((io (make-seq-iterator object) (seq-iterator-next object io))
(l nil (cons (seq-iterator-ref object io) l)))
((null io) l)))
((CHARACTER BASE-CHAR) (character object))
(FLOAT (float object))
(SINGLE-FLOAT (float object 0.0F0))
(SHORT-FLOAT (float object 0.0S0))
(DOUBLE-FLOAT (float object 0.0D0))
(LONG-FLOAT (float object 0.0L0))
(COMPLEX (complex (realpart object) (imagpart object)))
(FUNCTION (coerce-to-function object))
((VECTOR SIMPLE-VECTOR #+unicode SIMPLE-BASE-STRING SIMPLE-STRING #+unicode BASE-STRING STRING BIT-VECTOR SIMPLE-BIT-VECTOR)
(concatenate type object))
(t
(if (or (listp object) (vector object))
(concatenate type object)
(error-coerce object type)))))
((eq (setq aux (first type)) 'COMPLEX)
(if type
(complex (coerce (realpart object) (second type))
(coerce (imagpart object) (second type)))
(complex (realpart object) (imagpart object))))
((member aux '(SINGLE-FLOAT SHORT-FLOAT DOUBLE-FLOAT LONG-FLOAT FLOAT))
(setq aux (coerce object aux))
(unless (typep aux type)
(error-coerce object type))
aux)
((eq aux 'AND)
(dolist (type (rest type))
(setq aux (coerce aux type)))
(unless (typep aux type)
(error-coerce object type))
aux)
((or (listp object) (vector object))
(concatenate type object))
(t
(error-coerce object type))))
;;************************************************************
;; SUBTYPEP
;;************************************************************
;;
;; TYPES LATTICE (Following Henry Baker's paper)
;;
;; The algorithm works as follows. Types are identified with sets. Some sets
;; are elementary, in the sense that other types may be expressed as
;; combination of them. We partition these sets into FAMILIES
;;
;; Built-in objects --- Hash tables, etc
;; Intervals --- (INTEGER a b), (REAL a b), etc
;; Arrays --- (ARRAY * (2)), etc
;; Classes
;;
;; When passed a type specifier, ECL canonicalizes it: it decomposes the
;; type into the most elementary sets, assigns a unique bit pattern (TAG) to
;; each of these sets, and builds a composite tag for the type by LOGIOR.
;; Operations between these sets reduce to logical operations between these
;; bit patterns. Given types T1, T2 and a function which produces tags f(T)
;;
;; f((AND T1 T2)) = (LOGIAND f(T1) f(T2))
;; f((OR T1 T2)) = (LOGIOR f(T1) f(T2))
;; f((NOT T1)) = (LOGNOT f(T2))
;;
;; However, tags are not permanent: whenever a new type is registered, the
;; tag associated to a type may be changed (for instance, because new
;; elementary sets are discovered, which also belong to existing types).
(defparameter *save-types-database* nil)
(defparameter *highest-type-tag*
#+ecl-min #B1
#-ecl-min '#.*highest-type-tag*)
(defparameter *member-types*
#+ecl-min NIL
#-ecl-min '#.*member-types*)
(defparameter *intervals-mask* #B1)
(defparameter *elementary-types*
#+ecl-min
'()
#-ecl-min
'#.*elementary-types*)
(defun new-type-tag ()
(declare (si::c-local))
(prog1 *highest-type-tag*
(setq *highest-type-tag* (ash *highest-type-tag* 1))))
;; Find out the tag for a certain type, if it has been already registered.
;;
(defun find-registered-tag (type &optional (test #'equal))
(declare (si::c-local))
(let* ((pos (assoc type *elementary-types* :test test)))
(and pos (cdr pos))))
;; We are going to make changes in the types database. Save a copy if this
;; will cause trouble.
;;
(defun maybe-save-types ()
(declare (si::c-local))
(when *save-types-database*
(setf *save-types-database* nil
*elementary-types* (copy-tree *elementary-types*)
*member-types* (copy-tree *member-types*))))
;; We have created and tagged a new type (NEW-TAG). However, there are
;; composite and synonym types registered around which are supertypes of
;; this type and need to be tagged. TYPE-MASK is a bit pattern which helps
;; us in recognizing these supertypes.
;;
(defun update-types (type-mask new-tag)
(declare (ext:assume-no-errors))
(maybe-save-types)
(dolist (i *elementary-types*)
(unless (zerop (logand (cdr i) type-mask))
(setf (cdr i) (logior new-tag (cdr i))))))
;; FIND-TYPE-BOUNDS => (VALUES TAG-SUPER TAG-SUB)
;;
;; This function outputs two values: TAG-SUB, the tag for the union-type of all
;; types which are subtypes of the supplied one; and TAG-SUPER, which is either
;; the tag for the union-type of all types which a supertype of the supplied
;; one (MINIMIZE-SUPER = NIL) or the tag for the smallest type which is a
;; supertype of the given one (MINIMIZE-SUPER = TRUE). The search process is
;; restricted to types in the same family class.
;;
;; A value of MINIMIZE-SUPER = TRUE only makes sense for some families (such
;; as semi-infinite intervals), for which (SUBTYPEP T1 T2) = T and (SUBTYPEP T1
;; T3) = T implies either (SUBTYPEP T2 T3) = T or (SUBTYPEP T3 T2) = T.
;;
(defun find-type-bounds (type in-our-family-p type-<= minimize-super)
(declare (si::c-local)
(optimize (safety 0))
(function in-our-family-p type-<=))
(let* ((subtype-tag 0)
(disjoint-tag 0)
(supertype-tag (if minimize-super -1 0)))
(dolist (i *elementary-types*)
(declare (cons i))
(let ((other-type (car i))
(other-tag (cdr i)))
(when (funcall in-our-family-p other-type)
(cond ((funcall type-<= type other-type)
(if minimize-super
(when (zerop (logandc2 other-tag supertype-tag))
(setq supertype-tag other-tag))
(setq supertype-tag (logior other-tag supertype-tag))))
((funcall type-<= other-type type)
(setq subtype-tag (logior other-tag subtype-tag)))
(t
(setq disjoint-tag (logior disjoint-tag other-tag)))))))
(values (if (= supertype-tag -1) 0
(logandc2 supertype-tag (logior disjoint-tag subtype-tag)))
subtype-tag)))
;; A new type is to be registered, which is not simply a composition of
;; previous types. A new tag has to be created, and all supertypes are to be
;; tagged. Here we have to distinguish two possibilities: first, a supertype
;; may belong to the same family (intervals, arrays, etc); second, some
;; supertypes may be basic types (NUMBER is a supertype for (INTEGER 0 2),
;; for instance). The first possibility is detected with the comparison
;; procedure, TYPE-<=; the second possibility is detected by means of tags.
;;
(defun register-type (type in-our-family-p type-<=)
(declare (si::c-local)
(optimize (safety 0))
(function in-our-family-p type-<=))
(or (find-registered-tag type)
(multiple-value-bind (tag-super tag-sub)
(find-type-bounds type in-our-family-p type-<= nil)
(let ((tag (new-type-tag)))
(update-types (logandc2 tag-super tag-sub) tag)
(setf tag (logior tag tag-sub))
(push-type type tag)))))
;;----------------------------------------------------------------------
;; MEMBER types. We register this object in a separate list, *MEMBER-TYPES*,
;; and tag all types to which it belongs. We need to treat three cases
;; separately
;; - Ordinary types, via simple-member-type, check the objects
;; against all pre-registered types, adding their tags.
;; - Ordinary numbers, are translated into intervals.
;; - Floating point zeros, have to be treated separately. This
;; is done by assigning a special tag to -0.0 and translating
;; (MEMBER 0.0) = (AND (float-type 0.0 0.0) (NOT (MEMBER -0.0)))
;;
(defun register-member-type (object)
;(declare (si::c-local))
(let ((pos (assoc object *member-types*)))
(cond ((and pos (cdr pos)))
((not (realp object))
(simple-member-type object))
((and (floatp object) (zerop object))
#.(if (eql (- 0.0) 0.0)
'(number-member-type object)
'(if (minusp (float-sign object))
(simple-member-type object)
(logandc2 (number-member-type object)
(register-member-type (- object))))))
(t
(number-member-type object)))))
(defun simple-member-type (object)
(declare (si::c-local)
(ext:assume-no-errors))
(let* ((tag (new-type-tag)))
(maybe-save-types)
(setq *member-types* (acons object tag *member-types*))
(dolist (i *elementary-types*)
(let ((type (car i)))
(when (typep object type)
(setf (cdr i) (logior tag (cdr i))))))
tag))
;; We convert number into intervals, so that (AND INTEGER (NOT (EQL
;; 10))) is detected as a subtype of (OR (INTEGER * 9) (INTEGER 11
;; *)).
(defun number-member-type (object)
(let* ((base-type (if (integerp object) 'INTEGER (type-of object)))
(type (list base-type object object)))
(or (find-registered-tag type)
(register-interval-type type))))
(defun push-type (type tag)
(declare (si::c-local)
(ext:assume-no-errors))
(dolist (i *member-types*)
(declare (cons i))
(when (typep (car i) type)
(setq tag (logior tag (cdr i)))))
(push (cons type tag) *elementary-types*)
tag)
;;----------------------------------------------------------------------
;; SATISFIES types. Here we should signal some error which is caught
;; somewhere up, to denote failure of the decision procedure.
;;
(defun register-satisfies-type (type)
(declare (si::c-local)
(ignore type))
(throw '+canonical-type-failure+ 'satisfies))
;;----------------------------------------------------------------------
;; CLOS classes and structures.
;;
(defun register-class (class)
(declare (si::c-local)
(notinline class-name))
(or (find-registered-tag class)
;; We do not need to register classes which belong to the core type
;; system of LISP (ARRAY, NUMBER, etc).
(let* ((name (class-name class)))
(and name
(eq class (find-class name 'nil))
(or (find-registered-tag name)
(find-built-in-tag name))))
(and (not (clos::class-finalized-p class))
(throw '+canonical-type-failure+ nil))
(register-type class
#'(lambda (c) (or (si::instancep c) (symbolp c)))
#'(lambda (c1 c2)
(when (symbolp c1)
(setq c1 (find-class c1 nil)))
(when (symbolp c2)
(setq c2 (find-class c2 nil)))
(and c1 c2 (si::subclassp c1 c2))))))
;;----------------------------------------------------------------------
;; ARRAY types.
;;
(defun register-array-type (type)
(declare (si::c-local))
(multiple-value-bind (array-class elt-type dimensions)
(parse-array-type type)
(cond ((eq elt-type '*)
(canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions))
+upgraded-array-element-types+))))
((find-registered-tag (setq type (list array-class elt-type dimensions))))
(t
#+nil
(when (and (consp dimensions) (> (count-if #'numberp dimensions) 1))
(dotimes (i (length dimensions))
(when (numberp (elt dimensions i))
(let ((dims (make-list (length dimensions) :initial-element '*)))
(setf (elt dims i) (elt dimensions i))
(register-type (list array-class elt-type dims)
#'array-type-p #'array-type-<=)))))
(register-type type #'array-type-p #'array-type-<=)))))
;;
;; We look for the most specialized type which is capable of containing
;; this object. LIST always contains 'T, so that this procedure never
;; fails. It is faster than UPGRADED-... because we use the tags of types
;; that have been already registered.
;;
(defun fast-upgraded-array-element-type (type)
(declare (si::c-local))
(cond ((eql type '*) '*)
((member type +upgraded-array-element-types+ :test #'eq)
type)
(t
(dolist (other-type +upgraded-array-element-types+ 'T)
(when (fast-subtypep type other-type)
(return other-type))))))
;;
;; This canonicalizes the array type into the form
;; ({COMPLEX-ARRAY | SIMPLE-ARRAY} {elt-type | '*} {'* | (['*]*)})
;;
;; ELT-TYPE is the upgraded element type of the input.
;;
(defun parse-array-type (input)
(declare (si::c-local))
(let* ((type input)
(name (pop type))
(elt-type (fast-upgraded-array-element-type (if type (pop type) '*)))
(dims (if type (pop type) '*)))
(when type
(error "Wrong array type designator ~S." input))
(cond ((numberp dims)
(unless (< -1 dims array-rank-limit)
(error "Wrong rank size array type ~S." input))
(setq dims (nthcdr (- array-rank-limit dims)
'#.(make-list array-rank-limit :initial-element '*))))
((consp dims)
(dolist (i dims)
(unless (or (eq i '*)
(and (integerp i) (< -1 i array-dimension-limit)))
(error "Wrong dimension size in array type ~S." input)))))
(values name elt-type dims)))
;;
;; This function checks whether the array type T1 is a subtype of the array
;; type T2.
;;
(defun array-type-<= (t1 t2)
(unless (and (eq (first t1) (first t2))
(eq (second t1) (second t2)))
(return-from array-type-<= nil))
(let ((dim (third t1))
(pat (third t2)))
(cond ((eq pat '*) t)
((eq dim '*) nil)
(t (do ((a dim (cdr a))
(b pat (cdr b)))
((or (endp a)
(endp b)
(not (or (eq (car b) '*)
(eql (car b) (car a)))))
(and (null a) (null b)))
)))))
(defun array-type-p (type)
(and (consp type)
(member (first type) '(COMPLEX-ARRAY SIMPLE-ARRAY))))
;;----------------------------------------------------------------------
;; INTERVALS:
;;
;; Arbitrary intervals may be defined as the union or intersection of
;; semi-infinite intervals, of the form (number-type b *), where B is
;; either a real number, a list with one real number or *.
;; Any other interval, may be defined using these. For instance
;; (INTEGER 0 2) = (AND (INTEGER 0 *) (NOT (INTEGER (2) *)))
;; (SHORT-FLOAT (0.2) (2)) = (AND (SHORT-FLOAT (0.2) *) (NOT (SHORT-FLOAT 2 *)))
(defun register-elementary-interval (type b)
(declare (si::c-local))
(setq type (list type b))
(or (find-registered-tag type #'equalp)
(multiple-value-bind (tag-super tag-sub)
(find-type-bounds type
#'(lambda (other-type)
(and (consp other-type)
(null (cddr other-type))))
#'(lambda (i1 i2)
(and (eq (first i1) (first i2))
(bounds-<= (second i2) (second i1))))
t)
(let ((tag (new-type-tag)))
(update-types (logandc2 tag-super tag-sub) tag)
(setq tag (logior tag tag-sub))
(push-type type tag)))))
(defun register-interval-type (interval)
(declare (si::c-local))
(let* ((i interval)
(type (pop i))
(low (if i (pop i) '*))
(high (if i (pop i) '*))
(tag-high (cond ((eq high '*)
0)
((eq type 'INTEGER)
(setq high (if (consp high)
(ceiling (first high))
(floor (1+ high))))
(register-elementary-interval type high))
((consp high)
(register-elementary-interval type (first high)))
(t
(register-elementary-interval type (list high)))))
(tag-low (register-elementary-interval type
(cond ((or (eq '* low) (not (eq type 'INTEGER)) (integerp low))
low)
((consp low)
(floor (1+ (first low))))
(t
(ceiling low)))))
(tag (logandc2 tag-low tag-high)))
(unless (eq high '*)
(push-type interval tag))
tag))
;; All comparisons between intervals operations may be defined in terms of
;;
;; (BOUNDS-<= b1 b2) and (BOUNDS-< b1 b2)
;;
;; The first one checks whether (REAL b2 *) is contained in (REAL b1 *). The
;; second one checks whether (REAL b2 *) is strictly contained in (REAL b1 *)
;; (i.e., (AND (REAL b1 *) (NOT (REAL b2 *))) is not empty).
;;
(defun bounds-<= (b1 b2)
(cond ((eq b1 '*) t)
((eq b2 '*) nil)
((consp b1)
(if (consp b2)
(<= (first b1) (first b2))
(< (first b1) b2)))
((consp b2)
(<= b1 (first b2)))
(t
(<= b1 b2))))
(defun bounds-< (b1 b2)
(cond ((eq b1 '*) (not (eq b2 '*)))
((eq b2 '*) nil)
((consp b1)
(if (consp b2)
(< (first b1) (first b2))
(< (first b1) b2)))
((consp b2)
(<= b1 (first b2)))
(t
(< b1 b2))))
;;----------------------------------------------------------------------
;; COMPLEX types. We do not need to register anything, because all
;; possibilities have been covered by the definitions above. We only have to
;; bring the type to canonical form, which is a union of all specialized
;; complex types that can store an element of the corresponding type.
;;
(defun canonical-complex-type (real-type)
(declare (si::c-local))
;; UPGRADE-COMPLEX-PART-TYPE will signal an error if REAL-TYPE
;; is not a subtype of REAL.
(unless (eq real-type '*)
(upgraded-complex-part-type real-type))
(or (find-registered-tag '(COMPLEX REAL))
(let ((tag (new-type-tag)))
(push-type '(COMPLEX REAL) tag)))
#+(or)
(case real-type
((SINGLE-FLOAT DOUBLE-FLOAT INTEGER RATIO #+long-float LONG-FLOAT)
(let ((tag (new-type-tag)))
(push-type `(COMPLEX ,real-type) tag)))
((RATIONAL) (canonical-type '(OR (COMPLEX INTEGER) (COMPLEX RATIO))))
((FLOAT) (canonical-type '(OR (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT)
#+long-float (COMPLEX LONG-FLOAT))))
((* NIL REAL) (canonical-type
'(OR (COMPLEX INTEGER) (COMPLEX RATIO)
(COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT)
#+long-float (COMPLEX LONG-FLOAT)
)))
(otherwise (canonical-complex-type (upgraded-complex-part-type real-type)))))
;;----------------------------------------------------------------------
;; CONS types. Only (CONS T T) and variants, as well as (CONS NIL *), etc
;; are strictly supported.
;;
(defun register-cons-type (&optional (car-type '*) (cdr-type '*))
;; The problem with the code below is that it does not suport infinite
;; recursion. Instead we just canonicalize everything to CONS, irrespective
;; of whether the arguments are valid types or not!
#+(or)
(canonical-type 'CONS)
(let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type)))
(cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type))))
(cond ((or (zerop car-tag) (zerop cdr-tag))
0)
((and (= car-tag -1) (= cdr-tag -1))
(canonical-type 'CONS))
(t
(throw '+canonical-type-failure+ 'CONS)))))
;;----------------------------------------------------------------------
;; FIND-BUILT-IN-TAG
;;
;; This function computes the tags for all builtin types. We used to
;; do this computation and save it. However, for most cases it seems
;; faster if we just repeat it every time we need it, because the list of
;; *elementary-types* is kept smaller and *highest-type-tag* may be just
;; a fixnum.
;;
;; Note 1: There is some redundancy between this and the built-in
;; classes definitions. REGISTER-CLASS knows this and calls
;; FIND-BUILT-IN-TAG, which has priority. This is because some built-in
;; classes are also interpreted as intervals, arrays, etc.
;;
;; Note 2: All built in types listed here have to be symbols.
;;
#+ecl-min
(defconstant +built-in-type-list+
'((SYMBOL)
(KEYWORD NIL SYMBOL)
(PACKAGE)
(COMPILED-FUNCTION)
(FUNCTION (OR COMPILED-FUNCTION GENERIC-FUNCTION))
(INTEGER (INTEGER * *))
(FIXNUM (INTEGER #.most-negative-fixnum #.most-positive-fixnum))
(BIGNUM (OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
(SINGLE-FLOAT (SINGLE-FLOAT * *))
(DOUBLE-FLOAT (DOUBLE-FLOAT * *))
#+long-float
(LONG-FLOAT (LONG-FLOAT * *))
(RATIO (RATIO * *))
(RATIONAL (OR INTEGER RATIO))
(FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT
#+long-float LONG-FLOAT))
(REAL (OR INTEGER SINGLE-FLOAT DOUBLE-FLOAT
#+long-float LONG-FLOAT RATIO))
(COMPLEX (COMPLEX REAL))
(NUMBER (OR REAL COMPLEX))
(CHARACTER)
#-unicode
(BASE-CHAR CHARACTER)
#+unicode
(BASE-CHAR NIL CHARACTER)
(STANDARD-CHAR NIL BASE-CHAR)
(CONS)
(NULL (MEMBER NIL))
(LIST (OR CONS (MEMBER NIL)))
(ARRAY (ARRAY * *))
(SIMPLE-ARRAY (SIMPLE-ARRAY * *))
(SIMPLE-VECTOR (SIMPLE-ARRAY T (*)))
(SIMPLE-BIT-VECTOR (SIMPLE-ARRAY BIT (*)))
(VECTOR (ARRAY * (*)))
(STRING (ARRAY CHARACTER (*)))
#+unicode
(BASE-STRING (ARRAY BASE-CHAR (*)))
(SIMPLE-STRING (SIMPLE-ARRAY CHARACTER (*)))
#+unicode
(SIMPLE-BASE-STRING (SIMPLE-ARRAY BASE-CHAR (*)))
(BIT-VECTOR (ARRAY BIT (*)))
(SEQUENCE (OR CONS (MEMBER NIL) (ARRAY * (*))))
(HASH-TABLE)
(PATHNAME)
(LOGICAL-PATHNAME NIL PATHNAME)
(BROADCAST-STREAM)
(CONCATENATED-STREAM)
(ECHO-STREAM)
(FILE-STREAM)
(STRING-STREAM)
(SYNONYM-STREAM)
(TWO-WAY-STREAM)
(EXT:SEQUENCE-STREAM)
(EXT:ANSI-STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM
FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM
EXT:SEQUENCE-STREAM
#+clos-streams GRAY:FUNDAMENTAL-STREAM))
(STREAM EXT:ANSI-STREAM)
(READTABLE)
#+threads (MP::PROCESS)
#+threads (MP::LOCK)
#+threads (MP::RWLOCK)
#+threads (MP::CONDITION-VARIABLE)
#+threads (MP::SEMAPHORE)
#+threads (MP::BARRIER)
#+threads (MP::MAILBOX)
#+ffi (FOREIGN-DATA)
#+sse2 (EXT:SSE-PACK (OR EXT:INT-SSE-PACK
EXT:FLOAT-SSE-PACK
EXT:DOUBLE-SSE-PACK))
#+sse2 (EXT:INT-SSE-PACK)
#+sse2 (EXT:FLOAT-SSE-PACK)
#+sse2 (EXT:DOUBLE-SSE-PACK)
(CODE-BLOCK)
))
(defconstant +built-in-types+
(ext:hash-table-fill
(make-hash-table :test 'eq :size 128)
'#.+built-in-type-list+))
(defun find-built-in-tag (name)
(declare (si::c-local))
(let (record)
(cond ((eq name T)
-1)
((eq (setf record (gethash name +built-in-types+ name))
name)
nil)
(t
(let* ((alias (pop record))
tag)
(if alias
(setq tag (canonical-type alias))
(let* ((strict-supertype (or (first record) 'T))
(strict-supertype-tag (canonical-type strict-supertype)))
(setq tag (new-type-tag))
(unless (eq strict-supertype 't)
(extend-type-tag tag strict-supertype-tag))))
(push-type name tag))))))
(defun extend-type-tag (tag minimal-supertype-tag)
(declare (si::c-local)
(ext:assume-no-errors))
(dolist (type *elementary-types*)
(let ((other-tag (cdr type)))
(when (zerop (logandc2 minimal-supertype-tag other-tag))
(setf (cdr type) (logior tag other-tag))))))
;;----------------------------------------------------------------------
;; CANONICALIZE (removed)
;;
;; This function takes a type tag and produces a more or less human
;; readable representation of the type in terms of elementary types,
;; intervals, arrays and classes.
;;
#+nil
(defun canonicalize (type)
(let ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(let ((tag (canonical-type type))
(out))
(setq tag (canonical-type type))
;;(print-types-database *elementary-types*)
;;(print-types-database *member-types*)
(dolist (i *member-types*)
(unless (zerop (logand (cdr i) tag))
(push (car i) out)))
(when out
(setq out `((MEMBER ,@out))))
(dolist (i *elementary-types*)
(unless (zerop (logand (cdr i) tag))
;;(print (list tag (cdr i) (logand tag (cdr i))))
(push (car i) out)))
(values tag `(OR ,@out)))))
;;----------------------------------------------------------------------
;; (CANONICAL-TYPE TYPE)
;;
;; This function registers all types mentioned in the given expression,
;; and outputs a code corresponding to the represented type. This
;; function has side effects: it destructively modifies the content of
;; *ELEMENTARY-TYPES* and *MEMBER-TYPES*.
;;
(defun canonical-type (type)
(declare (notinline clos::classp))
(cond ((find-registered-tag type))
((eq type 'T) -1)
((eq type 'NIL) 0)
((symbolp type)
(let ((expander (get-sysprop type 'DEFTYPE-DEFINITION)))
(cond (expander
(canonical-type (funcall expander)))
((find-built-in-tag type))
(t (let ((class (find-class type nil)))
(if class
(register-class class)
(throw '+canonical-type-failure+ nil)))))))
((consp type)
(case (first type)
(AND (apply #'logand (mapcar #'canonical-type (rest type))))
(OR (apply #'logior (mapcar #'canonical-type (rest type))))
(NOT (lognot (canonical-type (second type))))
((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type))))
(SATISFIES (register-satisfies-type type))
((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT)
(register-interval-type type))
((FLOAT)
(canonical-type `(OR (SINGLE-FLOAT ,@(rest type))
(DOUBLE-FLOAT ,@(rest type))
#+long-float
(LONG-FLOAT ,@(rest type)))))
((REAL)
(canonical-type `(OR (INTEGER ,@(rest type))
(RATIO ,@(rest type))
(SINGLE-FLOAT ,@(rest type))
(DOUBLE-FLOAT ,@(rest type))
#+long-float
(LONG-FLOAT ,@(rest type)))))
((RATIONAL)
(canonical-type `(OR (INTEGER ,@(rest type))
(RATIO ,@(rest type)))))
(COMPLEX
(or (find-built-in-tag type)
(canonical-complex-type (second type))))
(CONS (apply #'register-cons-type (rest type)))
(ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type)))
(register-array-type `(SIMPLE-ARRAY ,@(rest type)))))
((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type))
;;(FUNCTION (register-function-type type))
;;(VALUES (register-values-type type))
(FUNCTION (canonical-type 'FUNCTION))
(t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION)))
(if expander
(canonical-type (apply expander (rest type)))
(unless (assoc (first type) *elementary-types*)
(throw '+canonical-type-failure+ nil)))))))
((clos::classp type)
(register-class type))
((and (fboundp 'function-type-p) (function-type-p type))
(register-function-type type))
((and (fboundp 'values-type-p) (values-type-p type))
(register-values-type type))
(t
(error-type-specifier type))))
(defun safe-canonical-type (type)
(catch '+canonical-type-failure+
(canonical-type type)))
(defun fast-subtypep (t1 t2)
(declare (si::c-local))
(when (eq t1 t2)
(return-from fast-subtypep (values t t)))
(let* ((tag1 (safe-canonical-type t1))
(tag2 (safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(values (zerop (logandc2 (safe-canonical-type t1)
(safe-canonical-type t2)))
t))
#+nil
((null tag1)
(error "Unknown type specifier ~S." t1))
#+nil
((null tag2)
(error "Unknown type specifier ~S." t2))
(t
(values nil nil)))))
(defun subtypep (t1 t2 &optional env)
(declare (ignore env))
;; One easy case: types are equal
(when (eq t1 t2)
(return-from subtypep (values t t)))
;; Another easy case: types are classes.
(when (and (instancep t1) (instancep t2)
(clos::classp t1) (clos::classp t2))
(return-from subtypep (values (subclassp t1 t2) t)))
;; Finally, cached results.
(let* ((cache *subtypep-cache*)
(hash (truly-the (integer 0 255) (logand (hash-eql t1 t2) 255)))
(elt (aref cache hash)))
(when (and elt (eq (caar elt) t1) (eq (cdar elt) t2))
(setf elt (cdr elt))
(return-from subtypep (values (car elt) (cdr elt))))
(let* ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(multiple-value-bind (test confident)
(fast-subtypep t1 t2)
(setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
(values test confident)))))
(defun fast-type= (t1 t2)
(declare (si::c-local))
(when (eq t1 t2)
(return-from fast-type= (values t t)))
(let* ((tag1 (safe-canonical-type t1))
(tag2 (safe-canonical-type t2)))
(cond ((and (numberp tag1) (numberp tag2))
(values (= (safe-canonical-type t1) (safe-canonical-type t2))
t))
#+nil
((null tag1)
(error "Unknown type specifier ~S." t1))
#+nil
((null tag2)
(error "Unknown type specifier ~S." t2))
(t
(values nil nil)))))
(defun type= (t1 t2)
(let ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(fast-type= t1 t2)))