[403bac]: src / code / class.lisp Maximize Restore History

Download this file

class.lisp    1343 lines (1266 with data), 55.7 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
;;;; This file contains structures and functions for the maintenance of
;;;; basic information about defined types. Different object systems
;;;; can be supported simultaneously.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!KERNEL")
(!begin-collecting-cold-init-forms)
;;;; the CLASSOID structure
;;; The CLASSOID structure is a supertype of all classoid types. A
;;; CLASSOID is also a CTYPE structure as recognized by the type
;;; system. (FIXME: It's also a type specifier, though this might go
;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
;;; longer necessary)
(def!struct (classoid
(:make-load-form-fun classoid-make-load-form-fun)
(:include ctype
(class-info (type-class-or-lose 'classoid)))
(:constructor nil)
#-no-ansi-print-object
(:print-object
(lambda (class stream)
(let ((name (classoid-name class)))
(print-unreadable-object (class stream
:type t
:identity (not name))
(format stream
;; FIXME: Make sure that this prints
;; reasonably for anonymous classes.
"~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
name
(classoid-state class))))))
#-sb-xc-host (:pure nil))
;; the value to be returned by CLASSOID-NAME.
(name nil :type symbol)
;; the current layout for this class, or NIL if none assigned yet
(layout nil :type (or layout null))
;; How sure are we that this class won't be redefined?
;; :READ-ONLY = We are committed to not changing the effective
;; slots or superclasses.
;; :SEALED = We can't even add subclasses.
;; NIL = Anything could happen.
(state nil :type (member nil :read-only :sealed))
;; direct superclasses of this class
(direct-superclasses () :type list)
;; representation of all of the subclasses (direct or indirect) of
;; this class. This is NIL if no subclasses or not initalized yet;
;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
;; subclass layout that was in effect at the time the subclass was
;; created.
(subclasses nil :type (or null hash-table))
;; the PCL class (= CL:CLASS, but with a view to future flexibility
;; we don't just call it the CLASS slot) object for this class, or
;; NIL if none assigned yet
(pcl-class nil))
(defun classoid-make-load-form-fun (class)
(/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
(let ((name (classoid-name class)))
(unless (and name (eq (find-classoid name nil) class))
(/show "anonymous/undefined class case")
(error "can't use anonymous or undefined class as constant:~% ~S"
class))
`(locally
;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
;; class names which creates fast but non-cold-loadable,
;; non-compact code. In this context, we'd rather have compact,
;; cold-loadable code. -- WHN 19990928
(declare (notinline find-classoid))
(find-classoid ',name))))
;;;; basic LAYOUT stuff
;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
;;; in order to guarantee that several hash values can be added without
;;; overflowing into a bignum.
(def!constant layout-clos-hash-max (ash most-positive-fixnum -3)
#!+sb-doc
"the inclusive upper bound on LAYOUT-CLOS-HASH values")
;;; a list of conses, initialized by genesis
;;;
;;; In each cons, the car is the symbol naming the layout, and the
;;; cdr is the layout itself.
(defvar *!initial-layouts*)
;;; a table mapping class names to layouts for classes we have
;;; referenced but not yet loaded. This is initialized from an alist
;;; created by genesis describing the layouts that genesis created at
;;; cold-load time.
(defvar *forward-referenced-layouts*)
(!cold-init-forms
(setq *forward-referenced-layouts* (make-hash-table :test 'equal))
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(dolist (x *!initial-layouts*)
(setf (gethash (car x) *forward-referenced-layouts*)
(cdr x)))
(/show0 "done processing *!INITIAL-LAYOUTS*")))
;;; The LAYOUT structure is pointed to by the first cell of instance
;;; (or structure) objects. It represents what we need to know for
;;; type checking and garbage collection. Whenever a class is
;;; incompatibly redefined, a new layout is allocated. If two object's
;;; layouts are EQ, then they are exactly the same type.
;;;
;;; KLUDGE: The genesis code has raw offsets of slots in this
;;; structure hardwired into it. It would be good to rewrite that code
;;; so that it looks up those offsets in the compiler's tables, but
;;; for now if you change this structure, lucky you, you get to grovel
;;; over the genesis code by hand.:-( -- WHN 19990820
(def!struct (layout
;; KLUDGE: A special hack keeps this from being
;; called when building code for the
;; cross-compiler. See comments at the DEFUN for
;; this. -- WHN 19990914
(:make-load-form-fun #-sb-xc-host ignore-it
;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
;; time controls both the
;; build-the-cross-compiler behavior
;; and the run-the-cross-compiler
;; behavior. The value below only
;; works for build-the-cross-compiler.
;; There's a special hack in
;; EMIT-MAKE-LOAD-FORM which gives
;; effectively IGNORE-IT behavior for
;; LAYOUT at run-the-cross-compiler
;; time. It would be cleaner to
;; actually have an IGNORE-IT value
;; stored, but it's hard to see how to
;; do that concisely with the current
;; DEF!STRUCT setup. -- WHN 19990930
#+sb-xc-host
make-load-form-for-layout))
;; hash bits which should be set to constant pseudo-random values
;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see
;; LAYOUT-CLOS-HASH.
;;
;; FIXME: We should get our story straight on what the type of these
;; values is. (declared INDEX here, described as <=
;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
;;
;; KLUDGE: The fact that the slots here start at offset 1 is known
;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
;; in GENESIS.
(clos-hash-0 (random-layout-clos-hash) :type index)
(clos-hash-1 (random-layout-clos-hash) :type index)
(clos-hash-2 (random-layout-clos-hash) :type index)
(clos-hash-3 (random-layout-clos-hash) :type index)
(clos-hash-4 (random-layout-clos-hash) :type index)
(clos-hash-5 (random-layout-clos-hash) :type index)
(clos-hash-6 (random-layout-clos-hash) :type index)
(clos-hash-7 (random-layout-clos-hash) :type index)
;; the class that this is a layout for
(classoid (missing-arg) :type classoid)
;; The value of this slot can be:
;; * :UNINITIALIZED if not initialized yet;
;; * NIL if this is the up-to-date layout for a class; or
;; * T if this layout has been invalidated (by being replaced by
;; a new, more-up-to-date LAYOUT).
;; * something else (probably a list) if the class is a PCL wrapper
;; and PCL has made it invalid and made a note to itself about it
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
;; the layouts for all classes we inherit. If hierarchical, i.e. if
;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS,
;; so that each inherited layout appears at its expected depth,
;; i.e. at its LAYOUT-DEPTHOID value.
;;
;; Remaining elements are filled by the non-hierarchical layouts or,
;; if they would otherwise be empty, by copies of succeeding layouts.
(inherits #() :type simple-vector)
;; If inheritance is not hierarchical, this is -1. If inheritance is
;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
;; Note:
;; (1) This turns out to be a handy encoding for arithmetically
;; comparing deepness; it is generally useful to do a bare numeric
;; comparison of these depthoid values, and we hardly ever need to
;; test whether the values are negative or not.
;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
;; renamed because some of us find it confusing to call something
;; a depth when it isn't quite.
(depthoid -1 :type layout-depthoid)
;; the number of top level descriptor cells in each instance
(length 0 :type index)
;; If this layout has some kind of compiler meta-info, then this is
;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
(info nil)
;; This is true if objects of this class are never modified to
;; contain dynamic pointers in their slots or constant-like
;; substructure (and hence can be copied into read-only space by
;; PURIFY).
;;
;; KLUDGE: This slot is known to the C runtime support code.
(pure nil :type (member t nil 0)))
(def!method print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
(format stream
"for ~S~@[, INVALID=~S~]"
(layout-proper-name layout)
(layout-invalid layout))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun layout-proper-name (layout)
(classoid-proper-name (layout-classoid layout))))
;;;; support for the hash values used by CLOS when working with LAYOUTs
(def!constant layout-clos-hash-length 8)
#!-sb-fluid (declaim (inline layout-clos-hash))
(defun layout-clos-hash (layout i)
;; FIXME: Either this I should be declared to be `(MOD
;; ,LAYOUT-CLOS-HASH-LENGTH), or this is used in some inner loop
;; where we can't afford to check that kind of thing and therefore
;; should have some insane level of optimization. (This is true both
;; of this function and of the SETF function below.)
(declare (type layout layout) (type index i))
;; FIXME: LAYOUT slots should have type `(MOD ,LAYOUT-CLOS-HASH-MAX),
;; not INDEX.
(truly-the index (%instance-ref layout (1+ i))))
#!-sb-fluid (declaim (inline (setf layout-clos-hash)))
(defun (setf layout-clos-hash) (new-value layout i)
(declare (type layout layout) (type index new-value i))
(setf (%instance-ref layout (1+ i)) new-value))
;;; a generator for random values suitable for the CLOS-HASH slots of
;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
;;; pseudo-random values to come the same way in the target even when
;;; we make minor changes to the system, in order to reduce the
;;; mysteriousness of possible CLOS bugs.
(defvar *layout-clos-hash-random-state*)
(defun random-layout-clos-hash ()
;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
;; returning a strictly positive value. I copied it verbatim from
;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
;; dunno whether the hash values are really supposed to be 1-based.
;; They're declared as INDEX.. Or is this a hack to try to avoid
;; having to use bignum arithmetic? Or what? An explanation would be
;; nice.
(1+ (random layout-clos-hash-max
(if (boundp '*layout-clos-hash-random-state*)
*layout-clos-hash-random-state*
(setf *layout-clos-hash-random-state*
(make-random-state))))))
;;; If we can't find any existing layout, then we create a new one
;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
;;; used to immediately check for compatibility, but for
;;; cross-compilability reasons (i.e. convenience of using this
;;; function in a MAKE-LOAD-FORM expression) that functionality has
;;; been split off into INIT-OR-CHECK-LAYOUT.
(declaim (ftype (function (symbol) layout) find-layout))
(defun find-layout (name)
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout classoid))
(gethash name *forward-referenced-layouts*)
(setf (gethash name *forward-referenced-layouts*)
(make-layout :classoid (or classoid
(make-undefined-classoid name)))))))
;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
;;;
;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
;;; anything about the class", so if LAYOUT is initialized, any
;;; preexisting class slot value is OK, and if it's not initialized,
;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
;;; is no longer true, :UNINITIALIZED used instead.
(declaim (ftype (function (layout classoid index simple-vector layout-depthoid)
layout)
init-or-check-layout))
(defun init-or-check-layout (layout classoid length inherits depthoid)
(cond ((eq (layout-invalid layout) :uninitialized)
;; There was no layout before, we just created one which
;; we'll now initialize with our information.
(setf (layout-length layout) length
(layout-inherits layout) inherits
(layout-depthoid layout) depthoid
(layout-classoid layout) classoid
(layout-invalid layout) nil))
;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
;; clause is not needed?
((not *type-system-initialized*)
(setf (layout-classoid layout) classoid))
(t
;; There was an old layout already initialized with old
;; information, and we'll now check that old information
;; which was known with certainty is consistent with current
;; information which is known with certainty.
(check-layout layout classoid length inherits depthoid)))
layout)
;;; In code for the target Lisp, we don't use dump LAYOUTs using the
;;; standard load form mechanism, we use special fops instead, in
;;; order to make cold load come out right. But when we're building
;;; the cross-compiler, we can't do that because we don't have access
;;; to special non-ANSI low-level things like special fops, and we
;;; don't need to do that anyway because our code isn't going to be
;;; cold loaded, so we use the ordinary load form system.
;;;
;;; KLUDGE: A special hack causes this not to be called when we are
;;; building code for the target Lisp. It would be tidier to just not
;;; have it in place when we're building the target Lisp, but it
;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
;;; bit, so I punted. -- WHN 19990914
#+sb-xc-host
(defun make-load-form-for-layout (layout &optional env)
(declare (type layout layout))
(declare (ignore env))
(when (layout-invalid layout)
(compiler-error "can't dump reference to obsolete class: ~S"
(layout-classoid layout)))
(let ((name (classoid-name (layout-classoid layout))))
(unless name
(compiler-error "can't dump anonymous LAYOUT: ~S" layout))
;; Since LAYOUT refers to a class which refers back to the LAYOUT,
;; we have to do this in two stages, like the TREE-WITH-PARENT
;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
(values
;; "creation" form (which actually doesn't create a new LAYOUT if
;; there's a preexisting one with this name)
`(find-layout ',name)
;; "initialization" form (which actually doesn't initialize
;; preexisting LAYOUTs, just checks that they're consistent).
`(init-or-check-layout ',layout
',(layout-classoid layout)
',(layout-length layout)
',(layout-inherits layout)
',(layout-depthoid layout)))))
;;; If LAYOUT's slot values differ from the specified slot values in
;;; any interesting way, then give a warning and return T.
(declaim (ftype (function (simple-string
layout
simple-string
index
simple-vector
layout-depthoid))
redefine-layout-warning))
(defun redefine-layout-warning (old-context old-layout
context length inherits depthoid)
(declare (type layout old-layout) (type simple-string old-context context))
(let ((name (layout-proper-name old-layout)))
(or (let ((old-inherits (layout-inherits old-layout)))
(or (when (mismatch old-inherits
inherits
:key #'layout-proper-name)
(warn "change in superclasses of class ~S:~% ~
~A superclasses: ~S~% ~
~A superclasses: ~S"
name
old-context
(map 'list #'layout-proper-name old-inherits)
context
(map 'list #'layout-proper-name inherits))
t)
(let ((diff (mismatch old-inherits inherits)))
(when diff
(warn
"in class ~S:~% ~
~:(~A~) definition of superclass ~S is incompatible with~% ~
~A definition."
name
old-context
(layout-proper-name (svref old-inherits diff))
context)
t))))
(let ((old-length (layout-length old-layout)))
(unless (= old-length length)
(warn "change in instance length of class ~S:~% ~
~A length: ~W~% ~
~A length: ~W"
name
old-context old-length
context length)
t))
(unless (= (layout-depthoid old-layout) depthoid)
(warn "change in the inheritance structure of class ~S~% ~
between the ~A definition and the ~A definition"
name old-context context)
t))))
;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
;;; INHERITS, and DEPTHOID.
(declaim (ftype (function
(layout classoid index simple-vector layout-depthoid))
check-layout))
(defun check-layout (layout classoid length inherits depthoid)
(aver (eq (layout-classoid layout) classoid))
(when (redefine-layout-warning "current" layout
"compile time" length inherits depthoid)
;; Classic CMU CL had more options here. There are several reasons
;; why they might want more options which are less appropriate for
;; us: (1) It's hard to fit the classic CMU CL flexible approach
;; into the ANSI-style MAKE-LOAD-FORM system, and having a
;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
;; We have CLOS now, and if you want to be able to flexibly
;; redefine classes without restarting the system, it'd make sense
;; to use that, so supporting complexity in order to allow
;; modifying DEFSTRUCTs without restarting the system is a low
;; priority. (3) We now have the ability to rebuild the SBCL
;; system from scratch, so we no longer need this functionality in
;; order to maintain the SBCL system by modifying running images.
(error "The class ~S was not changed, and there's no guarantee that~@
the loaded code (which expected another layout) will work."
(layout-proper-name layout)))
(values))
;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
;;; single function call
;;;
;;; Used by the loader to forward-reference layouts for classes whose
;;; definitions may not have been loaded yet. This allows type tests
;;; to be loaded when the type definition hasn't been loaded yet.
(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
find-and-init-or-check-layout))
(defun find-and-init-or-check-layout (name length inherits depthoid)
(let ((layout (find-layout name)))
(init-or-check-layout layout
(or (find-classoid name nil)
(make-undefined-classoid name))
length
inherits
depthoid)))
;;; Record LAYOUT as the layout for its class, adding it as a subtype
;;; of all superclasses. This is the operation that "installs" a
;;; layout for a class in the type system, clobbering any old layout.
;;; However, this does not modify the class namespace; that is a
;;; separate operation (think anonymous classes.)
;;; -- If INVALIDATE, then all the layouts for any old definition
;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
;;; destructively modified to hold the same type information.
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun register-layout (layout &key (invalidate t) destruct-layout)
(declare (type layout layout) (type (or layout null) destruct-layout))
(let* ((classoid (layout-classoid layout))
(classoid-layout (classoid-layout classoid))
(subclasses (classoid-subclasses classoid)))
;; Attempting to register ourselves with a temporary undefined
;; class placeholder is almost certainly a programmer error. (I
;; should know, I did it.) -- WHN 19990927
(aver (not (undefined-classoid-p classoid)))
;; This assertion dates from classic CMU CL. The rationale is
;; probably that calling REGISTER-LAYOUT more than once for the
;; same LAYOUT is almost certainly a programmer error.
(aver (not (eq classoid-layout layout)))
;; Figure out what classes are affected by the change, and issue
;; appropriate warnings and invalidations.
(when classoid-layout
(modify-classoid classoid)
(when subclasses
(dohash (subclass subclass-layout subclasses)
(modify-classoid subclass)
(when invalidate
(invalidate-layout subclass-layout))))
(when invalidate
(invalidate-layout classoid-layout)
(setf (classoid-subclasses classoid) nil)))
(if destruct-layout
(setf (layout-invalid destruct-layout) nil
(layout-inherits destruct-layout) (layout-inherits layout)
(layout-depthoid destruct-layout)(layout-depthoid layout)
(layout-length destruct-layout) (layout-length layout)
(layout-info destruct-layout) (layout-info layout)
(classoid-layout classoid) destruct-layout)
(setf (layout-invalid layout) nil
(classoid-layout classoid) layout))
(let ((inherits (layout-inherits layout)))
(dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
(let* ((super (layout-classoid (svref inherits i)))
(subclasses (or (classoid-subclasses super)
(setf (classoid-subclasses super)
(make-hash-table :test 'eq)))))
(when (and (eq (classoid-state super) :sealed)
(not (gethash classoid subclasses)))
(warn "unsealing sealed class ~S in order to subclass it"
(classoid-name super))
(setf (classoid-state super) :read-only))
(setf (gethash classoid subclasses)
(or destruct-layout layout))))))
(values))
); EVAL-WHEN
;;; Arrange the inherited layouts to appear at their expected depth,
;;; ensuring that hierarchical type tests succeed. Layouts with
;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
;;; layouts are placed in remaining elements. Then, any still-empty
;;; elements are filled with their successors, ensuring that each
;;; element contains a valid layout.
;;;
;;; This reordering may destroy CPL ordering, so the inherits should
;;; not be read as being in CPL order.
(defun order-layout-inherits (layouts)
(declare (simple-vector layouts))
(let ((length (length layouts))
(max-depth -1))
(dotimes (i length)
(let ((depth (layout-depthoid (svref layouts i))))
(when (> depth max-depth)
(setf max-depth depth))))
(let* ((new-length (max (1+ max-depth) length))
;; KLUDGE: 0 here is the "uninitialized" element. We need
;; to specify it explicitly for portability purposes, as
;; elements can be read before being set [ see below, "(EQL
;; OLD-LAYOUT 0)" ]. -- CSR, 2002-04-20
(inherits (make-array new-length :initial-element 0)))
(dotimes (i length)
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(unless (eql depth -1)
(let ((old-layout (svref inherits depth)))
(unless (or (eql old-layout 0) (eq old-layout layout))
(error "layout depth conflict: ~S~%" layouts)))
(setf (svref inherits depth) layout))))
(do ((i 0 (1+ i))
(j 0))
((>= i length))
(declare (type index i j))
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(when (eql depth -1)
(loop (when (eql (svref inherits j) 0)
(return))
(incf j))
(setf (svref inherits j) layout))))
(do ((i (1- new-length) (1- i)))
((< i 0))
(declare (type fixnum i))
(when (eql (svref inherits i) 0)
(setf (svref inherits i) (svref inherits (1+ i)))))
inherits)))
;;;; class precedence lists
;;; Topologically sort the list of objects to meet a set of ordering
;;; constraints given by pairs (A . B) constraining A to precede B.
;;; When there are multiple objects to choose, the tie-breaker
;;; function is called with both the list of object to choose from and
;;; the reverse ordering built so far.
(defun topological-sort (objects constraints tie-breaker)
(declare (list objects constraints)
(function tie-breaker))
(let ((obj-info (make-hash-table :size (length objects)))
(free-objs nil)
(result nil))
(dolist (constraint constraints)
(let ((obj1 (car constraint))
(obj2 (cdr constraint)))
(let ((info2 (gethash obj2 obj-info)))
(if info2
(incf (first info2))
(setf (gethash obj2 obj-info) (list 1))))
(let ((info1 (gethash obj1 obj-info)))
(if info1
(push obj2 (rest info1))
(setf (gethash obj1 obj-info) (list 0 obj2))))))
(dolist (obj objects)
(let ((info (gethash obj obj-info)))
(when (or (not info) (zerop (first info)))
(push obj free-objs))))
(loop
(flet ((next-result (obj)
(push obj result)
(dolist (successor (rest (gethash obj obj-info)))
(let* ((successor-info (gethash successor obj-info))
(count (1- (first successor-info))))
(setf (first successor-info) count)
(when (zerop count)
(push successor free-objs))))))
(cond ((endp free-objs)
(dohash (obj info obj-info)
(unless (zerop (first info))
(error "Topological sort failed due to constraint on ~S."
obj)))
(return (nreverse result)))
((endp (rest free-objs))
(next-result (pop free-objs)))
(t
(let ((obj (funcall tie-breaker free-objs result)))
(setf free-objs (remove obj free-objs))
(next-result obj))))))))
;;; standard class precedence list computation
(defun std-compute-class-precedence-list (class)
(let ((classes nil)
(constraints nil))
(labels ((note-class (class)
(unless (member class classes)
(push class classes)
(let ((superclasses (classoid-direct-superclasses class)))
(do ((prev class)
(rest superclasses (rest rest)))
((endp rest))
(let ((next (first rest)))
(push (cons prev next) constraints)
(setf prev next)))
(dolist (class superclasses)
(note-class class)))))
(std-cpl-tie-breaker (free-classes rev-cpl)
(dolist (class rev-cpl (first free-classes))
(let* ((superclasses (classoid-direct-superclasses class))
(intersection (intersection free-classes
superclasses)))
(when intersection
(return (first intersection)))))))
(note-class class)
(topological-sort classes constraints #'std-cpl-tie-breaker))))
;;;; object types to represent classes
;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
;;; referenced layouts. Users should never see them.
(def!struct (undefined-classoid
(:include classoid)
(:constructor make-undefined-classoid (name))))
;;; BUILT-IN-CLASS is used to represent the standard classes that
;;; aren't defined with DEFSTRUCT and other specially implemented
;;; primitive types whose only attribute is their name.
;;;
;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
;;; are effectively DEFTYPE'd to some other type (usually a union of
;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
;;; This translation is done when type specifiers are parsed. Type
;;; system operations (union, subtypep, etc.) should never encounter
;;; translated classes, only their translation.
(def!struct (built-in-classoid (:include classoid)
(:constructor make-built-in-classoid))
;; the type we translate to on parsing. If NIL, then this class
;; stands on its own; or it can be set to :INITIALIZING for a period
;; during cold-load.
(translation nil :type (or ctype (member nil :initializing))))
;;; FIXME: In CMU CL, this was a class with a print function, but not
;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
;;; we let CLOS handle our print functions, so that is no longer needed.
;;; Is there any need for this class any more?
(def!struct (slot-classoid (:include classoid)
(:constructor nil)))
;;; STRUCTURE-CLASS represents what we need to know about structure
;;; classes. Non-structure "typed" defstructs are a special case, and
;;; don't have a corresponding class.
(def!struct (basic-structure-classoid (:include slot-classoid)
(:constructor nil)))
(def!struct (structure-classoid (:include basic-structure-classoid)
(:constructor make-structure-classoid))
;; If true, a default keyword constructor for this structure.
(constructor nil :type (or function null)))
;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
;;; structures, which are used to implement generic functions.
(def!struct (funcallable-structure-classoid
(:include basic-structure-classoid)
(:constructor make-funcallable-structure-classoid)))
;;;; classoid namespace
;;; We use an indirection to allow forward referencing of class
;;; definitions with load-time resolution.
(def!struct (classoid-cell
(:constructor make-classoid-cell (name &optional classoid))
(:make-load-form-fun (lambda (c)
`(find-classoid-cell
',(classoid-cell-name c))))
#-no-ansi-print-object
(:print-object (lambda (s stream)
(print-unreadable-object (s stream :type t)
(prin1 (classoid-cell-name s) stream)))))
;; Name of class we expect to find.
(name nil :type symbol :read-only t)
;; Class or NIL if not yet defined.
(classoid nil :type (or classoid null)))
(defun find-classoid-cell (name)
(or (info :type :classoid name)
(setf (info :type :classoid name)
(make-classoid-cell name))))
;;; FIXME: When the system is stable, this DECLAIM FTYPE should
;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv)))
find-classoid))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun find-classoid (name &optional (errorp t) environment)
#!+sb-doc
"Return the class with the specified NAME. If ERRORP is false, then NIL is
returned when no such class exists."
(declare (type symbol name) (ignore environment))
(let ((res (classoid-cell-classoid (find-classoid-cell name))))
(if (or res (not errorp))
res
(error "class not yet defined:~% ~S" name))))
(defun (setf find-classoid) (new-value name)
#-sb-xc (declare (type (or null classoid) new-value))
(cond
((null new-value)
(ecase (info :type :kind name)
((nil))
(:defined)
(:primitive
(error "attempt to redefine :PRIMITIVE type: ~S" name))
((:forthcoming-defclass-type :instance)
(setf (info :type :kind name) nil
(info :type :classoid name) nil
(info :type :documentation name) nil
(info :type :compiler-layout name) nil))))
(t
(ecase (info :type :kind name)
((nil))
(:forthcoming-defclass-type
;; XXX Currently, nothing needs to be done in this
;; case. Later, when PCL is integrated tighter into SBCL, this
;; might need more work.
nil)
(:instance
;; KLUDGE: The reason these clauses aren't directly parallel
;; is that we need to use the internal CLASSOID structure
;; ourselves, because we don't have CLASSes to work with until
;; PCL is built. In the host, CLASSes have an approximately
;; one-to-one correspondence with the target CLASSOIDs (as
;; well as with the target CLASSes, modulo potential
;; differences with respect to conditions).
#+sb-xc-host
(let ((old (class-of (find-classoid name)))
(new (class-of new-value)))
(unless (eq old new)
(bug "trying to change the metaclass of ~S from ~S to ~S in the ~
cross-compiler."
name (class-name old) (class-name new))))
#-sb-xc-host
(let ((old (classoid-of (find-classoid name)))
(new (classoid-of new-value)))
(unless (eq old new)
(warn "changing meta-class of ~S from ~S to ~S"
name (classoid-name old) (classoid-name new)))))
(:primitive
(error "illegal to redefine standard type ~S" name))
(:defined
(warn "redefining DEFTYPE type to be a class: ~S" name)
(setf (info :type :expander name) nil)))
(remhash name *forward-referenced-layouts*)
(%note-type-defined name)
(setf (info :type :kind name) :instance)
(setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
(unless (eq (info :type :compiler-layout name)
(classoid-layout new-value))
(setf (info :type :compiler-layout name) (classoid-layout new-value)))))
new-value)
) ; EVAL-WHEN
;;; Called when we are about to define NAME as a class meeting some
;;; predicate (such as a meta-class type test.) The first result is
;;; always of the desired class. The second result is any existing
;;; LAYOUT for this name.
(defun insured-find-classoid (name predicate constructor)
(declare (type function predicate constructor))
(let* ((old (find-classoid name nil))
(res (if (and old (funcall predicate old))
old
(funcall constructor :name name)))
(found (or (gethash name *forward-referenced-layouts*)
(when old (classoid-layout old)))))
(when found
(setf (layout-classoid found) res))
(values res found)))
;;; If the class has a proper name, return the name, otherwise return
;;; the class.
(defun classoid-proper-name (class)
#-sb-xc (declare (type classoid class))
(let ((name (classoid-name class)))
(if (and name (eq (find-classoid name nil) class))
name
class)))
;;;; CLASS type operations
(!define-type-class classoid)
;;; Simple methods for TYPE= and SUBTYPEP should never be called when
;;; the two classes are equal, since there are EQ checks in those
;;; operations.
(!define-type-method (classoid :simple-=) (type1 type2)
(aver (not (eq type1 type2)))
(values nil t))
(!define-type-method (classoid :simple-subtypep) (class1 class2)
(aver (not (eq class1 class2)))
(let ((subclasses (classoid-subclasses class2)))
(if (and subclasses (gethash class1 subclasses))
(values t t)
(values nil t))))
;;; When finding the intersection of a sealed class and some other
;;; class (not hierarchically related) the intersection is the union
;;; of the currently shared subclasses.
(defun sealed-class-intersection2 (sealed other)
(declare (type classoid sealed other))
(let ((s-sub (classoid-subclasses sealed))
(o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
(dohash (subclass layout s-sub)
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
(res))
*empty-type*)))
(!define-type-method (classoid :simple-intersection2) (class1 class2)
(declare (type classoid class1 class2))
(cond ((eq class1 class2)
class1)
;; If one is a subclass of the other, then that is the
;; intersection.
((let ((subclasses (classoid-subclasses class2)))
(and subclasses (gethash class1 subclasses)))
class1)
((let ((subclasses (classoid-subclasses class1)))
(and subclasses (gethash class2 subclasses)))
class2)
;; Otherwise, we can't in general be sure that the
;; intersection is empty, since a subclass of both might be
;; defined. But we can eliminate it for some special cases.
((or (basic-structure-classoid-p class1)
(basic-structure-classoid-p class2))
;; No subclass of both can be defined.
*empty-type*)
((eq (classoid-state class1) :sealed)
;; checking whether a subclass of both can be defined:
(sealed-class-intersection2 class1 class2))
((eq (classoid-state class2) :sealed)
;; checking whether a subclass of both can be defined:
(sealed-class-intersection2 class2 class1))
(t
;; uncertain, since a subclass of both might be defined
nil)))
;;; KLUDGE: we need this because of the need to represent
;;; intersections of two classes, even when empty at a given time, as
;;; uncanonicalized intersections because of the possibility of later
;;; defining a subclass of both classes. The necessity for changing
;;; the default return value from SUBTYPEP to NIL, T if no alternate
;;; method is present comes about because, unlike the other places we
;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
;;; like, classes are in their own hierarchy with no possibility of
;;; mixtures with other type classes.
(!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
(if (and (intersection-type-p type1)
(> (count-if #'classoid-p (intersection-type-types type1)) 1))
(values nil nil)
(invoke-complex-subtypep-arg1-method type1 class2 nil t)))
(!define-type-method (classoid :unparse) (type)
(classoid-proper-name type))
;;;; PCL stuff
(def!struct (std-classoid (:include classoid)
(:constructor nil)))
(def!struct (standard-classoid (:include std-classoid)
(:constructor make-standard-classoid)))
(def!struct (random-pcl-classoid (:include std-classoid)
(:constructor make-random-pcl-classoid)))
;;;; built-in classes
;;; The BUILT-IN-CLASSES list is a data structure which configures the
;;; creation of all the built-in classes. It contains all the info
;;; that we need to maintain the mapping between classes, compile-time
;;; types and run-time type codes. These options are defined:
;;;
;;; :TRANSLATION (default none)
;;; When this class is "parsed" as a type specifier, it is
;;; translated into the specified internal type representation,
;;; rather than being left as a class. This is used for types
;;; which we want to canonicalize to some other kind of type
;;; object because in general we want to be able to include more
;;; information than just the class (e.g. for numeric types.)
;;;
;;; :ENUMERABLE (default NIL)
;;; The value of the :ENUMERABLE slot in the created class.
;;; Meaningless in translated classes.
;;;
;;; :STATE (default :SEALED)
;;; The value of CLASS-STATE which we want on completion,
;;; indicating whether subclasses can be created at run-time.
;;;
;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
;;; True if we can assign this class a unique inheritance depth.
;;;
;;; :CODES (default none)
;;; Run-time type codes which should be translated back to this
;;; class by CLASS-OF. Unspecified for abstract classes.
;;;
;;; :INHERITS (default this class and T)
;;; The class-precedence list for this class, with this class and
;;; T implicit.
;;;
;;; :DIRECT-SUPERCLASSES (default to head of CPL)
;;; List of the direct superclasses of this class.
;;;
;;; FIXME: This doesn't seem to be needed after cold init (and so can
;;; probably be uninterned at the end of cold init).
(defvar *built-in-classes*)
(!cold-init-forms
(/show0 "setting *BUILT-IN-CLASSES*")
(setq
*built-in-classes*
'((t :state :read-only :translation t)
(character :enumerable t :translation base-char)
(base-char :enumerable t
:inherits (character)
:codes (#.sb!vm:base-char-widetag))
(symbol :codes (#.sb!vm:symbol-header-widetag))
(instance :state :read-only)
(system-area-pointer :codes (#.sb!vm:sap-widetag))
(weak-pointer :codes (#.sb!vm:weak-pointer-widetag))
(code-component :codes (#.sb!vm:code-header-widetag))
(lra :codes (#.sb!vm:return-pc-header-widetag))
(fdefn :codes (#.sb!vm:fdefn-widetag))
(random-class) ; used for unknown type codes
(function
:codes (#.sb!vm:closure-header-widetag
#.sb!vm:simple-fun-header-widetag)
:state :read-only)
(funcallable-instance
:inherits (function)
:state :read-only)
(number :translation number)
(complex
:translation complex
:inherits (number)
:codes (#.sb!vm:complex-widetag))
(complex-single-float
:translation (complex single-float)
:inherits (complex number)
:codes (#.sb!vm:complex-single-float-widetag))
(complex-double-float
:translation (complex double-float)
:inherits (complex number)
:codes (#.sb!vm:complex-double-float-widetag))
#!+long-float
(complex-long-float
:translation (complex long-float)
:inherits (complex number)
:codes (#.sb!vm:complex-long-float-widetag))
(real :translation real :inherits (number))
(float
:translation float
:inherits (real number))
(single-float
:translation single-float
:inherits (float real number)
:codes (#.sb!vm:single-float-widetag))
(double-float
:translation double-float
:inherits (float real number)
:codes (#.sb!vm:double-float-widetag))
#!+long-float
(long-float
:translation long-float
:inherits (float real number)
:codes (#.sb!vm:long-float-widetag))
(rational
:translation rational
:inherits (real number))
(ratio
:translation (and rational (not integer))
:inherits (rational real number)
:codes (#.sb!vm:ratio-widetag))
(integer
:translation integer
:inherits (rational real number))
(fixnum
:translation (integer #.sb!xc:most-negative-fixnum
#.sb!xc:most-positive-fixnum)
:inherits (integer rational real number)
:codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
(bignum
:translation (and integer (not fixnum))
:inherits (integer rational real number)
:codes (#.sb!vm:bignum-widetag))
(array :translation array :codes (#.sb!vm:complex-array-widetag)
:hierarchical-p nil)
(simple-array
:translation simple-array :codes (#.sb!vm:simple-array-widetag)
:inherits (array))
(sequence
:translation (or cons (member nil) vector))
(vector
:translation vector :codes (#.sb!vm:complex-vector-widetag)
:direct-superclasses (array sequence)
:inherits (array sequence))
(simple-vector
:translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(bit-vector
:translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
:inherits (vector array sequence))
(simple-bit-vector
:translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
:direct-superclasses (bit-vector simple-array)
:inherits (bit-vector vector simple-array
array sequence))
(simple-array-unsigned-byte-2
:translation (simple-array (unsigned-byte 2) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-4
:translation (simple-array (unsigned-byte 4) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-8
:translation (simple-array (unsigned-byte 8) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-16
:translation (simple-array (unsigned-byte 16) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-unsigned-byte-32
:translation (simple-array (unsigned-byte 32) (*))
:codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-signed-byte-8
:translation (simple-array (signed-byte 8) (*))
:codes (#.sb!vm:simple-array-signed-byte-8-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-signed-byte-16
:translation (simple-array (signed-byte 16) (*))
:codes (#.sb!vm:simple-array-signed-byte-16-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-signed-byte-30
:translation (simple-array (signed-byte 30) (*))
:codes (#.sb!vm:simple-array-signed-byte-30-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-signed-byte-32
:translation (simple-array (signed-byte 32) (*))
:codes (#.sb!vm:simple-array-signed-byte-32-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-single-float
:translation (simple-array single-float (*))
:codes (#.sb!vm:simple-array-single-float-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-double-float
:translation (simple-array double-float (*))
:codes (#.sb!vm:simple-array-double-float-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
#!+long-float
(simple-array-long-float
:translation (simple-array long-float (*))
:codes (#.sb!vm:simple-array-long-float-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-complex-single-float
:translation (simple-array (complex single-float) (*))
:codes (#.sb!vm:simple-array-complex-single-float-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(simple-array-complex-double-float
:translation (simple-array (complex double-float) (*))
:codes (#.sb!vm:simple-array-complex-double-float-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
#!+long-float
(simple-array-complex-long-float
:translation (simple-array (complex long-float) (*))
:codes (#.sb!vm:simple-array-complex-long-float-widetag)
:direct-superclasses (vector simple-array)
:inherits (vector simple-array array sequence))
(string
:translation string
:direct-superclasses (vector)
:inherits (vector array sequence))
(simple-string
:translation simple-string
:direct-superclasses (string simple-array)
:inherits (string vector simple-array array sequence))
(vector-nil
;; FIXME: Should this be (AND (VECTOR NIL) (NOT (SIMPLE-ARRAY NIL (*))))?
:translation (vector nil)
:codes (#.sb!vm:complex-vector-nil-widetag)
:direct-superclasses (string)
:inherits (string vector array sequence))
(simple-array-nil
:translation (simple-array nil (*))
:codes (#.sb!vm:simple-array-nil-widetag)
:direct-superclasses (vector-nil simple-string)
:inherits (vector-nil simple-string string vector simple-array array sequence))
(base-string
:translation base-string
:codes (#.sb!vm:complex-base-string-widetag)
:direct-superclasses (string)
:inherits (string vector array sequence))
(simple-base-string
:translation simple-base-string
:codes (#.sb!vm:simple-base-string-widetag)
:direct-superclasses (base-string simple-string)
:inherits (base-string simple-string string vector simple-array
array sequence))
(list
:translation (or cons (member nil))
:inherits (sequence))
(cons
:codes (#.sb!vm:list-pointer-lowtag)
:translation cons
:inherits (list sequence))
(null
:translation (member nil)
:inherits (symbol list sequence)
:direct-superclasses (symbol list))
(stream
:state :read-only
:depth 3
:inherits (instance)))))
;;; See also src/code/class-init.lisp where we finish setting up the
;;; translations for built-in types.
(!cold-init-forms
(dolist (x *built-in-classes*)
#-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
(destructuring-bind
(name &key
(translation nil trans-p)
inherits
codes
enumerable
state
depth
(hierarchical-p t) ; might be modified below
(direct-superclasses (if inherits
(list (car inherits))
'(t))))
x
(declare (ignore codes state translation))
(let ((inherits-list (if (eq name t)
()
(cons t (reverse inherits))))
(classoid (make-built-in-classoid
:enumerable enumerable
:name name
:translation (if trans-p :initializing nil)
:direct-superclasses
(if (eq name t)
nil
(mapcar #'find-classoid direct-superclasses)))))
(setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
(classoid-cell-classoid (find-classoid-cell name)) classoid)
(unless trans-p
(setf (info :type :builtin name) classoid))
(let* ((inherits-vector
(map 'simple-vector
(lambda (x)
(let ((super-layout
(classoid-layout (find-classoid x))))
(when (minusp (layout-depthoid super-layout))
(setf hierarchical-p nil))
super-layout))
inherits-list))
(depthoid (if hierarchical-p
(or depth (length inherits-vector))
-1)))
(register-layout
(find-and-init-or-check-layout name
0
inherits-vector
depthoid)
:invalidate nil)))))
(/show0 "done with loop over *BUILT-IN-CLASSES*"))
;;; Define temporary PCL STANDARD-CLASSes. These will be set up
;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
;;; is loaded and the class defined.
(!cold-init-forms
(/show0 "about to define temporary STANDARD-CLASSes")
(dolist (x '(;; Why is STREAM duplicated in this list? Because, when
;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
;; a vector containing the elements of the list below,
;; i.e. '(T INSTANCE STREAM STREAM), is created, and
;; this is what the function ORDER-LAYOUT-INHERITS
;; would do, too.
;;
;; So, the purpose is to guarantee a valid layout for
;; the FUNDAMENTAL-STREAM class, matching what
;; ORDER-LAYOUT-INHERITS would do.
;; ORDER-LAYOUT-INHERITS would place STREAM at index 3
;; in the INHERITS(-VECTOR). Index 2 would not be
;; filled, so STREAM is duplicated there (as
;; ORDER-LAYOUTS-INHERITS would do). Maybe the
;; duplicate definition could be removed (removing a
;; STREAM element), because FUNDAMENTAL-STREAM is
;; redefined after PCL is set up, anyway. But to play
;; it safely, we define the class with a valid INHERITS
;; vector.
(fundamental-stream (t instance stream stream))))
(/show0 "defining temporary STANDARD-CLASS")
(let* ((name (first x))
(inherits-list (second x))
(classoid (make-standard-classoid :name name))
(classoid-cell (find-classoid-cell name)))
;; Needed to open-code the MAP, below
(declare (type list inherits-list))
(setf (classoid-cell-classoid classoid-cell) classoid
(info :type :classoid name) classoid-cell
(info :type :kind name) :instance)
(let ((inherits (map 'simple-vector
(lambda (x)
(classoid-layout (find-classoid x)))
inherits-list)))
#-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
(register-layout (find-and-init-or-check-layout name 0 inherits -1)
:invalidate nil))))
(/show0 "done defining temporary STANDARD-CLASSes"))
;;; Now that we have set up the class heterarchy, seal the sealed
;;; classes. This must be done after the subclasses have been set up.
(!cold-init-forms
(dolist (x *built-in-classes*)
(destructuring-bind (name &key (state :sealed) &allow-other-keys) x
(setf (classoid-state (find-classoid name)) state))))
;;;; class definition/redefinition
;;; This is to be called whenever we are altering a class.
(defun modify-classoid (classoid)
(clear-type-caches)
(when (member (classoid-state classoid) '(:read-only :frozen))
;; FIXME: This should probably be CERROR.
(warn "making ~(~A~) class ~S writable"
(classoid-state classoid)
(classoid-name classoid))
(setf (classoid-state classoid) nil)))
;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
;;; structure type tests to fail. Remove class from all superclasses
;;; too (might not be registered, so might not be in subclasses of the
;;; nominal superclasses.)
(defun invalidate-layout (layout)
(declare (type layout layout))
(setf (layout-invalid layout) t
(layout-depthoid layout) -1)
(let ((inherits (layout-inherits layout))
(classoid (layout-classoid layout)))
(modify-classoid classoid)
(dotimes (i (length inherits)) ; FIXME: DOVECTOR
(let* ((super (svref inherits i))
(subs (classoid-subclasses (layout-classoid super))))
(when subs
(remhash classoid subs)))))
(values))
;;;; cold loading initializations
;;; FIXME: It would be good to arrange for this to be called when the
;;; cross-compiler is being built, not just when the target Lisp is
;;; being cold loaded. Perhaps this could be moved to its own file
;;; late in the build-order.lisp-expr sequence, and be put in
;;; !COLD-INIT-FORMS there?
(defun !class-finalize ()
(dohash (name layout *forward-referenced-layouts*)
(let ((class (find-classoid name nil)))
(cond ((not class)
(setf (layout-classoid layout) (make-undefined-classoid name)))
((eq (classoid-layout class) layout)
(remhash name *forward-referenced-layouts*))
(t
;; FIXME: ERROR?
(warn "something strange with forward layout for ~S:~% ~S"
name
layout))))))
;;; a vector that maps type codes to layouts, used for quickly finding
;;; the layouts of built-in classes
(defvar *built-in-class-codes*) ; initialized in cold load
(declaim (type simple-vector *built-in-class-codes*))
(!cold-init-forms
#-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
(setq *built-in-class-codes*
(let* ((initial-element
(locally
;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
;; constant class names which creates fast but
;; non-cold-loadable, non-compact code. In this
;; context, we'd rather have compact, cold-loadable
;; code. -- WHN 19990928
(declare (notinline find-classoid))
(classoid-layout (find-classoid 'random-class))))
(res (make-array 256 :initial-element initial-element)))
(dolist (x *built-in-classes* res)
(destructuring-bind (name &key codes &allow-other-keys)
x
(let ((layout (classoid-layout (find-classoid name))))
(dolist (code codes)
(setf (svref res code) layout)))))))
#-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
(!defun-from-collected-cold-init-forms !classes-cold-init)