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

Download this file

std-class.lisp    1728 lines (1568 with data), 79.2 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
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
;;;; 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)
(let ((info (slot-definition-info slotd)))
(ecase type
(reader (slot-info-reader info))
(writer (slot-info-writer info))
(boundp (slot-info-boundp info)))))
(defmethod (setf slot-accessor-function) (function
(slotd effective-slot-definition)
type)
(let ((info (slot-definition-info slotd)))
(ecase type
(reader (setf (slot-info-reader info) function))
(writer (setf (slot-info-writer info) function))
(boundp (setf (slot-info-boundp info) 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)))
(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)))
;; KLUDGE: this logic is cut'n'pasted from
;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is
;; only called later, because it does things that can't be
;; computed this early in class finalization; however, we need
;; this bit as early as possible. -- CSR, 2009-11-05
(setf (slot-accessor-std-p slotd type)
(let* ((std-method (standard-svuc-method type))
(str-method (structure-svuc-method type))
(types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
(types (if (eq type 'writer) `(t ,@types1) types1))
(methods (compute-applicable-methods-using-types gf types)))
(null (cdr methods))))
(setf (slot-accessor-function slotd type)
(lambda (&rest args)
(declare (dynamic-extent args))
;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
;; work here (see KLUDGE comment above).
(let ((fun (compute-slot-accessor-info slotd type gf)))
(apply fun args))))))))
(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition))
(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))))
;;; 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)))
(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))))
(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 is not finalized.~:@>" 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 :test #'eq)
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.
;;; This needs to be used recursively, in case a non-trivial user
;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another
;;; function using the same lock.
(defvar *specializer-lock* (sb-thread:make-mutex :name "Specializer lock"))
(defmethod add-direct-method :around ((specializer specializer) method)
;; All the actions done under this lock are done in an order
;; that is safe to unwind at any point.
(sb-thread::with-recursive-system-lock (*specializer-lock*)
(call-next-method)))
(defmethod remove-direct-method :around ((specializer specializer) method)
;; All the actions done under this lock are done in an order
;; that is safe to unwind at any point.
(sb-thread::with-recursive-system-lock (*specializer-lock*)
(call-next-method)))
(defmethod add-direct-method ((specializer class) (method method))
(let ((cell (slot-value specializer 'direct-methods)))
;; We need to first smash the CDR, because a parallel read may
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr cell) ()
(car cell) (adjoin method (car cell) :test #'eq)))
method)
(defmethod remove-direct-method ((specializer class) (method method))
(let ((cell (slot-value specializer 'direct-methods)))
;; We need to first smash the CDR, because a parallel read may
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr cell) ()
(car cell) (remove method (car cell))))
method)
(defmethod specializer-direct-methods ((specializer class))
(with-slots (direct-methods) specializer
(car direct-methods)))
(defmethod specializer-direct-generic-functions ((specializer class))
(let ((cell (slot-value specializer 'direct-methods)))
;; If an ADD/REMOVE-METHOD is in progress, no matter: either
;; we behave as if we got just first or just after -- it's just
;; for update that we need to lock.
(or (cdr cell)
(sb-thread:with-mutex (*specializer-lock*)
(setf (cdr cell)
(let (collect)
(dolist (m (car cell))
;; 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.
;;;
;;; These tables are shared between threads, so they need to be synchronized.
(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t))
(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t))
(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
(setf entry
(setf (gethash object table) (cons nil nil))))
;; We need to first smash the CDR, because a parallel read may
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr entry) ()
(car entry) (adjoin method (car entry) :test #'eq))
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
;; We need to first smash the CDR, because a parallel read may
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr entry) ()
(car entry) (remove method (car 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)
(sb-thread:with-mutex (*specializer-lock*)
(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 source-location safe-p)
(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 source-location
'safe-p safe-p
other)))
res)))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
(defun ensure-class (name &rest args)
(with-world-lock ()
(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)
(with-world-lock ()
(multiple-value-bind (meta initargs)
(frob-ensure-class-args args)
(setf class (apply #'make-instance meta :name name initargs))
(without-package-locks
(setf (find-class name) class))))
;; After boot (SETF FIND-CLASS) does this.
(unless (eq **boot-state** 'complete)
(%set-class-type-translation class name))
class)
(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
(with-world-lock ()
(multiple-value-bind (meta initargs)
(frob-ensure-class-args 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))))
;; After boot (SETF FIND-CLASS) does this.
(unless (eq **boot-state** 'complete)
(%set-class-type-translation class name))
class)
(defun frob-ensure-class-args (args)
(let (metaclass metaclassp reversed-plist)
(flet ((frob-superclass (s)
(cond
((classp s) s)
((legal-class-name-p s)
(or (find-class s nil)
(ensure-class s :metaclass 'forward-referenced-class)))
(t (error "Not a class or a legal class name: ~S." s)))))
(doplist (key val) args
(cond ((eq key :metaclass)
(unless metaclassp
(setf metaclass val metaclassp key)))
(t
(when (eq key :direct-superclasses)
(setf val (mapcar #'frob-superclass val)))
(setf reversed-plist (list* val key reversed-plist)))))
(values (cond (metaclassp
(if (classp metaclass)
metaclass
(find-class metaclass)))
(t *the-class-standard-class*))
(nreverse reversed-plist)))))
;;; This is used to call initfunctions of :allocation :class slots.
(defun call-initfun (fun slotd safe)
(declare (function fun))
(let ((value (funcall fun)))
(when safe
(let ((type (slot-definition-type slotd)))
(unless (or (eq t type)
(typep value type))
(error 'type-error :expected-type type :datum value))))
value))
(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)
definition-source)
(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))
(safe (safe-p class))
(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 :test #'eq))
(let* ((initfunction (slot-definition-initfunction dslotd))
(value
(if initfunction
(call-initfun initfunction dslotd safe)
+slot-unbound+)))
(push (cons name value) collect))
(push old collect)))))
(nreverse collect)))
(add-direct-subclasses class direct-superclasses)
(if (class-finalized-p class)
;; required by AMOP, "Reinitialization of Class Metaobjects"
(finalize-inheritance class)
(update-class class nil))
(add-slot-accessors class direct-slots definition-source)
(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))))
(with-world-lock ()
(without-package-locks
(unless (class-finalized-p class)
(let ((name (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.
(let ((layout (make-wrapper 0 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)
(%set-class-type-translation class (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 reinitialize-instance :after ((class condition-class) &key)
(let* ((name (class-name class))
(classoid (find-classoid name))
(slots (condition-classoid-slots classoid)))
;; to balance the REMOVE-SLOT-ACCESSORS call in
;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
(dolist (slot slots)
(let ((slot-name (condition-slot-name slot)))
(dolist (reader (condition-slot-readers slot))
;; FIXME: see comment in SHARED-INITIALIZE :AFTER
;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
(sb-kernel::install-condition-slot-reader reader name slot-name))
(dolist (writer (condition-slot-writers slot))
(sb-kernel::install-condition-slot-writer writer name slot-name))))))
(defmethod shared-initialize :after ((class condition-class) slot-names
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (slot-value class 'name))))
(with-slots (wrapper %class-precedence-list cpl-available-p
prototype (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)
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots)
(setf (layout-slot-table wrapper) (make-slot-table class slots)))))
;; 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.
;;
;; ??? What does the above comment mean and why is it a good idea?
;; CMUCL (which still as of 2005-11-18 uses this code and has this
;; comment) loses slot information in its condition classes:
;; DIRECT-SLOTS is always NIL. We have the right information, so we
;; remove slot accessors but never put them back. I've added a
;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
;; was meant to happen? -- CSR, 2005-11-18
)
(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))
(info (slot-definition-info slotd)))
(setf (slot-info-reader info)
(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-info-writer info)
(lambda (v x)
(condition-writer-function x v slot-name)))
(setf (slot-info-boundp info)
(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 #'finalize-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))
(included-name (class-name include))
(included-slots
(when include
(mapcar #'dsd-name (dd-slots (find-defstruct-description included-name)))))
(old-slots nil)
(new-slots nil)
(reader-names nil)
(writer-names nil))
(dolist (slotd (reverse direct-slots))
(let* ((slot-name (slot-definition-name slotd))
(initform (slot-definition-initform slotd))
(type (slot-definition-type slotd))
(desc `(,slot-name ,initform :type ,type)))
(push `(slot-accessor ,name ,slot-name reader)
reader-names)
(push `(slot-accessor ,name ,slot-name writer)
writer-names)
(if (member slot-name included-slots :test #'eq)
(push desc old-slots)
(push desc new-slots))))
(let* ((defstruct `(defstruct (,name
,@(when include
`((:include ,included-name
,@old-slots)))
(:constructor ,constructor ())
(:predicate nil)
(:conc-name ,conc-name)
(:copier nil))
,@new-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 (name)
;; FIXME: Why don't we go class->layout->info == dd
(let ((dd (find-defstruct-description name)))
(ecase (dd-type dd)
(structure
(%make-structure-instance-allocator dd nil))
(funcallable-structure
(%make-funcallable-structure-instance-allocator dd nil)))))
(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
definition-source)
(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 (slot-value class 'name) 'structure-object))
(list *the-class-structure-object*)))))
(setq direct-superclasses (slot-value class 'direct-superclasses)))
(let* ((name (slot-value class 'name))
(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 (fboundp 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)
;; KLUDGE: not class; in fixup.lisp, can't access slots
;; outside methods yet.
(make-defstruct-allocation-function name)))
(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)
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots)
(let* ((lclass (find-classoid (slot-value class 'name)))
(layout (classoid-layout lclass)))
(setf (classoid-pcl-class lclass) class)
(setf (slot-value class 'wrapper) layout)
(setf (layout-slot-table layout) (make-slot-table class slots))))
(setf (slot-value class 'finalized-p) t)
(add-slot-accessors class direct-slots definition-source)))
(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 &optional source-location)
(fix-slot-accessors class dslotds 'add source-location))
(defun remove-slot-accessors (class dslotds)
(fix-slot-accessors class dslotds 'remove))
(defun fix-slot-accessors (class dslotds add/remove &optional source-location)
(flet ((fix (gfspec name r/w doc)
(let ((gf (cond ((eq add/remove 'add)
(or (find-generic-function gfspec nil)
(ensure-generic-function
gfspec :lambda-list (case r/w
(r '(object))
(w '(new-value object))))))
(t
(find-generic-function gfspec nil)))))
(when gf
(case r/w
(r (if (eq add/remove 'add)
(add-reader-method class gf name doc source-location)
(remove-reader-method class gf)))
(w (if (eq add/remove 'add)
(add-writer-method class gf name doc source-location)
(remove-writer-method class gf))))))))
(dolist (dslotd dslotds)
(let ((slot-name (slot-definition-name dslotd))
(slot-doc (%slot-definition-documentation dslotd)))
(dolist (r (slot-definition-readers dslotd))
(fix r slot-name 'r slot-doc))
(dolist (w (slot-definition-writers dslotd))
(fix w slot-name 'w slot-doc))))))
(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 (when (forward-referenced-class-p class)
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)
(without-package-locks
(with-world-lock ()
(when (or finalizep (class-finalized-p class))
(%update-cpl class (compute-class-precedence-list class))
;; This invocation of UPDATE-SLOTS, in practice, finalizes the
;; class.
(%update-slots class (compute-slots class))
(update-gfs-of-class class)
(setf (plist-value class 'default-initargs) (compute-default-initargs class))
(update-ctors 'finalize-inheritance :class class))
(dolist (sub (class-direct-subclasses class))
(update-class sub nil)))))
(define-condition cpl-protocol-violation (reference-condition error)
((class :initarg :class :reader cpl-protocol-violation-class)
(cpl :initarg :cpl :reader cpl-protocol-violation-cpl))
(:default-initargs :references (list '(:sbcl :node "Metaobject Protocol")))
(:report
(lambda (c s)
(format s "~@<Protocol violation: the ~S class ~S ~
~:[has~;does not have~] the class ~S in its ~
class precedence list: ~S.~@:>"
(class-name (class-of (cpl-protocol-violation-class c)))
(cpl-protocol-violation-class c)
(eq (class-of (cpl-protocol-violation-class c))
*the-class-funcallable-standard-class*)
(find-class 'function)
(cpl-protocol-violation-cpl c)))))
(defun %update-cpl (class cpl)
(when (eq (class-of class) *the-class-standard-class*)
(when (find (find-class 'function) cpl)
(error 'cpl-protocol-violation :class class :cpl cpl)))
(when (eq (class-of class) *the-class-funcallable-standard-class*)
(unless (find (find-class 'function) cpl)
(error 'cpl-protocol-violation :class class :cpl 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) :test #'eq)))
(update-class-can-precede-p (cdr cpl))))
(defun class-can-precede-p (class1 class2)
(member class2 (class-can-precede-list class1) :test #'eq))
;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
;;;
;;; In addition to slot locations (implicit in the ordering of the slots), we
;;; must check classes: SLOT-INFO structures from old slotds may have been
;;; cached in permutation vectors, but new slotds have had new ones allocated
;;; to them. This is non-problematic for standard slotds, because we know the
;;; structure is compatible, but if a slot definition class changes, this can
;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
;;;
;;; Also, if the slot has a non-standard allocation, we need to check that it
;;; doesn't change.
(defun slot-layouts-compatible-p
(oslotds new-instance-slotds new-class-slotds new-custom-slotds)
(multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds)
(classify-slotds oslotds)
(and
;; Instance slots: name, type, and class.
(dolist (o old-instance-slotds (not new-instance-slotds))
(let ((n (pop new-instance-slotds)))
(unless (and n
(eq (slot-definition-name o) (slot-definition-name n))
(eq (slot-definition-type o) (slot-definition-type n))
(eq (class-of o) (class-of n)))
(return nil))))
;; Class slots: name and class. (FIXME: class slots not typechecked?)
(dolist (o old-class-slotds (not new-class-slotds))
(let ((n (pop new-class-slotds)))
(unless (and n
(eq (slot-definition-name o) (slot-definition-name n))
(eq (class-of n) (class-of o)))
(return nil))))
;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
(dolist (o old-custom-slotds (not new-custom-slotds))
(let ((n (pop new-custom-slotds)))
(unless (and n
(eq (slot-definition-name o) (slot-definition-name n))
(eq (slot-definition-type o) (slot-definition-type n))
(eq (slot-definition-allocation o) (slot-definition-allocation n))
(eq (class-of o) (class-of n)))
(return nil)))))))
(defun style-warn-about-duplicate-slots (class)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
((null slots)
(when dupes
(style-warn
"~@<slot names with the same SYMBOL-NAME but ~
different SYMBOL-PACKAGE (possible package problem) ~
for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
class dupes)))
(let* ((slot-name (slot-definition-name (car slots)))
(oslots (and (not (eq (symbol-package slot-name)
*pcl-package*))
(remove-if
(lambda (slot-name-2)
(or (eq (symbol-package slot-name-2)
*pcl-package*)
(string/= slot-name slot-name-2)))
(cdr slots)
:key #'slot-definition-name))))
(when oslots
(pushnew (cons slot-name
(mapcar #'slot-definition-name oslots))
dupes
:test #'string= :key #'car)))))
(defun %update-slots (class eslotds)
(multiple-value-bind (instance-slots class-slots custom-slots)
(classify-slotds eslotds)
(let* ((nslots (length instance-slots))
(owrapper (when (class-finalized-p class) (class-wrapper class)))
(nwrapper
(cond ((null owrapper)
(make-wrapper nslots class))
((slot-layouts-compatible-p (wrapper-slots owrapper)
instance-slots class-slots custom-slots)
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)))))
(%update-lisp-class-layout class nwrapper)
(setf (slot-value class 'slots) eslotds
(wrapper-slots nwrapper) eslotds
(wrapper-slot-table nwrapper) (make-slot-table class eslotds)
(wrapper-length nwrapper) nslots
(slot-value class 'wrapper) nwrapper)
(style-warn-about-duplicate-slots class)
(setf (slot-value class 'finalized-p) t)
(unless (eq owrapper nwrapper)
(maybe-update-standard-slot-locations class)))))
(defun update-gf-dfun (class gf)
(let ((*new-class* class)
(arg-info (gf-arg-info gf)))
(cond
((special-case-for-compute-discriminating-function-p gf))
((gf-precompute-dfun-and-emf-p arg-info)
(multiple-value-bind (dfun cache info) (make-final-dfun-internal gf)
(update-dfun gf dfun cache info))))))
(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 :test #'eq)
(member *the-class-standard-effective-slot-definition*
cpl :test #'eq))))
(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)))))
(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))
;;; I (CSR) am not sure, but I believe that the particular order of
;;; slots is quite important: it is ideal to attempt to have a
;;; constant slot location for the same notional slots as much as
;;; possible, so that clever discriminating functions (ONE-INDEX et
;;; al.) have a chance of working. The below at least walks through
;;; the slots predictably, but maybe it would be good to compute some
;;; kind of optimal slot layout by looking at locations of slots in
;;; superclasses?
(defun std-compute-slots (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 (reverse (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)
(cdr direct)))
(nreverse name-dslotds-alist))))
(defmethod compute-slots ((class standard-class))
(std-compute-slots class))
(defmethod compute-slots ((class funcallable-standard-class))
(std-compute-slots class))
(defun std-compute-slots-around (class eslotds)
(let ((location -1)
(safe (safe-p class)))
(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))
(let ((c (cons name +slot-unbound+)))
(push c (class-slot-cells from-class))
c))))
(aver (consp cell))
(if (eq +slot-unbound+ (cdr cell))
;; We may have inherited an initfunction FIXME: Is this
;; really right? Is the initialization in
;; SHARED-INITIALIZE (STD-CLASS) not enough?
(let ((initfun (slot-definition-initfunction eslotd)))
(if initfun
(rplacd cell (call-initfun initfun eslotd safe))
cell))
cell)))))
(unless (slot-definition-class eslotd)
(setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
(defmethod compute-slots :around ((class standard-class))
(let ((eslotds (call-next-method)))
(std-compute-slots-around class eslotds)))
(defmethod compute-slots :around ((class funcallable-standard-class))
(let ((eslotds (call-next-method)))
(std-compute-slots-around class eslotds)))
(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 #'finalize-internal-slot-functions eslotds)
eslotds))
(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
(class (apply #'effective-slot-definition-class class initargs))
(slotd (apply #'make-instance class initargs)))
slotd))
(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)
(documentation nil)
(documentationp nil)
(namep nil)
(initp nil)
(allocp nil))
(dolist (slotd direct-slotds)
(when slotd
(unless namep
(setq name (slot-definition-name slotd)
namep t))
(unless initp
(awhen (slot-definition-initfunction slotd)
(setq initform (slot-definition-initform slotd)
initfunction it
initp t)))
(unless documentationp
(awhen (%slot-definition-documentation slotd)
(setq documentation it
documentationp 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)
;; This pairwise type intersection is perhaps a
;; little inefficient and inelegant, but it's
;; unlikely to lie on the critical path. Shout
;; if I'm wrong. -- CSR, 2005-11-24
(t (type-specifier
(specifier-type `(and ,type ,slotd-type)))))))))
(list :name name
:initform initform
:initfunction initfunction
:initargs initargs
:allocation allocation
:allocation-class allocation-class
:type type
:class class
:documentation documentation)))
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
(let* ((slotd (car direct-slotds))
(accessor (slot-definition-defstruct-accessor-symbol slotd)))
(list* :defstruct-accessor-symbol accessor
: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 slot-documentation source-location)
(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)
(or slot-documentation "automatically generated reader method")
:slot-name slot-name
:object-class class
:method-class-function #'reader-method-class
:definition-source source-location)))
(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 slot-documentation source-location)
(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)
(or slot-documentation "automatically generated writer method")
:slot-name slot-name
:object-class class
:method-class-function #'writer-method-class
:definition-source source-location)))
(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation source-location)
(add-method generic-function
(make-a-method (constantly (find-class 'standard-boundp-method))
class
()
(list (or (class-name class) 'object))
(list class)
(make-boundp-method-function class slot-name)
(or slot-documentation "automatically generated boundp method")
:slot-name slot-name
:definition-source source-location)))
(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 slot-name))
(defmethod make-writer-method-function ((class slot-class) slot-name)
(make-std-writer-method-function class slot-name))
(defmethod make-boundp-method-function ((class slot-class) slot-name)
(make-std-boundp-method-function 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) (superclass class))
(or (eq superclass *the-class-t*)
(eq (class-of class) (class-of superclass))
(and (eq (class-of superclass) *the-class-standard-class*)
(eq (class-of class) *the-class-funcallable-standard-class*))
(and (eq (class-of superclass) *the-class-funcallable-standard-class*)
(eq (class-of class) *the-class-standard-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 (layout-length owrapper)
class)))
(setf (wrapper-slots nwrapper)
(wrapper-slots owrapper))
(setf (wrapper-slot-table nwrapper)
(wrapper-slot-table owrapper))
(%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))))))
;;; 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))
(with-world-lock ()
(let* ((owrapper (class-wrapper class))
(nwrapper (make-wrapper (layout-length owrapper)
class)))
(unless (class-finalized-p class)
(if (class-has-a-forward-referenced-superclass-p class)
(return-from make-instances-obsolete class)
(%update-cpl class (compute-class-precedence-list class))))
(setf (wrapper-slots nwrapper)
(wrapper-slots owrapper))
(setf (wrapper-slot-table nwrapper)
(wrapper-slot-table owrapper))
(%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 (layout-for-std-class-p owrapper))
(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 ???
(oslots (get-slots instance))
(nslots (get-slots copy))
(added ())
(discarded ())
(plist ())
(safe (safe-p class)))
;; local --> local transfer value, check type
;; local --> shared discard value, discard slot
;; local --> -- discard slot
;; local --> custom XXX
;; shared --> local transfer value, check type
;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
;; shared --> -- discard value
;; shared --> custom XXX
;; -- --> local add slot
;; -- --> shared --
;; -- --> custom XXX
(multiple-value-bind (new-instance-slots new-class-slots new-custom-slots)
(classify-slotds (wrapper-slots nwrapper))
(declare (ignore new-class-slots))
(multiple-value-bind (old-instance-slots old-class-slots old-custom-slots)
(classify-slotds (wrapper-slots owrapper))
(let ((layout (mapcar (lambda (slotd)
;; Get the names only once.
(cons (slot-definition-name slotd) slotd))
new-instance-slots)))
(flet ((set-value (value cell)
(let ((name (car cell))
(slotd (cdr cell)))
(when (and safe (neq value +slot-unbound+))
(let ((type (slot-definition-type slotd)))
(assert
(typep value type) (value)
"~@<Error updating obsolete instance. Current value in slot ~
~S of an instance of ~S is ~S, which does not match the new ~
slot type ~S.~:@>"
name class value type)))
(setf (clos-slots-ref nslots (slot-definition-location slotd)) value
;; Prune from the list now that it's been dealt with.
layout (remove cell layout)))))
;; Go through all the old local slots.
(dolist (old old-instance-slots)
(let* ((name (slot-definition-name old))
(value (clos-slots-ref oslots (slot-definition-location old))))
(unless (eq value +slot-unbound+)
(let ((new (assq name layout)))
(cond (new
(set-value value new))
(t
(push name discarded)
(setf (getf plist name) value)))))))
;; Go through all the old shared slots.
(dolist (old old-class-slots)
(let* ((cell (slot-definition-location old))
(name (car cell))
(new (assq name layout)))
(when new
(set-value (cdr cell) new))))
;; Go through all custom slots to find added ones. CLHS
;; doesn't specify what to do about them, and neither does
;; AMOP. We do want them to get initialized, though, so we
;; list them in ADDED for the benefit of SHARED-INITIALIZE.
(dolist (new new-custom-slots)
(let* ((name (slot-definition-name new))
(old (find name old-custom-slots :key #'slot-definition-name)))
(unless old
(push name added))))
;; Go through all the remaining new local slots to compute the added slots.
(dolist (cell layout)
(push (car cell) added))))))
(%swap-wrappers-and-slots instance copy)
(update-instance-for-redefined-class instance
added
discarded
plist)
nwrapper)))
(defun %change-class (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-slots (get-slots instance))
(new-slots (get-slots copy))
(safe (safe-p new-class)))
(multiple-value-bind (new-instance-slots new-class-slots)
(classify-slotds (wrapper-slots new-wrapper))
(multiple-value-bind (old-instance-slots old-class-slots)
(classify-slotds (wrapper-slots old-wrapper))
(flet ((set-value (value slotd)
(when safe
(assert (typep value (slot-definition-type slotd)) (value)
"~@<Error changing class. Current value in slot ~S ~
of an instance of ~S is ~S, which does not match the new ~
slot type ~S in class ~S.~:@>"
(slot-definition-name slotd) old-class value
(slot-definition-type slotd) new-class))
(setf (clos-slots-ref new-slots (slot-definition-location slotd)) value)))
;; "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."
(dolist (new new-instance-slots)
(let* ((name (slot-definition-name new))
(old (find name old-instance-slots :key #'slot-definition-name)))
(when old
(set-value (clos-slots-ref old-slots (slot-definition-location old))
new))))
;; "The values of slots specified as shared in the class CFROM and
;; as local in the class CTO are retained."
(dolist (old old-class-slots)
(let* ((slot-and-val (slot-definition-location old))
(new (find (car slot-and-val) new-instance-slots
:key #'slot-definition-name)))
(when new
(set-value (cdr slot-and-val) new)))))))
;; 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)
(with-world-lock ()
(unless (class-finalized-p new-class)
(finalize-inheritance new-class))
(let ((cpl (class-precedence-list new-class)))
(dolist (class cpl)
(macrolet
((frob (class-name)
`(when (eq class (find-class ',class-name))
(error 'metaobject-initialization-violation
:format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
:format-arguments (list 'change-class ',class-name)
:references (list '(:amop :initialization ,class-name))))))
(frob class)
(frob generic-function)
(frob method)
(frob slot-definition))))
(%change-class instance new-class initargs)))
(defmethod change-class ((instance forward-referenced-class)
(new-class standard-class) &rest initargs)
(with-world-lock ()
(let ((cpl (class-precedence-list new-class)))
(dolist (class cpl
(error 'metaobject-initialization-violation
:format-control
"~@<Cannot ~S ~S objects into non-~S objects.~@:>"
:format-arguments
(list 'change-class 'forward-referenced-class 'class)
:references
(list '(:amop :generic-function ensure-class-using-class)
'(:amop :initialization class))))
(when (eq class (find-class 'class))
(return nil))))
(%change-class instance new-class initargs)))
(defmethod change-class ((instance funcallable-standard-object)
(new-class funcallable-standard-class)
&rest initargs)
(with-world-lock ()
(let ((cpl (class-precedence-list new-class)))
(dolist (class cpl)
(macrolet
((frob (class-name)
`(when (eq class (find-class ',class-name))
(error 'metaobject-initialization-violation
:format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
:format-arguments (list 'change-class ',class-name)
:references (list '(:amop :initialization ,class-name))))))
(frob class)
(frob generic-function)
(frob method)
(frob slot-definition))))
(%change-class 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.
(macrolet ((def (name args control)
`(defmethod ,name ,args
(declare (ignore initargs))
(error 'metaobject-initialization-violation
:format-control ,(format nil "~@<~A~@:>" control)
:format-arguments (list ',name)
:references (list '(:amop :initialization "Class"))))))
(def initialize-instance ((class built-in-class) &rest initargs)
"Cannot ~S an instance of BUILT-IN-CLASS.")
(def reinitialize-instance ((class built-in-class) &rest initargs)
"Cannot ~S an instance of BUILT-IN-CLASS."))
(macrolet ((def (name)
`(defmethod ,name ((class built-in-class)) nil)))
(def class-direct-slots)
(def class-slots)
(def class-direct-default-initargs)
(def class-default-initargs))
(defmethod validate-superclass ((c class) (s built-in-class))
(or (eq s *the-class-t*) (eq s *the-class-stream*)
;; FIXME: bad things happen if someone tries to mix in both
;; FILE-STREAM and STRING-STREAM (as they have the same
;; layout-depthoid). Is there any way we can provide a useful
;; error message? -- CSR, 2005-05-03
(eq s *the-class-file-stream*) (eq s *the-class-string-stream*)
;; This probably shouldn't be mixed in with certain other
;; classes, too, but it seems to work both with STANDARD-OBJECT
;; and FUNCALLABLE-STANDARD-OBJECT
(eq s *the-class-sequence*)))
;;; 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) :test #'eq))
(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)))