[ea1220]: src / pcl / std-class.lisp Maximize Restore History

Download this file

std-class.lisp    1522 lines (1372 with data), 61.1 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
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; This software is derived from software originally released by Xerox
;;;; Corporation. Copyright and release statements follow. Later modifications
;;;; to the software are in the public domain and are provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for more
;;;; information.
;;;; copyright information from original PCL sources:
;;;;
;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;;; All rights reserved.
;;;;
;;;; Use and copying of this software and preparation of derivative works based
;;;; upon this software are permitted. Any distribution of this software or
;;;; derivative works must comply with all applicable United States export
;;;; control laws.
;;;;
;;;; This software is made available AS IS, and Xerox Corporation makes no
;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
(in-package "SB-PCL")
(defmethod slot-accessor-function ((slotd effective-slot-definition) type)
(ecase type
(reader (slot-definition-reader-function slotd))
(writer (slot-definition-writer-function slotd))
(boundp (slot-definition-boundp-function slotd))))
(defmethod (setf slot-accessor-function) (function
(slotd effective-slot-definition)
type)
(ecase type
(reader (setf (slot-definition-reader-function slotd) function))
(writer (setf (slot-definition-writer-function slotd) function))
(boundp (setf (slot-definition-boundp-function slotd) function))))
(defconstant +slotd-reader-function-std-p+ 1)
(defconstant +slotd-writer-function-std-p+ 2)
(defconstant +slotd-boundp-function-std-p+ 4)
(defconstant +slotd-all-function-std-p+ 7)
(defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
(let ((flags (slot-value slotd 'accessor-flags)))
(declare (type fixnum flags))
(if (eq type 'all)
(eql +slotd-all-function-std-p+ flags)
(let ((mask (ecase type
(reader +slotd-reader-function-std-p+)
(writer +slotd-writer-function-std-p+)
(boundp +slotd-boundp-function-std-p+))))
(declare (type fixnum mask))
(not (zerop (the fixnum (logand mask flags))))))))
(defmethod (setf slot-accessor-std-p) (value
(slotd effective-slot-definition)
type)
(let ((mask (ecase type
(reader +slotd-reader-function-std-p+)
(writer +slotd-writer-function-std-p+)
(boundp +slotd-boundp-function-std-p+)))
(flags (slot-value slotd 'accessor-flags)))
(declare (type fixnum mask flags))
(setf (slot-value slotd 'accessor-flags)
(if value
(the fixnum (logior mask flags))
(the fixnum (logand (the fixnum (lognot mask)) flags)))))
value)
(defmethod initialize-internal-slot-functions ((slotd
effective-slot-definition))
(let* ((name (slot-value slotd 'name))
(class (slot-value slotd 'class)))
(let ((table (or (gethash name *name->class->slotd-table*)
(setf (gethash name *name->class->slotd-table*)
(make-hash-table :test 'eq :size 5)))))
(setf (gethash class table) slotd))
(dolist (type '(reader writer boundp))
(let* ((gf-name (ecase type
(reader 'slot-value-using-class)
(writer '(setf slot-value-using-class))
(boundp 'slot-boundp-using-class)))
(gf (gdefinition gf-name)))
(compute-slot-accessor-info slotd type gf)))
(initialize-internal-slot-gfs name)))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
;;;
;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
;;; writing/testing effective slot SLOTD.
;;;
;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
;;; GF. Store the effective method in the effective slot definition
;;; object itself; these GFs have special dispatch functions calling
;;; effective methods directly retrieved from effective slot
;;; definition objects, as an optimization.
;;;
;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
;;; or some such.
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
type gf)
(let* ((name (slot-value slotd 'name))
(class (slot-value slotd 'class))
(old-slotd (find-slot-definition class name))
(old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
(multiple-value-bind (function std-p)
(if (eq *boot-state* 'complete)
(get-accessor-method-function gf type class slotd)
(get-optimized-std-accessor-method-function class slotd type))
(setf (slot-accessor-std-p slotd type) std-p)
(setf (slot-accessor-function slotd type) function))
(when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
(push (cons class name) *pv-table-cache-update-info*))))
(defmethod slot-definition-allocation ((slotd structure-slot-definition))
:instance)
;;;; various class accessors that are a little more complicated than can be
;;;; done with automatically generated reader methods
(defmethod class-prototype :before (class)
(unless (class-finalized-p class)
(error "~S not yet finalized, cannot allocate a prototype." class)))
;;; KLUDGE: For some reason factoring the common body into a function
;;; breaks PCL bootstrapping, so just generate it with a macrolet for
;;; all.
(macrolet ((def (class)
`(defmethod class-prototype ((class ,class))
(with-slots (prototype) class
(or prototype
(setf prototype (allocate-instance class)))))))
(def std-class)
(def condition-class)
(def structure-class))
(defmethod class-direct-default-initargs ((class slot-class))
(plist-value class 'direct-default-initargs))
(defmethod class-default-initargs ((class slot-class))
(plist-value class 'default-initargs))
(defmethod class-slot-cells ((class std-class))
(plist-value class 'class-slot-cells))
(defmethod (setf class-slot-cells) (new-value (class std-class))
(setf (plist-value class 'class-slot-cells) new-value))
;;;; class accessors that are even a little bit more complicated than those
;;;; above. These have a protocol for updating them, we must implement that
;;;; protocol.
;;; Maintaining the direct subclasses backpointers. The update methods are
;;; here, the values are read by an automatically generated reader method.
(defmethod add-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
(pushnew subclass direct-subclasses)
subclass))
(defmethod remove-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
(setq direct-subclasses (remove subclass direct-subclasses))
subclass))
;;; Maintaining the direct-methods and direct-generic-functions backpointers.
;;;
;;; There are four generic functions involved, each has one method for the
;;; class case and another method for the damned EQL specializers. All of
;;; these are specified methods and appear in their specified place in the
;;; class graph.
;;;
;;; ADD-DIRECT-METHOD
;;; REMOVE-DIRECT-METHOD
;;; SPECIALIZER-DIRECT-METHODS
;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
;;;
;;; In each case, we maintain one value which is a cons. The car is the list
;;; methods. The cdr is a list of the generic functions. The cdr is always
;;; computed lazily.
(defmethod add-direct-method ((specializer class) (method method))
(with-slots (direct-methods) specializer
(setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
(cdr direct-methods) ()))
method)
(defmethod remove-direct-method ((specializer class) (method method))
(with-slots (direct-methods) specializer
(setf (car direct-methods) (remove method (car direct-methods))
(cdr direct-methods) ()))
method)
(defmethod specializer-direct-methods ((specializer class))
(with-slots (direct-methods) specializer
(car direct-methods)))
(defmethod specializer-direct-generic-functions ((specializer class))
(with-slots (direct-methods) specializer
(or (cdr direct-methods)
(setf (cdr direct-methods)
(let (collect)
(dolist (m (car direct-methods))
;; the old PCL code used COLLECTING-ONCE which used
;; #'EQ to check for newness
(pushnew (method-generic-function m) collect :test #'eq))
(nreverse collect))))))
;;; This hash table is used to store the direct methods and direct generic
;;; functions of EQL specializers. Each value in the table is the cons.
(defvar *eql-specializer-methods* (make-hash-table :test 'eql))
(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
(defmethod specializer-method-table ((specializer eql-specializer))
*eql-specializer-methods*)
(defmethod specializer-method-table ((specializer class-eq-specializer))
*class-eq-specializer-methods*)
(defmethod add-direct-method ((specializer specializer-with-object)
(method method))
(let* ((object (specializer-object specializer))
(table (specializer-method-table specializer))
(entry (gethash object table)))
(unless entry
(setq entry
(setf (gethash object table)
(cons nil nil))))
(setf (car entry) (adjoin method (car entry))
(cdr entry) ())
method))
(defmethod remove-direct-method ((specializer specializer-with-object)
(method method))
(let* ((object (specializer-object specializer))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(setf (car entry) (remove method (car entry))
(cdr entry) ()))
method))
(defmethod specializer-direct-methods ((specializer specializer-with-object))
(car (gethash (specializer-object specializer)
(specializer-method-table specializer))))
(defmethod specializer-direct-generic-functions ((specializer
specializer-with-object))
(let* ((object (specializer-object specializer))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(or (cdr entry)
(setf (cdr entry)
(let (collect)
(dolist (m (car entry))
(pushnew (method-generic-function m) collect :test #'eq))
(nreverse collect)))))))
(defun map-specializers (function)
(map-all-classes (lambda (class)
(funcall function (class-eq-specializer class))
(funcall function class)))
(maphash (lambda (object methods)
(declare (ignore methods))
(intern-eql-specializer object))
*eql-specializer-methods*)
(maphash (lambda (object specl)
(declare (ignore object))
(funcall function specl))
*eql-specializer-table*)
nil)
(defun map-all-generic-functions (function)
(let ((all-generic-functions (make-hash-table :test 'eq)))
(map-specializers (lambda (specl)
(dolist (gf (specializer-direct-generic-functions
specl))
(unless (gethash gf all-generic-functions)
(setf (gethash gf all-generic-functions) t)
(funcall function gf))))))
nil)
(defmethod shared-initialize :after ((specl class-eq-specializer)
slot-names
&key)
(declare (ignore slot-names))
(setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
(declare (ignore slot-names))
(setf (slot-value specl 'type)
`(eql ,(specializer-object specl)))
(setf (info :type :translator specl)
(constantly (make-member-type :members (list (specializer-object specl))))))
(defun real-load-defclass (name metaclass-name supers slots other
readers writers slot-names)
(with-single-package-locked-error (:symbol name "defining ~S as a class")
(%compiler-defclass name readers writers slot-names)
(let ((res (apply #'ensure-class name :metaclass metaclass-name
:direct-superclasses supers
:direct-slots slots
:definition-source `((defclass ,name)
,*load-pathname*)
other)))
res)))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
(defun ensure-class (name &rest args)
(apply #'ensure-class-using-class
(let ((class (find-class name nil)))
(when (and class (eq name (class-name class)))
;; NAME is the proper name of CLASS, so redefine it
class))
name
args))
(defmethod ensure-class-using-class ((class null) name &rest args &key)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
(set-class-type-translation (class-prototype meta) name)
(setf class (apply #'make-instance meta :name name initargs))
(without-package-locks
(setf (find-class name) class))
(set-class-type-translation class name)
class))
(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
(multiple-value-bind (meta initargs)
(ensure-class-values class args)
(unless (eq (class-of class) meta)
(apply #'change-class class meta initargs))
(apply #'reinitialize-instance class initargs)
(without-package-locks
(setf (find-class name) class))
(set-class-type-translation class name)
class))
(defmethod class-predicate-name ((class t))
'constantly-nil)
(defun fix-super (s)
(cond ((classp s) s)
((not (legal-class-name-p s))
(error "~S is not a class or a legal class name." s))
(t
(or (find-class s nil)
(make-instance 'forward-referenced-class
:name s)))))
(defun ensure-class-values (class initargs)
(let (metaclass metaclassp reversed-plist)
(doplist (key val) initargs
(cond ((eq key :metaclass)
(setf metaclass val
metaclassp key))
(t
(when (eq key :direct-superclasses)
(setf val (mapcar #'fix-super val)))
(setf reversed-plist (list* val key reversed-plist)))))
(values (cond (metaclassp
(find-class metaclass))
((or (null class) (forward-referenced-class-p class))
*the-class-standard-class*)
(t
(class-of class)))
(nreverse reversed-plist))))
(defmethod shared-initialize :after
((class std-class)
slot-names
&key (direct-superclasses nil direct-superclasses-p)
(direct-slots nil direct-slots-p)
(direct-default-initargs nil direct-default-initargs-p)
(predicate-name nil predicate-name-p))
(cond (direct-superclasses-p
(setq direct-superclasses
(or direct-superclasses
(list (if (funcallable-standard-class-p class)
*the-class-funcallable-standard-object*
*the-class-standard-object*))))
(dolist (superclass direct-superclasses)
(unless (validate-superclass class superclass)
(error "The class ~S was specified as a~%
super-class of the class ~S;~%~
but the meta-classes ~S and~%~S are incompatible.~@
Define a method for ~S to avoid this error."
superclass class (class-of superclass) (class-of class)
'validate-superclass)))
(setf (slot-value class 'direct-superclasses) direct-superclasses))
(t
(setq direct-superclasses (slot-value class 'direct-superclasses))))
(setq direct-slots
(if direct-slots-p
(setf (slot-value class 'direct-slots)
(mapcar (lambda (pl) (make-direct-slotd class pl))
direct-slots))
(slot-value class 'direct-slots)))
(if direct-default-initargs-p
(setf (plist-value class 'direct-default-initargs)
direct-default-initargs)
(setq direct-default-initargs
(plist-value class 'direct-default-initargs)))
(setf (plist-value class 'class-slot-cells)
(let ((old-class-slot-cells (plist-value class 'class-slot-cells))
(collect '()))
(dolist (dslotd direct-slots)
(when (eq :class (slot-definition-allocation dslotd))
;; see CLHS 4.3.6
(let* ((name (slot-definition-name dslotd))
(old (assoc name old-class-slot-cells)))
(if (or (not old)
(eq t slot-names)
(member name slot-names))
(let* ((initfunction (slot-definition-initfunction dslotd))
(value (if initfunction
(funcall initfunction)
+slot-unbound+)))
(push (cons name value) collect))
(push old collect)))))
(nreverse collect)))
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
(car predicate-name))
(or (slot-value class 'predicate-name)
(setf (slot-value class 'predicate-name)
(make-class-predicate-name (class-name
class))))))
(add-direct-subclasses class direct-superclasses)
(make-class-predicate class predicate-name)
(update-class class nil)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
((null slots) (when dupes
(style-warn
;; FIXME: the indentation request ("~4I")
;; below appears not to do anything. Finding
;; out why would be nice. -- CSR, 2003-04-24
"~@<slot names with the same SYMBOL-NAME but ~
different SYMBOL-PACKAGE (possible package problem) ~
for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"
class
dupes)))
(let* ((slot (car slots))
(oslots (remove (slot-definition-name slot) (cdr slots)
:test #'string/= :key #'slot-definition-name)))
(when oslots
(pushnew (cons (slot-definition-name slot)
(mapcar #'slot-definition-name oslots))
dupes
:test #'string= :key #'car))))
(add-slot-accessors class direct-slots)
(make-preliminary-layout class))
(defmethod shared-initialize :after ((class forward-referenced-class)
slot-names &key &allow-other-keys)
(declare (ignore slot-names))
(make-preliminary-layout class))
(defvar *allow-forward-referenced-classes-in-cpl-p* nil)
;;; Give CLASS a preliminary layout if it doesn't have one already, to
;;; make it known to the type system.
(defun make-preliminary-layout (class)
(flet ((compute-preliminary-cpl (root)
(let ((*allow-forward-referenced-classes-in-cpl-p* t))
(compute-class-precedence-list root))))
(without-package-locks
(unless (class-finalized-p class)
(let ((name (class-name class)))
(setf (find-class name) class)
;; KLUDGE: This is fairly horrible. We need to make a
;; full-fledged CLASSOID here, not just tell the compiler that
;; some class is forthcoming, because there are legitimate
;; questions one can ask of the type system, implemented in
;; terms of CLASSOIDs, involving forward-referenced classes. So.
(when (and (eq *boot-state* 'complete)
(null (find-classoid name nil)))
(setf (find-classoid name)
(make-standard-classoid :name name)))
(set-class-type-translation class name)
(let ((layout (make-wrapper 0 class))
(classoid (find-classoid name)))
(setf (layout-classoid layout) classoid)
(setf (classoid-pcl-class classoid) class)
(setf (slot-value class 'wrapper) layout)
(let ((cpl (compute-preliminary-cpl class)))
(setf (layout-inherits layout)
(order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest cpl))))))
(register-layout layout :invalidate t)
(setf (classoid-layout classoid) layout)
(mapc #'make-preliminary-layout (class-direct-subclasses class))))))))
(defmethod shared-initialize :before ((class class) slot-names &key name)
(declare (ignore slot-names name))
;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
(setf (slot-value class 'type) `(class ,class))
(setf (slot-value class 'class-eq-specializer)
(make-instance 'class-eq-specializer :class class)))
(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses)
(dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))
(remove-direct-subclass old-super class))
(remove-slot-accessors class (class-direct-slots class)))
(defmethod reinitialize-instance :after ((class slot-class)
&rest initargs
&key)
(map-dependents class
(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
(defmethod shared-initialize :after ((class condition-class) slot-names
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (class-name class))))
(with-slots (wrapper class-precedence-list cpl-available-p
prototype predicate-name
(direct-supers direct-superclasses))
class
(setf (slot-value class 'direct-slots)
(mapcar (lambda (pl) (make-direct-slotd class pl))
direct-slots))
(setf (slot-value class 'finalized-p) t)
(setf (classoid-pcl-class classoid) class)
(setq direct-supers direct-superclasses)
(setq wrapper (classoid-layout classoid))
(setq class-precedence-list (compute-class-precedence-list class))
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
(setq predicate-name (make-class-predicate-name (class-name class)))
(make-class-predicate class predicate-name)
(setf (slot-value class 'slots) (compute-slots class))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
;; override condition accessors with generic functions. We do this
;; differently.
(update-pv-table-cache-info class))
(defmethod direct-slot-definition-class ((class condition-class)
&rest initargs)
(declare (ignore initargs))
(find-class 'condition-direct-slot-definition))
(defmethod effective-slot-definition-class ((class condition-class)
&rest initargs)
(declare (ignore initargs))
(find-class 'condition-effective-slot-definition))
(defmethod finalize-inheritance ((class condition-class))
(aver (slot-value class 'finalized-p))
nil)
(defmethod compute-effective-slot-definition
((class condition-class) slot-name dslotds)
(let ((slotd (call-next-method)))
(setf (slot-definition-reader-function slotd)
(lambda (x)
(handler-case (condition-reader-function x slot-name)
;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
;; is unbound; maybe it should be a CELL-ERROR of some
;; sort?
(error () (values (slot-unbound class x slot-name))))))
(setf (slot-definition-writer-function slotd)
(lambda (v x)
(condition-writer-function x v slot-name)))
(setf (slot-definition-boundp-function slotd)
(lambda (x)
(multiple-value-bind (v c)
(ignore-errors (condition-reader-function x slot-name))
(declare (ignore v))
(null c))))
slotd))
(defmethod compute-slots ((class condition-class))
(mapcan (lambda (superclass)
(mapcar (lambda (dslotd)
(compute-effective-slot-definition
class (slot-definition-name dslotd) (list dslotd)))
(class-direct-slots superclass)))
(reverse (slot-value class 'class-precedence-list))))
(defmethod compute-slots :around ((class condition-class))
(let ((eslotds (call-next-method)))
(mapc #'initialize-internal-slot-functions eslotds)
eslotds))
(defmethod shared-initialize :after
((slotd structure-slot-definition) slot-names &key
(allocation :instance) allocation-class)
(declare (ignore slot-names allocation-class))
(unless (eq allocation :instance)
(error "Structure slots must have :INSTANCE allocation.")))
(defun make-structure-class-defstruct-form (name direct-slots include)
(let* ((conc-name (format-symbol *package* "~S structure class " name))
(constructor (format-symbol *package* "~Aconstructor" conc-name))
(defstruct `(defstruct (,name
,@(when include
`((:include ,(class-name include))))
(:predicate nil)
(:conc-name ,conc-name)
(:constructor ,constructor ())
(:copier nil))
,@(mapcar (lambda (slot)
`(,(slot-definition-name slot)
+slot-unbound+))
direct-slots)))
(reader-names (mapcar (lambda (slotd)
(list 'slot-accessor name
(slot-definition-name slotd)
'reader))
direct-slots))
(writer-names (mapcar (lambda (slotd)
(list 'slot-accessor name
(slot-definition-name slotd)
'writer))
direct-slots))
(readers-init
(mapcar (lambda (slotd reader-name)
(let ((accessor
(slot-definition-defstruct-accessor-symbol
slotd)))
`(defun ,reader-name (obj)
(declare (type ,name obj))
(,accessor obj))))
direct-slots reader-names))
(writers-init
(mapcar (lambda (slotd writer-name)
(let ((accessor
(slot-definition-defstruct-accessor-symbol
slotd)))
`(defun ,writer-name (nv obj)
(declare (type ,name obj))
(setf (,accessor obj) nv))))
direct-slots writer-names))
(defstruct-form
`(progn
,defstruct
,@readers-init ,@writers-init
(cons nil nil))))
(values defstruct-form constructor reader-names writer-names)))
(defun make-defstruct-allocation-function (class)
(let ((dd (get-structure-dd (class-name class))))
(lambda ()
(let ((instance (%make-instance (dd-length dd)))
(raw-index (dd-raw-index dd)))
(setf (%instance-layout instance)
(sb-kernel::compiler-layout-or-lose (dd-name dd)))
(when raw-index
(setf (%instance-ref instance raw-index)
(make-array (dd-raw-length dd)
:element-type '(unsigned-byte 32))))
instance))))
(defmethod shared-initialize :after
((class structure-class)
slot-names
&key (direct-superclasses nil direct-superclasses-p)
(direct-slots nil direct-slots-p)
direct-default-initargs
(predicate-name nil predicate-name-p))
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(or direct-superclasses
(setq direct-superclasses
(and (not (eq (class-name class) 'structure-object))
(list *the-class-structure-object*)))))
(setq direct-superclasses (slot-value class 'direct-superclasses)))
(let* ((name (class-name class))
(from-defclass-p (slot-value class 'from-defclass-p))
(defstruct-p (or from-defclass-p (not (structure-type-p name)))))
(if direct-slots-p
(setf (slot-value class 'direct-slots)
(setq direct-slots
(mapcar (lambda (pl)
(when defstruct-p
(let* ((slot-name (getf pl :name))
(accessor
(format-symbol *package*
"~S structure class ~A"
name slot-name)))
(setq pl (list* :defstruct-accessor-symbol
accessor pl))))
(make-direct-slotd class pl))
direct-slots)))
(setq direct-slots (slot-value class 'direct-slots)))
(if defstruct-p
(let ((include (car (slot-value class 'direct-superclasses))))
(multiple-value-bind (defstruct-form constructor reader-names writer-names)
(make-structure-class-defstruct-form name direct-slots include)
(unless (structure-type-p name) (eval defstruct-form))
(mapc (lambda (dslotd reader-name writer-name)
(let* ((reader (gdefinition reader-name))
(writer (when (gboundp writer-name)
(gdefinition writer-name))))
(setf (slot-value dslotd 'internal-reader-function)
reader)
(setf (slot-value dslotd 'internal-writer-function)
writer)))
direct-slots reader-names writer-names)
(setf (slot-value class 'defstruct-form) defstruct-form)
(setf (slot-value class 'defstruct-constructor) constructor)))
(setf (slot-value class 'defstruct-constructor)
(make-defstruct-allocation-function class)))
(add-direct-subclasses class direct-superclasses)
(setf (slot-value class 'class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'cpl-available-p) t)
(setf (slot-value class 'slots) (compute-slots class))
(let ((lclass (find-classoid (class-name class))))
(setf (classoid-pcl-class lclass) class)
(setf (slot-value class 'wrapper) (classoid-layout lclass)))
(setf (slot-value class 'finalized-p) t)
(update-pv-table-cache-info class)
(setq predicate-name (if predicate-name-p
(setf (slot-value class 'predicate-name)
(car predicate-name))
(or (slot-value class 'predicate-name)
(setf (slot-value class 'predicate-name)
(make-class-predicate-name
(class-name class))))))
(make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots)))
(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
(declare (ignore initargs))
(find-class 'structure-direct-slot-definition))
(defmethod finalize-inheritance ((class structure-class))
nil) ; always finalized
(defun add-slot-accessors (class dslotds)
(fix-slot-accessors class dslotds 'add))
(defun remove-slot-accessors (class dslotds)
(fix-slot-accessors class dslotds 'remove))
(defun fix-slot-accessors (class dslotds add/remove)
(flet ((fix (gfspec name r/w)
(let ((gf (if (fboundp gfspec)
(without-package-locks
(ensure-generic-function gfspec))
(ensure-generic-function
gfspec :lambda-list (case r/w
(r '(object))
(w '(new-value object)))))))
(case r/w
(r (if (eq add/remove 'add)
(add-reader-method class gf name)
(remove-reader-method class gf)))
(w (if (eq add/remove 'add)
(add-writer-method class gf name)
(remove-writer-method class gf)))))))
(dolist (dslotd dslotds)
(let ((slot-name (slot-definition-name dslotd)))
(dolist (r (slot-definition-readers dslotd))
(fix r slot-name 'r))
(dolist (w (slot-definition-writers dslotd))
(fix w slot-name 'w))))))
(defun add-direct-subclasses (class supers)
(dolist (super supers)
(unless (memq class (class-direct-subclasses class))
(add-direct-subclass super class))))
(defmethod finalize-inheritance ((class std-class))
(update-class class t))
(defmethod finalize-inheritance ((class forward-referenced-class))
;; FIXME: should we not be thinking a bit about what kinds of error
;; we're throwing? Maybe we need a clos-error type to mix in? Or
;; possibly a forward-referenced-class-error, though that's
;; difficult given e.g. class precedence list calculations...
(error
"~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
~2I~_~S~:>"
class))
(defun class-has-a-forward-referenced-superclass-p (class)
(or (forward-referenced-class-p class)
(some #'class-has-a-forward-referenced-superclass-p
(class-direct-superclasses class))))
;;; This is called by :after shared-initialize whenever a class is initialized
;;; or reinitialized. The class may or may not be finalized.
(defun update-class (class finalizep)
;; Comment from Gerd Moellmann:
;;
;; Note that we can't simply delay the finalization when CLASS has
;; no forward referenced superclasses because that causes bootstrap
;; problems.
(without-package-locks
(when (and (not finalizep)
(not (class-finalized-p class))
(not (class-has-a-forward-referenced-superclass-p class)))
(finalize-inheritance class)
(return-from update-class))
(when (or finalizep (class-finalized-p class)
(not (class-has-a-forward-referenced-superclass-p class)))
(setf (find-class (class-name class)) class)
(update-cpl class (compute-class-precedence-list class))
;; This invocation of UPDATE-SLOTS, in practice, finalizes the
;; class. The hoops above are to ensure that FINALIZE-INHERITANCE
;; is called at finalization, so that MOP programmers can hook
;; into the system as described in "Class Finalization Protocol"
;; (section 5.5.2 of AMOP).
(update-slots class (compute-slots class))
(update-gfs-of-class class)
(update-initargs class (compute-default-initargs class))
(update-ctors 'finalize-inheritance :class class))
(unless finalizep
(dolist (sub (class-direct-subclasses class)) (update-class sub nil)))))
(defun update-cpl (class cpl)
(if (class-finalized-p class)
(unless (and (equal (class-precedence-list class) cpl)
(dolist (c cpl t)
(when (position :class (class-direct-slots c)
:key #'slot-definition-allocation)
(return nil))))
;; comment from the old CMU CL sources:
;; Need to have the cpl setup before update-lisp-class-layout
;; is called on CMU CL.
(setf (slot-value class 'class-precedence-list) cpl)
(setf (slot-value class 'cpl-available-p) t)
(force-cache-flushes class))
(progn
(setf (slot-value class 'class-precedence-list) cpl)
(setf (slot-value class 'cpl-available-p) t)))
(update-class-can-precede-p cpl))
(defun update-class-can-precede-p (cpl)
(when cpl
(let ((first (car cpl)))
(dolist (c (cdr cpl))
(pushnew c (slot-value first 'can-precede-list))))
(update-class-can-precede-p (cdr cpl))))
(defun class-can-precede-p (class1 class2)
(member class2 (class-can-precede-list class1)))
(defun update-slots (class eslotds)
(let ((instance-slots ())
(class-slots ()))
(dolist (eslotd eslotds)
(let ((alloc (slot-definition-allocation eslotd)))
(case alloc
(:instance (push eslotd instance-slots))
(:class (push eslotd class-slots)))))
;; If there is a change in the shape of the instances then the
;; old class is now obsolete.
(let* ((nlayout (mapcar #'slot-definition-name
(sort instance-slots #'<
:key #'slot-definition-location)))
(nslots (length nlayout))
(nwrapper-class-slots (compute-class-slots class-slots))
(owrapper (when (class-finalized-p class)
(class-wrapper class)))
(olayout (when owrapper
(wrapper-instance-slots-layout owrapper)))
(owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
(nwrapper
(cond ((null owrapper)
(make-wrapper nslots class))
((and (equal nlayout olayout)
(not
(loop for o in owrapper-class-slots
for n in nwrapper-class-slots
do (unless (eq (car o) (car n)) (return t)))))
owrapper)
(t
;; This will initialize the new wrapper to have the
;; same state as the old wrapper. We will then have
;; to change that. This may seem like wasted work
;; (and it is), but the spec requires that we call
;; MAKE-INSTANCES-OBSOLETE.
(make-instances-obsolete class)
(class-wrapper class)))))
(with-slots (wrapper slots) class
(update-lisp-class-layout class nwrapper)
(setf slots eslotds
(wrapper-instance-slots-layout nwrapper) nlayout
(wrapper-class-slots nwrapper) nwrapper-class-slots
(wrapper-no-of-instance-slots nwrapper) nslots
wrapper nwrapper))
(setf (slot-value class 'finalized-p) t)
(unless (eq owrapper nwrapper)
(update-pv-table-cache-info class)
(maybe-update-standard-class-locations class)))))
(defun compute-class-slots (eslotds)
(let (collect)
(dolist (eslotd eslotds)
(push (assoc (slot-definition-name eslotd)
(class-slot-cells (slot-definition-class eslotd)))
collect))
(nreverse collect)))
(defun update-gfs-of-class (class)
(when (and (class-finalized-p class)
(let ((cpl (class-precedence-list class)))
(or (member *the-class-slot-class* cpl)
(member *the-class-standard-effective-slot-definition*
cpl))))
(let ((gf-table (make-hash-table :test 'eq)))
(labels ((collect-gfs (class)
(dolist (gf (specializer-direct-generic-functions class))
(setf (gethash gf gf-table) t))
(mapc #'collect-gfs (class-direct-superclasses class))))
(collect-gfs class)
(maphash (lambda (gf ignore)
(declare (ignore ignore))
(update-gf-dfun class gf))
gf-table)))))
(defun update-initargs (class inits)
(setf (plist-value class 'default-initargs) inits))
(defmethod compute-default-initargs ((class slot-class))
(let ((initargs (loop for c in (class-precedence-list class)
append (class-direct-default-initargs c))))
(delete-duplicates initargs :test #'eq :key #'car :from-end t)))
;;;; protocols for constructing direct and effective slot definitions
(defmethod direct-slot-definition-class ((class std-class) &rest initargs)
(declare (ignore initargs))
(find-class 'standard-direct-slot-definition))
(defun make-direct-slotd (class initargs)
(apply #'make-instance
(apply #'direct-slot-definition-class class initargs)
:class class
initargs))
(defmethod compute-slots ((class std-class))
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
;; for each different slot name we find in our superclasses. Each
;; call receives the class and a list of the dslotds with that name.
;; The list is in most-specific-first order.
(let ((name-dslotds-alist ()))
(dolist (c (class-precedence-list class))
(dolist (slot (class-direct-slots c))
(let* ((name (slot-definition-name slot))
(entry (assq name name-dslotds-alist)))
(if entry
(push slot (cdr entry))
(push (list name slot) name-dslotds-alist)))))
(mapcar (lambda (direct)
(compute-effective-slot-definition class
(car direct)
(nreverse (cdr direct))))
name-dslotds-alist)))
(defmethod compute-slots ((class standard-class))
(call-next-method))
(defmethod compute-slots :around ((class standard-class))
(let ((eslotds (call-next-method))
(location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
(case (slot-definition-allocation eslotd)
(:instance
(incf location))
(:class
(let* ((name (slot-definition-name eslotd))
(from-class
(or
(slot-definition-allocation-class eslotd)
;; we get here if the user adds an extra slot
;; himself...
(setf (slot-definition-allocation-class eslotd)
class)))
;; which raises the question of what we should
;; do if we find that said user has added a slot
;; with the same name as another slot...
(cell (or (assq name (class-slot-cells from-class))
(setf (class-slot-cells from-class)
(cons (cons name +slot-unbound+)
(class-slot-cells from-class))))))
(aver (consp cell))
(if (eq +slot-unbound+ (cdr cell))
;; We may have inherited an initfunction
(let ((initfun (slot-definition-initfunction eslotd)))
(if initfun
(rplacd cell (funcall initfun))
cell))
cell)))))
(unless (slot-definition-class eslotd)
(setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
(defmethod compute-slots ((class funcallable-standard-class))
(call-next-method))
(defmethod compute-slots :around ((class funcallable-standard-class))
(labels ((instance-slot-names (slotds)
(let (collect)
(dolist (slotd slotds (nreverse collect))
(when (eq (slot-definition-allocation slotd) :instance)
(push (slot-definition-name slotd) collect)))))
;; This sorts slots so that slots of classes later in the CPL
;; come before slots of other classes. This is crucial for
;; funcallable instances because it ensures that the slots of
;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
;; a funcallable instance.
(compute-layout (eslotds)
(let ((first ())
(names (instance-slot-names eslotds)))
(dolist (class
(reverse (class-precedence-list class))
(nreverse (nconc names first)))
(dolist (ss (class-slots class))
(let ((name (slot-definition-name ss)))
(when (member name names)
(push name first)
(setq names (delete name names)))))))))
(let ((all-slotds (call-next-method))
(instance-slots ())
(class-slots ()))
(dolist (slotd all-slotds)
(case (slot-definition-allocation slotd)
(:instance (push slotd instance-slots))
(:class (push slotd class-slots))))
(let ((layout (compute-layout instance-slots)))
(dolist (slotd instance-slots)
(setf (slot-definition-location slotd)
(position (slot-definition-name slotd) layout))
(initialize-internal-slot-functions slotd)))
(dolist (slotd class-slots)
(let ((name (slot-definition-name slotd))
(from-class (slot-definition-allocation-class slotd)))
(setf (slot-definition-location slotd)
(assoc name (class-slot-cells from-class)))
(aver (consp (slot-definition-location slotd)))
(initialize-internal-slot-functions slotd)))
all-slotds)))
(defmethod compute-slots ((class structure-class))
(mapcan (lambda (superclass)
(mapcar (lambda (dslotd)
(compute-effective-slot-definition
class
(slot-definition-name dslotd)
(list dslotd)))
(class-direct-slots superclass)))
(reverse (slot-value class 'class-precedence-list))))
(defmethod compute-slots :around ((class structure-class))
(let ((eslotds (call-next-method)))
(mapc #'initialize-internal-slot-functions eslotds)
eslotds))
(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
(declare (ignore name))
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
(class (apply #'effective-slot-definition-class class initargs)))
(apply #'make-instance class initargs)))
(defmethod effective-slot-definition-class ((class std-class) &rest initargs)
(declare (ignore initargs))
(find-class 'standard-effective-slot-definition))
(defmethod effective-slot-definition-class ((class structure-class) &rest initargs)
(declare (ignore initargs))
(find-class 'structure-effective-slot-definition))
(defmethod compute-effective-slot-definition-initargs
((class slot-class) direct-slotds)
(let* ((name nil)
(initfunction nil)
(initform nil)
(initargs nil)
(allocation nil)
(allocation-class nil)
(type t)
(namep nil)
(initp nil)
(allocp nil))
(dolist (slotd direct-slotds)
(when slotd
(unless namep
(setq name (slot-definition-name slotd)
namep t))
(unless initp
(when (slot-definition-initfunction slotd)
(setq initform (slot-definition-initform slotd)
initfunction (slot-definition-initfunction slotd)
initp t)))
(unless allocp
(setq allocation (slot-definition-allocation slotd)
allocation-class (slot-definition-class slotd)
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
(let ((slotd-type (slot-definition-type slotd)))
(setq type (cond ((eq type t) slotd-type)
((*subtypep type slotd-type) type)
(t `(and ,type ,slotd-type)))))))
(list :name name
:initform initform
:initfunction initfunction
:initargs initargs
:allocation allocation
:allocation-class allocation-class
:type type
:class class)))
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
(let ((slotd (car direct-slotds)))
(list* :defstruct-accessor-symbol
(slot-definition-defstruct-accessor-symbol slotd)
:internal-reader-function
(slot-definition-internal-reader-function slotd)
:internal-writer-function
(slot-definition-internal-writer-function slotd)
(call-next-method))))
;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
;;; to make the method object. They have to use make-a-method which
;;; is a specially bootstrapped mechanism for making standard methods.
(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
(declare (ignore direct-slot initargs))
(find-class 'standard-reader-method))
(defmethod add-reader-method ((class slot-class) generic-function slot-name)
(add-method generic-function
(make-a-method 'standard-reader-method
()
(list (or (class-name class) 'object))
(list class)
(make-reader-method-function class slot-name)
"automatically generated reader method"
slot-name)))
(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
(declare (ignore direct-slot initargs))
(find-class 'standard-writer-method))
(defmethod add-writer-method ((class slot-class) generic-function slot-name)
(add-method generic-function
(make-a-method 'standard-writer-method
()
(list 'new-value (or (class-name class) 'object))
(list *the-class-t* class)
(make-writer-method-function class slot-name)
"automatically generated writer method"
slot-name)))
(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
(add-method generic-function
(make-a-method 'standard-boundp-method
()
(list (or (class-name class) 'object))
(list class)
(make-boundp-method-function class slot-name)
"automatically generated boundp method"
slot-name)))
(defmethod remove-reader-method ((class slot-class) generic-function)
(let ((method (get-method generic-function () (list class) nil)))
(when method (remove-method generic-function method))))
(defmethod remove-writer-method ((class slot-class) generic-function)
(let ((method
(get-method generic-function () (list *the-class-t* class) nil)))
(when method (remove-method generic-function method))))
(defmethod remove-boundp-method ((class slot-class) generic-function)
(let ((method (get-method generic-function () (list class) nil)))
(when method (remove-method generic-function method))))
;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
;;; function are NOT part of the standard protocol. They are however
;;; useful; PCL makes use of them internally and documents them for
;;; PCL users. (FIXME: but SBCL certainly doesn't)
;;;
;;; *** This needs work to make type testing by the writer functions which
;;; *** do type testing faster. The idea would be to have one constructor
;;; *** for each possible type test.
;;;
;;; *** There is a subtle bug here which is going to have to be fixed.
;;; *** Namely, the simplistic use of the template has to be fixed. We
;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
;;; *** defined for this metaclass a chance to run.
(defmethod make-reader-method-function ((class slot-class) slot-name)
(make-std-reader-method-function (class-name class) slot-name))
(defmethod make-writer-method-function ((class slot-class) slot-name)
(make-std-writer-method-function (class-name class) slot-name))
(defmethod make-boundp-method-function ((class slot-class) slot-name)
(make-std-boundp-method-function (class-name class) slot-name))
(defmethod compatible-meta-class-change-p (class proto-new-class)
(eq (class-of class) (class-of proto-new-class)))
(defmethod validate-superclass ((class class) (new-super class))
(or (eq new-super *the-class-t*)
(eq (class-of class) (class-of new-super))))
(defmethod validate-superclass ((class standard-class) (new-super std-class))
(let ((new-super-meta-class (class-of new-super)))
(or (eq new-super-meta-class *the-class-std-class*)
(eq (class-of class) new-super-meta-class))))
;;; What this does depends on which of the four possible values of
;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
;;; nothing to do, as the new wrapper has already been created. If
;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
;;;
;;; This leaves the case where LAYOUT-INVALID returns T, which happens
;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
;;; obsolete the wrapper.
;;;
;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
;;; :UNINITIALIZED)))
;;;
;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
(defun force-cache-flushes (class)
(let* ((owrapper (class-wrapper class)))
;; We only need to do something if the wrapper is still valid. If
;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
;; both of those will already be doing what we want. In
;; particular, we must be sure we never change an OBSOLETE into a
;; FLUSH since OBSOLETE means do what FLUSH does and then some.
(when (or (not (invalid-wrapper-p owrapper))
;; KLUDGE: despite the observations above, this remains
;; a violation of locality or what might be considered
;; good style. There has to be a better way! -- CSR,
;; 2002-10-29
(eq (layout-invalid owrapper) t))
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
(with-pcl-lock
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
;; Use :OBSOLETE instead of :FLUSH if any superclass has
;; been obsoleted.
(if (find-if (lambda (x)
(and (consp x) (eq :obsolete (car x))))
(layout-inherits owrapper)
:key #'layout-invalid)
(invalidate-wrapper owrapper :obsolete nwrapper)
(invalidate-wrapper owrapper :flush nwrapper)))))))
(defun flush-cache-trap (owrapper nwrapper instance)
(declare (ignore owrapper))
(set-wrapper instance nwrapper))
;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
;;; the next access to the instance (as defined in 88-002R) to trap
;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
(defmethod make-instances-obsolete ((class std-class))
(let* ((owrapper (class-wrapper class))
(nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
(wrapper-instance-slots-layout owrapper))
(setf (wrapper-class-slots nwrapper)
(wrapper-class-slots owrapper))
(with-pcl-lock
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(invalidate-wrapper owrapper :obsolete nwrapper)
class)))
(defmethod make-instances-obsolete ((class symbol))
(make-instances-obsolete (find-class class))
;; ANSI wants the class name when called with a symbol.
class)
;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
;;; see an obsolete instance. The times when it is called are:
;;; - when the instance is involved in method lookup
;;; - when attempting to access a slot of an instance
;;;
;;; It is not called by class-of, wrapper-of, or any of the low-level
;;; instance access macros.
;;;
;;; Of course these times when it is called are an internal
;;; implementation detail of PCL and are not part of the documented
;;; description of when the obsolete instance update happens. The
;;; documented description is as it appears in 88-002R.
;;;
;;; This has to return the new wrapper, so it counts on all the
;;; methods on obsolete-instance-trap-internal to return the new
;;; wrapper. It also does a little internal error checking to make
;;; sure that the traps are only happening when they should, and that
;;; the trap methods are computing appropriate new wrappers.
;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
;;; after a structure is redefined. In most cases,
;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
;;; so it must signal an error. The hard part of this is that the
;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
;;; called again, so in that case, we have to return some reasonable
;;; wrapper, instead.
(defvar *in-obsolete-instance-trap* nil)
(defvar *the-wrapper-of-structure-object*
(class-wrapper (find-class 'structure-object)))
(define-condition obsolete-structure (error)
((datum :reader obsolete-structure-datum :initarg :datum))
(:report
(lambda (condition stream)
;; Don't try to print the structure, since it probably won't work.
(format stream
"~@<obsolete structure error for a structure of type ~2I~_~S~:>"
(type-of (obsolete-structure-datum condition))))))
(defun obsolete-instance-trap (owrapper nwrapper instance)
(if (not (pcl-instance-p instance))
(if *in-obsolete-instance-trap*
*the-wrapper-of-structure-object*
(let ((*in-obsolete-instance-trap* t))
(error 'obsolete-structure :datum instance)))
(let* ((class (wrapper-class* nwrapper))
(copy (allocate-instance class)) ;??? allocate-instance ???
(olayout (wrapper-instance-slots-layout owrapper))
(nlayout (wrapper-instance-slots-layout nwrapper))
(oslots (get-slots instance))
(nslots (get-slots copy))
(oclass-slots (wrapper-class-slots owrapper))
(added ())
(discarded ())
(plist ()))
;; local --> local transfer value
;; local --> shared discard value, discard slot
;; local --> -- discard slot
;; shared --> local transfer value
;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
;; shared --> -- discard value
;; -- --> local add slot
;; -- --> shared --
;; Collect class slots from inherited wrappers. Needed for
;; shared -> local transfers of inherited slots.
(let ((inherited (layout-inherits owrapper)))
(loop for i from (1- (length inherited)) downto 0
for layout = (aref inherited i)
when (typep layout 'wrapper)
do (dolist (slot (wrapper-class-slots layout))
(pushnew slot oclass-slots :key #'car))))
;; Go through all the old local slots.
(let ((opos 0))
(dolist (name olayout)
(let ((npos (posq name nlayout)))
(if npos
(setf (clos-slots-ref nslots npos)
(clos-slots-ref oslots opos))
(progn
(push name discarded)
(unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
(setf (getf plist name) (clos-slots-ref oslots opos))))))
(incf opos)))
;; Go through all the old shared slots.
(dolist (oclass-slot-and-val oclass-slots)
(let ((name (car oclass-slot-and-val))
(val (cdr oclass-slot-and-val)))
(let ((npos (posq name nlayout)))
(when npos
(setf (clos-slots-ref nslots npos) val)))))
;; Go through all the new local slots to compute the added slots.
(dolist (nlocal nlayout)
(unless (or (memq nlocal olayout)
(assq nlocal oclass-slots))
(push nlocal added)))
(swap-wrappers-and-slots instance copy)
(update-instance-for-redefined-class instance
added
discarded
plist)
nwrapper)))
(defun change-class-internal (instance new-class initargs)
(let* ((old-class (class-of instance))
(copy (allocate-instance new-class))
(new-wrapper (get-wrapper copy))
(old-wrapper (class-wrapper old-class))
(old-layout (wrapper-instance-slots-layout old-wrapper))
(new-layout (wrapper-instance-slots-layout new-wrapper))
(old-slots (get-slots instance))
(new-slots (get-slots copy))
(old-class-slots (wrapper-class-slots old-wrapper)))
;; "The values of local slots specified by both the class CTO and
;; CFROM are retained. If such a local slot was unbound, it
;; remains unbound."
(let ((new-position 0))
(dolist (new-slot new-layout)
(let ((old-position (posq new-slot old-layout)))
(when old-position
(setf (clos-slots-ref new-slots new-position)
(clos-slots-ref old-slots old-position))))
(incf new-position)))
;; "The values of slots specified as shared in the class CFROM and
;; as local in the class CTO are retained."
(dolist (slot-and-val old-class-slots)
(let ((position (posq (car slot-and-val) new-layout)))
(when position
(setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
;; Make the copy point to the old instance's storage, and make the
;; old instance point to the new storage.
(swap-wrappers-and-slots instance copy)
(apply #'update-instance-for-different-class copy instance initargs)
instance))
(defmethod change-class ((instance standard-object)
(new-class standard-class)
&rest initargs)
(change-class-internal instance new-class initargs))
(defmethod change-class ((instance funcallable-standard-object)
(new-class funcallable-standard-class)
&rest initargs)
(change-class-internal instance new-class initargs))
(defmethod change-class ((instance standard-object)
(new-class funcallable-standard-class)
&rest initargs)
(declare (ignore initargs))
(error "You can't change the class of ~S to ~S~@
because it isn't already an instance with metaclass ~S."
instance new-class 'standard-class))
(defmethod change-class ((instance funcallable-standard-object)
(new-class standard-class)
&rest initargs)
(declare (ignore initargs))
(error "You can't change the class of ~S to ~S~@
because it isn't already an instance with metaclass ~S."
instance new-class 'funcallable-standard-class))
(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
(apply #'change-class instance (find-class new-class-name) initargs))
;;;; The metaclass BUILT-IN-CLASS
;;;;
;;;; This metaclass is something of a weird creature. By this point, all
;;;; instances of it which will exist have been created, and no instance
;;;; is ever created by calling MAKE-INSTANCE.
;;;;
;;;; But, there are other parts of the protocol we must follow and those
;;;; definitions appear here.
(defmethod shared-initialize :before
((class built-in-class) slot-names &rest initargs)
(declare (ignore slot-names initargs))
(error "attempt to initialize or reinitialize a built in class"))
(defmethod class-direct-slots ((class built-in-class)) ())
(defmethod class-slots ((class built-in-class)) ())
(defmethod class-direct-default-initargs ((class built-in-class)) ())
(defmethod class-default-initargs ((class built-in-class)) ())
(defmethod validate-superclass ((c class) (s built-in-class))
(or (eq s *the-class-t*)
(eq s *the-class-stream*)))
;;; Some necessary methods for FORWARD-REFERENCED-CLASS
(defmethod class-direct-slots ((class forward-referenced-class)) ())
(defmethod class-direct-default-initargs ((class forward-referenced-class)) ())
(macrolet ((def (method)
`(defmethod ,method ((class forward-referenced-class))
(error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
',method class))))
(def class-default-initargs)
(def class-precedence-list)
(def class-slots))
(defmethod validate-superclass ((c slot-class)
(f forward-referenced-class))
t)
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
(pushnew dependent (plist-value metaobject 'dependents)))
(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
(setf (plist-value metaobject 'dependents)
(delete dependent (plist-value metaobject 'dependents))))
(defmethod map-dependents ((metaobject dependent-update-mixin) function)
(dolist (dependent (plist-value metaobject 'dependents))
(funcall function dependent)))