Source

XEmacs / src / specifier.c

   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
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
/* Specifier implementation
   Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
   Copyright (C) 1995, 1996 Ben Wing.
   Copyright (C) 1995 Sun Microsystems, Inc.

This file is part of XEmacs.

XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.

XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* Synched up with: Not in FSF. */

/* Design by Ben Wing;
   Original version by Chuck Thompson;
   rewritten by Ben Wing;
   Magic specifiers by Kirill Katsnelson;
*/

#include <config.h>
#include "lisp.h"

#include "buffer.h"
#include "device.h"
#include "frame.h"
#include "opaque.h"
#include "specifier.h"
#include "window.h"
#include "glyphs.h"  /* for DISP_TABLE_SIZE definition */

Lisp_Object Qspecifierp;
Lisp_Object Qprepend, Qappend, Qremove_tag_set_prepend, Qremove_tag_set_append;
Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
Lisp_Object Qfallback;

/* Qinteger, Qboolean, Qgeneric defined in general.c. */
Lisp_Object Qnatnum;

Lisp_Object Qconsole_type, Qdevice_class;

static Lisp_Object Vuser_defined_tags;

typedef struct specifier_type_entry specifier_type_entry;
struct specifier_type_entry
{
  Lisp_Object symbol;
  struct specifier_methods *meths;
};

typedef struct
{
  Dynarr_declare (specifier_type_entry);
} specifier_type_entry_dynarr;

specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;

static Lisp_Object Vspecifier_type_list;

static Lisp_Object Vcached_specifiers;
/* Do NOT mark through this, or specifiers will never be GC'd. */
static Lisp_Object Vall_specifiers;

static Lisp_Object Vunlock_ghost_specifiers;

/* #### The purpose of this is to check for inheritance loops
   in specifiers that can inherit from other specifiers, but it's
   not yet implemented.

   #### Look into this for 19.14. */
/* static Lisp_Object_dynarr current_specifiers; */

static void recompute_cached_specifier_everywhere (Lisp_Object specifier);

EXFUN (Fspecifier_specs, 4);
EXFUN (Fremove_specifier, 4);


/************************************************************************/
/*                       Specifier object methods                       */
/************************************************************************/

/* Remove dead objects from the specified assoc list. */

static Lisp_Object
cleanup_assoc_list (Lisp_Object list)
{
  Lisp_Object loop, prev, retval;

  loop = retval = list;
  prev = Qnil;

  while (!NILP (loop))
    {
      Lisp_Object entry = XCAR (loop);
      Lisp_Object key = XCAR (entry);

      /* remember, dead windows can become alive again. */
      if (!WINDOWP (key) && object_dead_p (key))
	{
	  if (NILP (prev))
	    {
	      /* Removing the head. */
	      retval = XCDR (retval);
	    }
	  else
	    {
	      Fsetcdr (prev, XCDR (loop));
	    }
	}
      else
	prev = loop;

      loop = XCDR (loop);
    }

  return retval;
}

/* Remove dead objects from the various lists so that they
   don't keep getting marked as long as this specifier exists and
   therefore wasting memory. */

void
cleanup_specifiers (void)
{
  Lisp_Object rest;

  for (rest = Vall_specifiers;
       !NILP (rest);
       rest = XSPECIFIER (rest)->next_specifier)
    {
      struct Lisp_Specifier *sp = XSPECIFIER (rest);
      /* This effectively changes the specifier specs.
	 However, there's no need to call
	 recompute_cached_specifier_everywhere() or the
	 after-change methods because the only specs we
	 are removing are for dead objects, and they can
	 never have any effect on the specifier values:
	 specifiers can only be instantiated over live
	 objects, and you can't derive a dead object
	 from a live one. */
      sp->device_specs = cleanup_assoc_list (sp->device_specs);
      sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
      sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
      /* windows are handled specially because dead windows
	 can be resurrected */
    }
}

void
kill_specifier_buffer_locals (Lisp_Object buffer)
{
  Lisp_Object rest;

  for (rest = Vall_specifiers;
       !NILP (rest);
       rest = XSPECIFIER (rest)->next_specifier)
    {
      struct Lisp_Specifier *sp = XSPECIFIER (rest);

      /* Make sure we're actually going to be changing something.
	 Fremove_specifier() always calls
	 recompute_cached_specifier_everywhere() (#### but should
	 be smarter about this). */
      if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
	Fremove_specifier (rest, buffer, Qnil, Qnil);
    }
}

static Lisp_Object
mark_specifier (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
  struct Lisp_Specifier *specifier = XSPECIFIER (obj);

  ((markobj) (specifier->global_specs));
  ((markobj) (specifier->device_specs));
  ((markobj) (specifier->frame_specs));
  ((markobj) (specifier->window_specs));
  ((markobj) (specifier->buffer_specs));
  ((markobj) (specifier->magic_parent));
  ((markobj) (specifier->fallback));
  if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
    MAYBE_SPECMETH (specifier, mark, (obj, markobj));
  return Qnil;
}

/* The idea here is that the specifier specs point to locales
   (windows, buffers, frames, and devices), and we want to make sure
   that the specs disappear automatically when the associated locale
   is no longer in use.  For all but windows, "no longer in use"
   corresponds exactly to when the object is deleted (non-deleted
   objects are always held permanently in special lists, and deleted
   objects are never on these lists and never reusable).  To handle
   this, we just have cleanup_specifiers() called periodically
   (at the beginning of garbage collection); it removes all dead
   objects.

   For windows, however, it's trickier because dead objects can be
   converted to live ones again if the dead object is in a window
   configuration.  Therefore, for windows, "no longer in use"
   corresponds to when the window object is garbage-collected.
   We now use weak lists for this purpose.

*/

void
prune_specifiers (int (*obj_marked_p) (Lisp_Object))
{
  Lisp_Object rest, prev = Qnil;

  for (rest = Vall_specifiers;
       !GC_NILP (rest);
       rest = XSPECIFIER (rest)->next_specifier)
    {
      if (! ((*obj_marked_p) (rest)))
	{
	  struct Lisp_Specifier* sp = XSPECIFIER (rest);
	  /* A bit of assertion that we're removing both parts of the
             magic one altogether */
	  assert (!GC_MAGIC_SPECIFIER_P(sp)
		  || (GC_BODILY_SPECIFIER_P(sp) && (*obj_marked_p)(sp->fallback))
		  || (GC_GHOST_SPECIFIER_P(sp) && (*obj_marked_p)(sp->magic_parent)));
	  /* This specifier is garbage.  Remove it from the list. */
	  if (GC_NILP (prev))
	    Vall_specifiers = sp->next_specifier;
	  else
	    XSPECIFIER (prev)->next_specifier = sp->next_specifier;
	}
      else
	prev = rest;
    }
}

static void
print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
  struct Lisp_Specifier *sp = XSPECIFIER (obj);
  char buf[100];
  int count = specpdl_depth ();
  Lisp_Object the_specs;

  if (print_readably)
    error ("printing unreadable object #<%s-specifier 0x%x>",
	   sp->methods->name, sp->header.uid);

  sprintf (buf, "#<%s-specifier global=", sp->methods->name);
  write_c_string (buf, printcharfun);
  specbind (Qprint_string_length, make_int (100));
  specbind (Qprint_length, make_int (5));
  the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
  if (NILP (the_specs))
    /* there are no global specs */
    write_c_string ("<unspecified>", printcharfun);
  else
    print_internal (the_specs, printcharfun, 1);
  if (!NILP (sp->fallback))
    {
      write_c_string (" fallback=", printcharfun);
      print_internal (sp->fallback, printcharfun, escapeflag);
    }
  unbind_to (count, Qnil);
  sprintf (buf, " 0x%x>", sp->header.uid);
  write_c_string (buf, printcharfun);
}

static void
finalize_specifier (void *header, int for_disksave)
{
  struct Lisp_Specifier *sp = (struct Lisp_Specifier *) header;
  /* don't be snafued by the disksave finalization. */
  if (!for_disksave && !GC_GHOST_SPECIFIER_P(sp) && sp->caching)
    {
      xfree (sp->caching);
      sp->caching = 0;
    }
}

static int
specifier_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
  struct Lisp_Specifier *s1 = XSPECIFIER (o1);
  struct Lisp_Specifier *s2 = XSPECIFIER (o2);
  int retval;
  Lisp_Object old_inhibit_quit = Vinhibit_quit;

  /* This function can be called from within redisplay.
     internal_equal can trigger a quit.  That leads to Bad Things. */
  Vinhibit_quit = Qt;

  depth++;
  retval =
    (s1->methods == s2->methods &&
     internal_equal (s1->global_specs, s2->global_specs, depth) &&
     internal_equal (s1->device_specs, s2->device_specs, depth) &&
     internal_equal (s1->frame_specs,  s2->frame_specs,  depth) &&
     internal_equal (s1->window_specs, s2->window_specs, depth) &&
     internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
     internal_equal (s1->fallback,     s2->fallback,     depth));

  if (retval && HAS_SPECMETH_P (s1, equal))
    retval = SPECMETH (s1, equal, (o1, o2, depth - 1));

  Vinhibit_quit = old_inhibit_quit;
  return retval;
}

static unsigned long
specifier_hash (Lisp_Object obj, int depth)
{
  struct Lisp_Specifier *s = XSPECIFIER (obj);

  /* specifier hashing is a bit problematic because there are so
     many places where data can be stored.  We pick what are perhaps
     the most likely places where interesting stuff will be. */
  return HASH5 ((HAS_SPECMETH_P (s, hash) ?
		 SPECMETH (s, hash, (obj, depth)) : 0),
		(unsigned long) s->methods,
		internal_hash (s->global_specs, depth + 1),
		internal_hash (s->frame_specs,  depth + 1),
		internal_hash (s->buffer_specs, depth + 1));
}

static size_t
sizeof_specifier (CONST void *header)
{
  if (GHOST_SPECIFIER_P ((struct Lisp_Specifier *) header))
    return sizeof (struct Lisp_Specifier);
  else
    {
      CONST struct Lisp_Specifier *p = (CONST struct Lisp_Specifier *) header;
      return sizeof (*p) + p->methods->extra_data_size - 1;
    }
}

DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
					mark_specifier, print_specifier,
					finalize_specifier,
					specifier_equal, specifier_hash,
					sizeof_specifier,
					struct Lisp_Specifier);

/************************************************************************/
/*                       Creating specifiers                            */
/************************************************************************/

static struct specifier_methods *
decode_specifier_type (Lisp_Object type, Error_behavior errb)
{
  int i;

  for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
    {
      if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
	return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
    }

  maybe_signal_simple_error ("Invalid specifier type", type,
			     Qspecifier, errb);

  return 0;
}

static int
valid_specifier_type_p (Lisp_Object type)
{
  return decode_specifier_type (type, ERROR_ME_NOT) != 0;
}

DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
Given a SPECIFIER-TYPE, return non-nil if it is valid.
Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
'face-boolean, and 'toolbar.
*/
       (specifier_type))
{
  return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
}

DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
Return a list of valid specifier types.
*/
       ())
{
  return Fcopy_sequence (Vspecifier_type_list);
}

void
add_entry_to_specifier_type_list (Lisp_Object symbol,
				  struct specifier_methods *meths)
{
  struct specifier_type_entry entry;

  entry.symbol = symbol;
  entry.meths = meths;
  Dynarr_add (the_specifier_type_entry_dynarr, entry);
  Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
}

static Lisp_Object
make_specifier_internal (struct specifier_methods *spec_meths,
			 size_t data_size, int call_create_meth)
{
  Lisp_Object specifier;
  struct Lisp_Specifier *sp = (struct Lisp_Specifier *)
    alloc_lcrecord (sizeof (struct Lisp_Specifier) +
		    data_size - 1, lrecord_specifier);

  sp->methods = spec_meths;
  sp->global_specs = Qnil;
  sp->device_specs = Qnil;
  sp->frame_specs = Qnil;
  sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
  sp->buffer_specs = Qnil;
  sp->fallback = Qnil;
  sp->magic_parent = Qnil;
  sp->caching = 0;
  sp->next_specifier = Vall_specifiers;

  XSETSPECIFIER (specifier, sp);
  Vall_specifiers = specifier;

  if (call_create_meth)
    {
      struct gcpro gcpro1;
      GCPRO1 (specifier);
      MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
      UNGCPRO;
    }
  return specifier;
}

static Lisp_Object
make_specifier (struct specifier_methods *meths)
{
  return make_specifier_internal (meths, meths->extra_data_size, 1);
}

Lisp_Object
make_magic_specifier (Lisp_Object type)
{
  /* This function can GC */
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
  Lisp_Object bodily, ghost;
  struct gcpro gcpro1;

  bodily = make_specifier (meths);
  GCPRO1 (bodily);
  ghost  = make_specifier_internal (meths, 0, 0);
  UNGCPRO;

  /* Connect guys together */
  XSPECIFIER(bodily)->magic_parent = Qt;
  XSPECIFIER(bodily)->fallback = ghost;
  XSPECIFIER(ghost)->magic_parent = bodily;

  return bodily;
}

DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
Return a new specifier object of type TYPE.

A specifier is an object that can be used to keep track of a property
whose value can be per-buffer, per-window, per-frame, or per-device,
and can further be restricted to a particular console-type or device-class.
Specifiers are used, for example, for the various built-in properties of a
face; this allows a face to have different values in different frames,
buffers, etc.  For more information, see `specifier-instance',
`specifier-specs', and `add-spec-to-specifier'; or, for a detailed
description of specifiers, including how they are instantiated over a
particular domain (i.e. how their value in that domain is determined),
see the chapter on specifiers in the XEmacs Lisp Reference Manual.

TYPE specifies the particular type of specifier, and should be one of
the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,
'face-boolean, or 'toolbar.

For more information on particular types of specifiers, see the functions
`generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',
`color-specifier-p', `font-specifier-p', `image-specifier-p',
`face-boolean-specifier-p', and `toolbar-specifier-p'.
*/
       (type))
{
  /* This function can GC */
  struct specifier_methods *meths = decode_specifier_type (type,
							   ERROR_ME);

  return make_specifier (meths);
}

DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
Return t if OBJECT is a specifier.

A specifier is an object that can be used to keep track of a property
whose value can be per-buffer, per-window, per-frame, or per-device,
and can further be restricted to a particular console-type or device-class.
See `make-specifier'.
*/
       (object))
{
  return SPECIFIERP (object) ? Qt : Qnil;
}

DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
Return the type of SPECIFIER.
*/
       (specifier))
{
  CHECK_SPECIFIER (specifier);
  return intern (XSPECIFIER (specifier)->methods->name);
}


/************************************************************************/
/*                       Locales and domains                            */
/************************************************************************/

DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
Return t if LOCALE is a valid specifier locale.
Valid locales are devices, frames, windows, buffers, and 'global.
\(nil is not valid.)
*/
       (locale))
{
  /* This cannot GC. */
  return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
	  (FRAMEP  (locale) && FRAME_LIVE_P  (XFRAME  (locale))) ||
	  (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
	  /* dead windows are allowed because they may become live
	     windows again when a window configuration is restored */
	  WINDOWP (locale) ||
	  EQ (locale, Qglobal))
    ? Qt : Qnil;
}

DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
Return t if DOMAIN is a valid specifier domain.
A domain is used to instance a specifier (i.e. determine the specifier's
value in that domain).  Valid domains are windows, frames, and devices.
\(nil is not valid.)
*/
     (domain))
{
  /* This cannot GC. */
  return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
	  (FRAMEP  (domain) && FRAME_LIVE_P  (XFRAME  (domain))) ||
	  (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
    ? Qt : Qnil;
}

DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
Given a specifier LOCALE-TYPE, return non-nil if it is valid.
Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
\(Note, however, that in functions that accept either a locale or a locale
type, 'global is considered an individual locale.)
*/
     (locale_type))
{
  /* This cannot GC. */
  return (EQ (locale_type, Qglobal) ||
	  EQ (locale_type, Qdevice) ||
	  EQ (locale_type, Qframe)  ||
	  EQ (locale_type, Qwindow) ||
	  EQ (locale_type, Qbuffer)) ? Qt : Qnil;
}

static void
check_valid_locale_or_locale_type (Lisp_Object locale)
{
  /* This cannot GC. */
  if (EQ (locale, Qall) ||
      !NILP (Fvalid_specifier_locale_p (locale)) ||
      !NILP (Fvalid_specifier_locale_type_p (locale)))
    return;
  signal_simple_error ("Invalid specifier locale or locale type", locale);
}

DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
       1, 1, 0, /*
Given a specifier LOCALE, return its type.
*/
       (locale))
{
  /* This cannot GC. */
  if (NILP (Fvalid_specifier_locale_p (locale)))
    signal_simple_error ("Invalid specifier locale", locale);
  if (DEVICEP (locale)) return Qdevice;
  if (FRAMEP  (locale)) return Qframe;
  if (WINDOWP (locale)) return Qwindow;
  if (BUFFERP (locale)) return Qbuffer;
  assert (EQ (locale, Qglobal));
  return Qglobal;
}

static Lisp_Object
decode_locale (Lisp_Object locale)
{
  /* This cannot GC. */
  if (NILP (locale))
    return Qglobal;
  else if (!NILP (Fvalid_specifier_locale_p (locale)))
    return locale;
  else
    signal_simple_error ("Invalid specifier locale", locale);

  return Qnil;
}

static enum spec_locale_type
decode_locale_type (Lisp_Object locale_type)
{
  /* This cannot GC. */
  if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
  if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
  if (EQ (locale_type, Qframe))  return LOCALE_FRAME;
  if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
  if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;

  signal_simple_error ("Invalid specifier locale type", locale_type);
  return LOCALE_GLOBAL; /* not reached */
}

Lisp_Object
decode_locale_list (Lisp_Object locale)
{
  /* This cannot GC. */
  /* The return value of this function must be GCPRO'd. */
  if (NILP (locale))
    locale = list1 (Qall);
  else
    {
      Lisp_Object rest;
      if (!CONSP (locale))
	locale = list1 (locale);
      EXTERNAL_LIST_LOOP (rest, locale)
	check_valid_locale_or_locale_type (XCAR (rest));
    }
  return locale;
}

static enum spec_locale_type
locale_type_from_locale (Lisp_Object locale)
{
  return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
}

static void
check_valid_domain (Lisp_Object domain)
{
  if (NILP (Fvalid_specifier_domain_p (domain)))
    signal_simple_error ("Invalid specifier domain", domain);
}

static Lisp_Object
decode_domain (Lisp_Object domain)
{
  if (NILP (domain))
    return Fselected_window (Qnil);
  check_valid_domain (domain);
  return domain;
}


/************************************************************************/
/*                                 Tags                                 */
/************************************************************************/

DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
Return non-nil if TAG is a valid specifier tag.
See also `valid-specifier-tag-set-p'.
*/
       (tag))
{
  return (valid_console_type_p (tag) ||
	  valid_device_class_p (tag) ||
	  !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
}

DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
Return non-nil if TAG-SET is a valid specifier tag set.

A specifier tag set is an entity that is attached to an instantiator
and can be used to restrict the scope of that instantiator to a
particular device class or device type and/or to mark instantiators
added by a particular package so that they can be later removed.

A specifier tag set consists of a list of zero of more specifier tags,
each of which is a symbol that is recognized by XEmacs as a tag.
\(The valid device types and device classes are always tags, as are
any tags defined by `define-specifier-tag'.) It is called a "tag set"
\(as opposed to a list) because the order of the tags or the number of
times a particular tag occurs does not matter.

Each tag has a predicate associated with it, which specifies whether
that tag applies to a particular device.  The tags which are device types
and classes match devices of that type or class.  User-defined tags can
have any predicate, or none (meaning that all devices match).  When
attempting to instance a specifier, a particular instantiator is only
considered if the device of the domain being instanced over matches
all tags in the tag set attached to that instantiator.

Most of the time, a tag set is not specified, and the instantiator
gets a null tag set, which matches all devices.
*/
     (tag_set))
{
  Lisp_Object rest;

  for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
    {
      if (!CONSP (rest))
	return Qnil;
      if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
	return Qnil;
      QUIT;
    }
  return Qt;
}

Lisp_Object
decode_specifier_tag_set (Lisp_Object tag_set)
{
  /* The return value of this function must be GCPRO'd. */
  if (!NILP (Fvalid_specifier_tag_p (tag_set)))
    return list1 (tag_set);
  if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
    signal_simple_error ("Invalid specifier tag-set", tag_set);
  return tag_set;
}

static Lisp_Object
canonicalize_tag_set (Lisp_Object tag_set)
{
  int len = XINT (Flength (tag_set));
  Lisp_Object *tags, rest;
  int i, j;

  /* We assume in this function that the tag_set has already been
     validated, so there are no surprises. */

  if (len == 0 || len == 1)
    /* most common case */
    return tag_set;

  tags = alloca_array (Lisp_Object, len);

  i = 0;
  LIST_LOOP (rest, tag_set)
    tags[i++] = XCAR (rest);

  /* Sort the list of tags.  We use a bubble sort here (copied from
     extent_fragment_update()) -- reduces the function call overhead,
     and is the fastest sort for small numbers of items. */

  for (i = 1; i < len; i++)
    {
      j = i - 1;
      while (j >= 0 &&
	     strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
		     (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
	{
	  Lisp_Object tmp = tags[j];
	  tags[j] = tags[j+1];
	  tags[j+1] = tmp;
	  j--;
	}
    }

  /* Now eliminate duplicates. */

  for (i = 1, j = 1; i < len; i++)
    {
      /* j holds the destination, i the source. */
      if (!EQ (tags[i], tags[i-1]))
	tags[j++] = tags[i];
    }

  return Flist (j, tags);
}

DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
Canonicalize the given tag set.
Two canonicalized tag sets can be compared with `equal' to see if they
represent the same tag set. (Specifically, canonicalizing involves
sorting by symbol name and removing duplicates.)
*/
       (tag_set))
{
  if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
    signal_simple_error ("Invalid tag set", tag_set);
  return canonicalize_tag_set (tag_set);
}

static int
device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
{
  Lisp_Object devtype, devclass, rest;
  struct device *d = XDEVICE (device);

  devtype = DEVICE_TYPE (d);
  devclass = DEVICE_CLASS (d);

  LIST_LOOP (rest, tag_set)
    {
      Lisp_Object tag = XCAR (rest);
      Lisp_Object assoc;

      if (EQ (tag, devtype) || EQ (tag, devclass))
	continue;
      assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
      /* other built-in tags (device types/classes) are not in
	 the user-defined-tags list. */
      if (NILP (assoc) || NILP (XCDR (assoc)))
	return 0;
    }

  return 1;
}

DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
Return non-nil if DEVICE matches specifier tag set TAG-SET.
This means that DEVICE matches each tag in the tag set. (Every
tag recognized by XEmacs has a predicate associated with it that
specifies which devices match it.)
*/
       (device, tag_set))
{
  CHECK_LIVE_DEVICE (device);

  if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
    signal_simple_error ("Invalid tag set", tag_set);

  return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
}

DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
Define a new specifier tag.
If PREDICATE is specified, it should be a function of one argument
\(a device) that specifies whether the tag matches that particular
device.  If PREDICATE is omitted, the tag matches all devices.

You can redefine an existing user-defined specifier tag.  However,
you cannot redefine the built-in specifier tags (the device types
and classes) or the symbols nil, t, 'all, or 'global.
*/
       (tag, predicate))
{
  Lisp_Object assoc, devcons, concons;
  int recompute = 0;

  CHECK_SYMBOL (tag);
  if (valid_device_class_p (tag) ||
      valid_console_type_p (tag))
    signal_simple_error ("Cannot redefine built-in specifier tags", tag);
  /* Try to prevent common instantiators and locales from being
     redefined, to reduce ambiguity */
  if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
    signal_simple_error ("Cannot define nil, t, 'all, or 'global",
			 tag);
  assoc = assq_no_quit (tag, Vuser_defined_tags);
  if (NILP (assoc))
    {
      recompute = 1;
      Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
      DEVICE_LOOP_NO_BREAK (devcons, concons)
	{
	  struct device *d = XDEVICE (XCAR (devcons));
	  /* Initially set the value to t in case of error
	     in predicate */
	  DEVICE_USER_DEFINED_TAGS (d) =
	    Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
	}
    }
  else if (!NILP (predicate) && !NILP (XCDR (assoc)))
    {
      recompute = 1;
      XCDR (assoc) = predicate;
    }

  /* recompute the tag values for all devices.  However, in the special
     case where both the old and new predicates are nil, we know that
     we don't have to do this. (It's probably common for people to
     call (define-specifier-tag) more than once on the same tag,
     and the most common case is where PREDICATE is not specified.) */

  if (recompute)
    {
      DEVICE_LOOP_NO_BREAK (devcons, concons)
	{
	  Lisp_Object device = XCAR (devcons);
	  assoc = assq_no_quit (tag,
				DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
	  assert (CONSP (assoc));
	  if (NILP (predicate))
	    XCDR (assoc) = Qt;
	  else
	    XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
	}
    }

  return Qnil;
}

/* Called at device-creation time to initialize the user-defined
   tag values for the newly-created device. */

void
setup_device_initial_specifier_tags (struct device *d)
{
  Lisp_Object rest, rest2;
  Lisp_Object device;

  XSETDEVICE (device, d);

  DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);

  /* Now set up the initial values */
  LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
    XCDR (XCAR (rest)) = Qt;

  for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
       !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
    {
      Lisp_Object predicate = XCDR (XCAR (rest));
      if (NILP (predicate))
	XCDR (XCAR (rest2)) = Qt;
      else
	XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
    }
}

DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
       0, 1, 0, /*
Return a list of all specifier tags matching DEVICE.
DEVICE defaults to the selected device if omitted.
*/
       (device))
{
  struct device *d = decode_device (device);
  Lisp_Object rest, list = Qnil;
  struct gcpro gcpro1;

  GCPRO1 (list);

  LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
    {
      if (!NILP (XCDR (XCAR (rest))))
	list = Fcons (XCAR (XCAR (rest)), list);
    }

  list = Fnreverse (list);
  list = Fcons (DEVICE_CLASS (d), list);
  list = Fcons (DEVICE_TYPE  (d), list);

  RETURN_UNGCPRO (list);
}

DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
Return a list of all currently-defined specifier tags.
This includes the built-in ones (the device types and classes).
*/
       ())
{
  Lisp_Object list = Qnil, rest;
  struct gcpro gcpro1;

  GCPRO1 (list);

  LIST_LOOP (rest, Vuser_defined_tags)
    list = Fcons (XCAR (XCAR (rest)), list);

  list = Fnreverse (list);
  list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
  list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);

  RETURN_UNGCPRO (list);
}

DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
Return the predicate for the given specifier tag.
*/
       (tag))
{
  /* The return value of this function must be GCPRO'd. */
  CHECK_SYMBOL (tag);

  if (NILP (Fvalid_specifier_tag_p (tag)))
    signal_simple_error ("Invalid specifier tag", tag);

  /* Make up some predicates for the built-in types */

  if (valid_console_type_p (tag))
    return list3 (Qlambda, list1 (Qdevice),
		  list3 (Qeq, list2 (Qquote, tag),
			 list2 (Qconsole_type, Qdevice)));

  if (valid_device_class_p (tag))
    return list3 (Qlambda, list1 (Qdevice),
		  list3 (Qeq, list2 (Qquote, tag),
			 list2 (Qdevice_class, Qdevice)));

  return XCDR (assq_no_quit (tag, Vuser_defined_tags));
}

/* Return true if A "matches" B.  If EXACT_P is 0, A must be a subset of B.
  Otherwise, A must be `equal' to B.  The sets must be canonicalized. */
static int
tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
{
  if (!exact_p)
    {
      while (!NILP (a) && !NILP (b))
	{
	  if (EQ (XCAR (a), XCAR (b)))
	    a = XCDR (a);
	  b = XCDR (b);
	}

      return NILP (a);
    }
  else
    {
      while (!NILP (a) && !NILP (b))
	{
	  if (!EQ (XCAR (a), XCAR (b)))
	    return 0;
	  a = XCDR (a);
	  b = XCDR (b);
	}

      return NILP (a) && NILP (b);
    }
}


/************************************************************************/
/*                       Spec-lists and inst-lists                      */
/************************************************************************/

static Lisp_Object
call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
{
  ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
  return Qt;
}

static Lisp_Object
check_valid_instantiator (Lisp_Object instantiator,
			  struct specifier_methods *meths,
			  Error_behavior errb)
{
  if (meths->validate_method)
    {
      Lisp_Object retval;

      if (ERRB_EQ (errb, ERROR_ME))
	{
	  (meths->validate_method) (instantiator);
	  retval = Qt;
	}
      else
	{
	  Lisp_Object opaque = make_opaque_ptr ((void *)
						meths->validate_method);
	  struct gcpro gcpro1;

	  GCPRO1 (opaque);
	  retval = call_with_suspended_errors
	    ((lisp_fn_t) call_validate_method,
	     Qnil, Qspecifier, errb, 2, opaque, instantiator);

	  free_opaque_ptr (opaque);
	  UNGCPRO;
	}

      return retval;
    }
  return Qt;
}

DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
*/
       (instantiator, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
							   ERROR_ME);

  return check_valid_instantiator (instantiator, meths, ERROR_ME);
}

DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
*/
       (instantiator, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
							   ERROR_ME);

  return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
}

static Lisp_Object
check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
		       Error_behavior errb)
{
  Lisp_Object rest;

  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object inst_pair, tag_set;

      if (!CONSP (rest))
	{
	  maybe_signal_simple_error ("Invalid instantiator list", inst_list,
				     Qspecifier, errb);
	  return Qnil;
	}
      if (!CONSP (inst_pair = XCAR (rest)))
	{
	  maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
				     Qspecifier, errb);
	  return Qnil;
	}
      if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
	{
	  maybe_signal_simple_error ("Invalid specifier tag", tag_set,
				     Qspecifier, errb);
	  return Qnil;
	}

      if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
	return Qnil;
    }

  return Qt;
}

DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
Signal an error if INST-LIST is invalid for specifier type TYPE.
*/
       (inst_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_inst_list (inst_list, meths, ERROR_ME);
}

DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
Return non-nil if INST-LIST is valid for specifier type TYPE.
*/
       (inst_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
}

static Lisp_Object
check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
		       Error_behavior errb)
{
  Lisp_Object rest;

  LIST_LOOP (rest, spec_list)
    {
      Lisp_Object spec, locale;
      if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
	{
	  maybe_signal_simple_error ("Invalid specification list", spec_list,
				     Qspecifier, errb);
	  return Qnil;
	}
      if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
	{
	  maybe_signal_simple_error ("Invalid specifier locale", locale,
				     Qspecifier, errb);
	  return Qnil;
	}

      if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
	return Qnil;
    }

  return Qt;
}

DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
Signal an error if SPEC-LIST is invalid for specifier type TYPE.
*/
       (spec_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_spec_list (spec_list, meths, ERROR_ME);
}

DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
Return non-nil if SPEC-LIST is valid for specifier type TYPE.
*/
       (spec_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
}

enum spec_add_meth
decode_how_to_add_specification (Lisp_Object how_to_add)
{
  if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
    return SPEC_REMOVE_TAG_SET_PREPEND;
  if (EQ (Qremove_tag_set_append, how_to_add))
    return SPEC_REMOVE_TAG_SET_APPEND;
  if (EQ (Qappend, how_to_add))
    return SPEC_APPEND;
  if (EQ (Qprepend, how_to_add))
    return SPEC_PREPEND;
  if (EQ (Qremove_locale, how_to_add))
    return SPEC_REMOVE_LOCALE;
  if (EQ (Qremove_locale_type, how_to_add))
    return SPEC_REMOVE_LOCALE_TYPE;
  if (EQ (Qremove_all, how_to_add))
    return SPEC_REMOVE_ALL;

  signal_simple_error ("Invalid `how-to-add' flag", how_to_add);

  return SPEC_PREPEND;		/* not reached */
}

/* Given a specifier object SPEC, return bodily specifier if SPEC is a
   ghost specifier, otherwise return the object itself
*/
static Lisp_Object
bodily_specifier (Lisp_Object spec)
{
  return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
	  ? XSPECIFIER(spec)->magic_parent : spec);
}

/* Signal error if (specifier SPEC is read-only.
   Read only are ghost specifiers unless Vunlock_ghost_specifiers is
   non-nil.  All other specifiers are read-write.
*/
static void
check_modifiable_specifier (Lisp_Object spec)
{
  if (NILP (Vunlock_ghost_specifiers)
      && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
    signal_simple_error ("Attempt to modify read-only specifier",
			 list1 (spec));
}

/* Helper function which unwind protects the value of
   Vunlock_ghost_specifiers, then sets it to non-nil value */
static Lisp_Object
restore_unlock_value (Lisp_Object val)
{
  Vunlock_ghost_specifiers = val;
  return val;
}

int
unlock_ghost_specifiers_protected (void)
{
  int depth = specpdl_depth ();
  record_unwind_protect (restore_unlock_value,
			 Vunlock_ghost_specifiers);
  Vunlock_ghost_specifiers = Qt;
  return depth;
}

/* This gets hit so much that the function call overhead had a
   measurable impact (according to Quantify).  #### We should figure
   out the frequency with which this is called with the various types
   and reorder the check accordingly. */
#define SPECIFIER_GET_SPEC_LIST(specifier, type)			\
(type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs)   :	\
 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs)   :	\
 type == LOCALE_FRAME  ? &(XSPECIFIER (specifier)->frame_specs)    :	\
 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST				\
			   (XSPECIFIER (specifier)->window_specs)) :	\
 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs)   :	\
 0)

static Lisp_Object *
specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
			 enum spec_locale_type type)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object specification;

  if (type == LOCALE_GLOBAL)
    return spec_list;
  /* Calling assq_no_quit when it is just going to return nil anyhow
     is extremely expensive.  So sayeth Quantify. */
  if (!CONSP (*spec_list))
    return 0;
  specification = assq_no_quit (locale, *spec_list);
  if (NILP (specification))
    return 0;
  return &XCDR (specification);
}

/* For the given INST_LIST, return a new INST_LIST containing all elements
   where TAG-SET matches the element's tag set.  EXACT_P indicates whether
   the match must be exact (as opposed to a subset).  SHORT_P indicates
   that the short form (for `specifier-specs') should be returned if
   possible.  If COPY_TREE_P, `copy-tree' is used to ensure that no
   elements of the new list are shared with the initial list.
*/

static Lisp_Object
specifier_process_inst_list (Lisp_Object inst_list,
			     Lisp_Object tag_set, int exact_p,
			     int short_p, int copy_tree_p)
{
  Lisp_Object retval = Qnil;
  Lisp_Object rest;
  struct gcpro gcpro1;

  GCPRO1 (retval);
  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object tagged_inst = XCAR (rest);
      Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
      if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
	{
	  if (short_p && NILP (tagged_inst_tag))
	    retval = Fcons (copy_tree_p ?
			    Fcopy_tree (XCDR (tagged_inst), Qt) :
			    XCDR (tagged_inst),
			    retval);
	  else
	    retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
			    tagged_inst, retval);
	}
    }
  retval = Fnreverse (retval);
  UNGCPRO;
  /* If there is a single instantiator and the short form is
     requested, return just the instantiator (rather than a one-element
     list of it) unless it is nil (so that it can be distinguished from
     no instantiators at all). */
  if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
      NILP (XCDR (retval)))
    return XCAR (retval);
  else
    return retval;
}

static Lisp_Object
specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
				  enum spec_locale_type type,
				  Lisp_Object tag_set, int exact_p,
				  int short_p, int copy_tree_p)
{
  Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
						    type);
  if (!inst_list || NILP (*inst_list))
    {
      /* nil for *inst_list should only occur in 'global */
      assert (!inst_list || EQ (locale, Qglobal));
      return Qnil;
    }

  return specifier_process_inst_list (*inst_list, tag_set, exact_p,
				      short_p, copy_tree_p);
}

static Lisp_Object
specifier_get_external_spec_list (Lisp_Object specifier,
				  enum spec_locale_type type,
				  Lisp_Object tag_set, int exact_p)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object retval = Qnil;
  Lisp_Object rest;
  struct gcpro gcpro1;

  assert (type != LOCALE_GLOBAL);
  /* We're about to let stuff go external; make sure there aren't
     any dead objects */
  *spec_list = cleanup_assoc_list (*spec_list);

  GCPRO1 (retval);
  LIST_LOOP (rest, *spec_list)
    {
      Lisp_Object spec = XCAR (rest);
      Lisp_Object inst_list =
	specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
      if (!NILP (inst_list))
	retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
    }
  RETURN_UNGCPRO (Fnreverse (retval));
}

static Lisp_Object *
specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
		    enum spec_locale_type type)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object new_spec = Fcons (locale, Qnil);
  assert (type != LOCALE_GLOBAL);
  *spec_list = Fcons (new_spec, *spec_list);
  return &XCDR (new_spec);
}

/* For the given INST_LIST, return a new list comprised of elements
   where TAG_SET does not match the element's tag set.  This operation
   is destructive. */

static Lisp_Object
specifier_process_remove_inst_list (Lisp_Object inst_list,
				    Lisp_Object tag_set, int exact_p,
				    int *was_removed)
{
  Lisp_Object prev = Qnil, rest;

  *was_removed = 0;

  LIST_LOOP (rest, inst_list)
    {
      if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
	{
	  /* time to remove. */
	  *was_removed = 1;
	  if (NILP (prev))
	    inst_list = XCDR (rest);
	  else
	    XCDR (prev) = XCDR (rest);
	}
      else
	prev = rest;
    }

  return inst_list;
}

static void
specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
		       enum spec_locale_type type,
		       Lisp_Object tag_set, int exact_p)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object assoc;
  int was_removed;

  if (type == LOCALE_GLOBAL)
    *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
						     exact_p, &was_removed);
  else
    {
      assoc = assq_no_quit (locale, *spec_list);
      if (NILP (assoc))
	/* this locale is not found. */
	return;
      XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
							 tag_set, exact_p,
							 &was_removed);
      if (NILP (XCDR (assoc)))
	/* no inst-pairs left; remove this locale entirely. */
	*spec_list = remassq_no_quit (locale, *spec_list);
    }

  if (was_removed)
    MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
		    (bodily_specifier (specifier), locale));
}

static void
specifier_remove_locale_type (Lisp_Object specifier,
			      enum spec_locale_type type,
			      Lisp_Object tag_set, int exact_p)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object prev = Qnil, rest;

  assert (type != LOCALE_GLOBAL);
  LIST_LOOP (rest, *spec_list)
    {
      int was_removed;
      int remove_spec = 0;
      Lisp_Object spec = XCAR (rest);

      /* There may be dead objects floating around */
      /* remember, dead windows can become alive again. */
      if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
	{
	  remove_spec = 1;
	  was_removed = 0;
	}
      else
	{
	  XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
							    tag_set, exact_p,
							    &was_removed);
	  if (NILP (XCDR (spec)))
	    remove_spec = 1;
	}

      if (remove_spec)
	{
	  if (NILP (prev))
	    *spec_list = XCDR (rest);
	  else
	    XCDR (prev) = XCDR (rest);
	}
      else
	prev = rest;

      if (was_removed)
	MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
			(bodily_specifier (specifier), XCAR (spec)));
    }
}

/* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
   Frob INST_LIST according to ADD_METH.  No need to call an after-change
   function; the calling function will do this.  Return either SPEC_PREPEND
   or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */

static enum spec_add_meth
handle_multiple_add_insts (Lisp_Object *inst_list,
			   Lisp_Object new_list,
			   enum spec_add_meth add_meth)
{
  switch (add_meth)
    {
    case SPEC_REMOVE_TAG_SET_APPEND:
      add_meth = SPEC_APPEND;
      goto remove_tag_set;
    case SPEC_REMOVE_TAG_SET_PREPEND:
      add_meth = SPEC_PREPEND;
    remove_tag_set:
      {
	Lisp_Object rest;

	LIST_LOOP (rest, new_list)
	  {
	    Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
	    struct gcpro gcpro1;

	    GCPRO1 (canontag);
	    /* pull out all elements from the existing list with the
	       same tag as any tags in NEW_LIST. */
	    *inst_list = remassoc_no_quit (canontag, *inst_list);
	    UNGCPRO;
	  }
      }
      return add_meth;
    case SPEC_REMOVE_LOCALE:
      *inst_list = Qnil;
      return SPEC_PREPEND;
    case SPEC_APPEND:
      return add_meth;
    default:
      return SPEC_PREPEND;
    }
}

/* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
   copy, canonicalize, and call the going_to_add methods as necessary
   to produce a new list that is the one that really will be added
   to the specifier. */

static Lisp_Object
build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
			 Lisp_Object inst_list)
{
  /* The return value of this function must be GCPRO'd. */
  Lisp_Object rest, list_to_build_up = Qnil;
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  struct gcpro gcpro1;

  GCPRO1 (list_to_build_up);
  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object tag_set = XCAR (XCAR (rest));
      Lisp_Object instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
      Lisp_Object sub_inst_list = Qnil;
      struct gcpro ngcpro1, ngcpro2;

      NGCPRO2 (instantiator, sub_inst_list);
      /* call the will-add method; it may GC */
      sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
	SPECMETH (sp, going_to_add,
		  (bodily_specifier (specifier), locale,
		   tag_set, instantiator)) :
	Qt;
      if (EQ (sub_inst_list, Qt))
	/* no change here. */
	sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
				      instantiator));
      else
	{
	  /* now canonicalize all the tag sets in the new objects */
	  Lisp_Object rest2;
	  LIST_LOOP (rest2, sub_inst_list)
	    XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
	}

      list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
      NUNGCPRO;
    }

  RETURN_UNGCPRO (Fnreverse (list_to_build_up));
}

/* Add a specification (locale and instantiator list) to a specifier.
   ADD_METH specifies what to do with existing specifications in the
   specifier, and is an enum that corresponds to the values in
   `add-spec-to-specifier'.  The calling routine is responsible for
   validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
   do not need to be canonicalized. */

  /* #### I really need to rethink the after-change
     functions to make them easier to use and more efficient. */

static void
specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
		    Lisp_Object inst_list, enum spec_add_meth add_meth)
{
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  enum spec_locale_type type = locale_type_from_locale (locale);
  Lisp_Object *orig_inst_list, tem;
  Lisp_Object list_to_build_up = Qnil;
  struct gcpro gcpro1;

  GCPRO1 (list_to_build_up);
  list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
  /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL.  These are the
     add-meth types that affect locales other than this one. */
  if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
    specifier_remove_locale_type (specifier, type, Qnil, 0);
  else if (add_meth == SPEC_REMOVE_ALL)
    {
      specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
      specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
      specifier_remove_locale_type (specifier, LOCALE_FRAME,  Qnil, 0);
      specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
      specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
    }

  orig_inst_list = specifier_get_inst_list (specifier, locale, type);
  if (!orig_inst_list)
    orig_inst_list = specifier_new_spec (specifier, locale, type);
  add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
					add_meth);

  if (add_meth == SPEC_PREPEND)
    tem = nconc2 (list_to_build_up, *orig_inst_list);
  else if (add_meth == SPEC_APPEND)
    tem = nconc2 (*orig_inst_list, list_to_build_up);
  else
    abort ();

  *orig_inst_list = tem;

  UNGCPRO;

  /* call the after-change method */
  MAYBE_SPECMETH (sp, after_change,
		  (bodily_specifier (specifier), locale));
}

static void
specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
		     Lisp_Object locale, enum spec_locale_type type,
		     Lisp_Object tag_set, int exact_p,
		     enum spec_add_meth add_meth)
{
  Lisp_Object inst_list =
    specifier_get_external_inst_list (specifier, locale, type, tag_set,
				      exact_p, 0, 0);
  specifier_add_spec (dest, locale, inst_list, add_meth);
}

static void
specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
			    enum spec_locale_type type,
			    Lisp_Object tag_set, int exact_p,
			    enum spec_add_meth add_meth)
{
  Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object rest;

  /* This algorithm is O(n^2) in running time.
     It's certainly possible to implement an O(n log n) algorithm,
     but I doubt there's any need to. */

  LIST_LOOP (rest, *src_list)
    {
      Lisp_Object spec = XCAR (rest);
      /* There may be dead objects floating around */
      /* remember, dead windows can become alive again. */
      if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
	specifier_add_spec
	  (dest, XCAR (spec),
	   specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
	   add_meth);
    }
}

/* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
   CLOSURE is passed unchanged to MAPFUN.  LOCALE can be one of

     -- nil (same as 'all)
     -- a single locale, locale type, or 'all
     -- a list of locales, locale types, and/or 'all

   MAPFUN is called for each locale and locale type given; for 'all,
   it is called for the locale 'global and for the four possible
   locale types.  In each invocation, either LOCALE will be a locale
   and LOCALE_TYPE will be the locale type of this locale,
   or LOCALE will be nil and LOCALE_TYPE will be a locale type.
   If MAPFUN ever returns non-zero, the mapping is halted and the
   value returned is returned from map_specifier().  Otherwise, the
   mapping proceeds to the end and map_specifier() returns 0.
 */

static int
map_specifier (Lisp_Object specifier, Lisp_Object locale,
	       int (*mapfun) (Lisp_Object specifier,
			      Lisp_Object locale,
			      enum spec_locale_type locale_type,
			      Lisp_Object tag_set,
			      int exact_p,
			      void *closure),
	       Lisp_Object tag_set, Lisp_Object exact_p,
	       void *closure)
{
  int retval = 0;
  Lisp_Object rest;
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (tag_set, locale);
  locale = decode_locale_list (locale);
  tag_set = decode_specifier_tag_set (tag_set);
  tag_set = canonicalize_tag_set (tag_set);

  LIST_LOOP (rest, locale)
    {
      Lisp_Object theloc = XCAR (rest);
      if (!NILP (Fvalid_specifier_locale_p (theloc)))
	{
	  retval = (*mapfun) (specifier, theloc,
			      locale_type_from_locale (theloc),
			      tag_set, !NILP (exact_p), closure);
	  if (retval)
	    break;
	}
      else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
	{
	  retval = (*mapfun) (specifier, Qnil,
			      decode_locale_type (theloc), tag_set,
			      !NILP (exact_p), closure);
	  if (retval)
	    break;
	}
      else
	{
	  assert (EQ (theloc, Qall));
	  retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
			      !NILP (exact_p), closure);
	  if (retval)
	    break;
	  retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
			      !NILP (exact_p), closure);
	  if (retval)
	    break;
	  retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
			      !NILP (exact_p), closure);
	  if (retval)
	    break;
	  retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
			      !NILP (exact_p), closure);
	  if (retval)
	    break;
	  retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
			      !NILP (exact_p), closure);
	  if (retval)
	    break;
	}
    }

  UNGCPRO;
  return retval;
}

DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
Add a specification to SPECIFIER.
The specification maps from LOCALE (which should be a window, buffer,
frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
whose allowed values depend on the type of the specifier.  Optional
argument TAG-SET limits the instantiator to apply only to the specified
tag set, which should be a list of tags all of which must match the
device being instantiated over (tags are a device type, a device class,
or tags defined with `define-specifier-tag').  Specifying a single
symbol for TAG-SET is equivalent to specifying a one-element list
containing that symbol.  Optional argument HOW-TO-ADD specifies what to
do if there are already specifications in the specifier.
It should be one of

  'prepend		Put at the beginning of the current list of
			instantiators for LOCALE.
  'append		Add to the end of the current list of
			instantiators for LOCALE.
  'remove-tag-set-prepend (this is the default)
			Remove any existing instantiators whose tag set is
			the same as TAG-SET; then put the new instantiator
			at the beginning of the current list. ("Same tag
			set" means that they contain the same elements.
			The order may be different.)
  'remove-tag-set-append
			Remove any existing instantiators whose tag set is
			the same as TAG-SET; then put the new instantiator
			at the end of the current list.
  'remove-locale	Remove all previous instantiators for this locale
			before adding the new spec.
  'remove-locale-type	Remove all specifications for all locales of the
			same type as LOCALE (this includes LOCALE itself)
			before adding the new spec.
  'remove-all		Remove all specifications from the specifier
			before adding the new spec.

You can retrieve the specifications for a particular locale or locale type
with the function `specifier-spec-list' or `specifier-specs'.
*/
       (specifier, instantiator, locale, tag_set, how_to_add))
{
  enum spec_add_meth add_meth;
  Lisp_Object inst_list;
  struct gcpro gcpro1;

  CHECK_SPECIFIER (specifier);
  check_modifiable_specifier (specifier);
  
  locale = decode_locale (locale);
  check_valid_instantiator (instantiator,
			    decode_specifier_type
			    (Fspecifier_type (specifier), ERROR_ME),
			    ERROR_ME);
  /* tag_set might be newly-created material, but it's part of inst_list
     so is properly GC-protected. */
  tag_set = decode_specifier_tag_set (tag_set);
  add_meth = decode_how_to_add_specification (how_to_add);

  inst_list = list1 (Fcons (tag_set, instantiator));
  GCPRO1 (inst_list);
  specifier_add_spec (specifier, locale, inst_list, add_meth);
  recompute_cached_specifier_everywhere (specifier);
  RETURN_UNGCPRO (Qnil);
}

DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
Add a spec-list (a list of specifications) to SPECIFIER.
The format of a spec-list is

  ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)

where
  LOCALE := a window, a buffer, a frame, a device, or 'global
  TAG-SET := an unordered list of zero or more TAGS, each of which
             is a symbol
  TAG := a device class (see `valid-device-class-p'), a device type
         (see `valid-console-type-p'), or a tag defined with
         `define-specifier-tag'
  INSTANTIATOR := format determined by the type of specifier

The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
A list of inst-pairs is called an `inst-list'.
The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
A spec-list, then, can be viewed as a list of specifications.

HOW-TO-ADD specifies how to combine the new specifications with
the existing ones, and has the same semantics as for
`add-spec-to-specifier'.

In many circumstances, the higher-level function `set-specifier' is
more convenient and should be used instead.
*/
       (specifier, spec_list, how_to_add))
{
  enum spec_add_meth add_meth;
  Lisp_Object rest;

  CHECK_SPECIFIER (specifier);
  check_modifiable_specifier (specifier);

  check_valid_spec_list (spec_list,
			 decode_specifier_type
			 (Fspecifier_type (specifier), ERROR_ME),
			 ERROR_ME);
  add_meth = decode_how_to_add_specification (how_to_add);

  LIST_LOOP (rest, spec_list)
    {
      /* Placating the GCC god. */
      Lisp_Object specification = XCAR (rest);
      Lisp_Object locale    = XCAR (specification);
      Lisp_Object inst_list = XCDR (specification);

      specifier_add_spec (specifier, locale, inst_list, add_meth);
    }
  recompute_cached_specifier_everywhere (specifier);
  return Qnil;
}

void
add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
			     Lisp_Object locale, Lisp_Object tag_set,
			     Lisp_Object how_to_add)
{
  int depth = unlock_ghost_specifiers_protected ();
  Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
			  instantiator, locale, tag_set, how_to_add);
  unbind_to (depth, Qnil);
}

struct specifier_spec_list_closure
{
  Lisp_Object head, tail;
};

static int
specifier_spec_list_mapfun (Lisp_Object specifier,
			    Lisp_Object locale,
			    enum spec_locale_type locale_type,
			    Lisp_Object tag_set,
			    int exact_p,
			    void *closure)
{
  struct specifier_spec_list_closure *cl =
    (struct specifier_spec_list_closure *) closure;
  Lisp_Object partial;

  if (NILP (locale))
    partial = specifier_get_external_spec_list (specifier,
						locale_type,
						tag_set, exact_p);
  else
    {
      partial = specifier_get_external_inst_list (specifier, locale,
						  locale_type, tag_set,
						  exact_p, 0, 1);
      if (!NILP (partial))
	partial = list1 (Fcons (locale, partial));
    }
  if (NILP (partial))
    return 0;

  /* tack on the new list */
  if (NILP (cl->tail))
    cl->head = cl->tail = partial;
  else
    XCDR (cl->tail) = partial;
  /* find the new tail */
  while (CONSP (XCDR (cl->tail)))
    cl->tail = XCDR (cl->tail);
  return 0;
}

/* For the given SPECIFIER create and return a list of all specs
   contained within it, subject to LOCALE.  If LOCALE is a locale, only
   specs in that locale will be returned.  If LOCALE is a locale type,
   all specs in all locales of that type will be returned.  If LOCALE is
   nil, all specs will be returned.  This always copies lists and never
   returns the actual lists, because we do not want someone manipulating
   the actual objects.  This may cause a slight loss of potential
   functionality but if we were to allow it then a user could manage to
   violate our assertion that the specs contained in the actual
   specifier lists are all valid. */

DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
Return the spec-list of specifications for SPECIFIER in LOCALE.

If LOCALE is a particular locale (a buffer, window, frame, device,
or 'global), a spec-list consisting of the specification for that
locale will be returned.

If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
a spec-list of the specifications for all locales of that type will be
returned.

If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
will be returned.

LOCALE can also be a list of locales, locale types, and/or 'all; the
result is as if `specifier-spec-list' were called on each element of the
list and the results concatenated together.

Only instantiators where TAG-SET (a list of zero or more tags) is a
subset of (or possibly equal to) the instantiator's tag set are returned.
\(The default value of nil is a subset of all tag sets, so in this case
no instantiators will be screened out.) If EXACT-P is non-nil, however,
TAG-SET must be equal to an instantiator's tag set for the instantiator
to be returned.
*/
     (specifier, locale, tag_set, exact_p))
{
  struct specifier_spec_list_closure cl;
  struct gcpro gcpro1, gcpro2;

  CHECK_SPECIFIER (specifier);
  cl.head = cl.tail = Qnil;
  GCPRO2 (cl.head, cl.tail);
  map_specifier (specifier, locale, specifier_spec_list_mapfun,
		 tag_set, exact_p, &cl);
  UNGCPRO;
  return cl.head;
}


DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
Return the specification(s) for SPECIFIER in LOCALE.

If LOCALE is a single locale or is a list of one element containing a
single locale, then a "short form" of the instantiators for that locale
will be returned.  Otherwise, this function is identical to
`specifier-spec-list'.

The "short form" is designed for readability and not for ease of use
in Lisp programs, and is as follows:

1. If there is only one instantiator, then an inst-pair (i.e. cons of
   tag and instantiator) will be returned; otherwise a list of
   inst-pairs will be returned.
2. For each inst-pair returned, if the instantiator's tag is 'any,
   the tag will be removed and the instantiator itself will be returned
   instead of the inst-pair.
3. If there is only one instantiator, its value is nil, and its tag is
   'any, a one-element list containing nil will be returned rather
   than just nil, to distinguish this case from there being no
   instantiators at all.
*/
       (specifier, locale, tag_set, exact_p))
{
  if (!NILP (Fvalid_specifier_locale_p (locale)) ||
      (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
       NILP (XCDR (locale))))
    {
      struct gcpro gcpro1;

      CHECK_SPECIFIER (specifier);
      if (CONSP (locale))
	locale = XCAR (locale);
      GCPRO1 (tag_set);
      tag_set = decode_specifier_tag_set (tag_set);
      tag_set = canonicalize_tag_set (tag_set);
      RETURN_UNGCPRO
	(specifier_get_external_inst_list (specifier, locale,
					   locale_type_from_locale (locale),
					   tag_set, !NILP (exact_p), 1, 1));
    }
  else
    return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
}

static int
remove_specifier_mapfun (Lisp_Object specifier,
			 Lisp_Object locale,
			 enum spec_locale_type locale_type,
			 Lisp_Object tag_set,
			 int exact_p,
			 void *ignored_closure)
{
  if (NILP (locale))
    specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
  else
    specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
  return 0;
}

DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
Remove specification(s) for SPECIFIER.

If LOCALE is a particular locale (a window, buffer, frame, device,
or 'global), the specification for that locale will be removed.

If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
or 'device), the specifications for all locales of that type will be
removed.

If LOCALE is nil or 'all, all specifications will be removed.

LOCALE can also be a list of locales, locale types, and/or 'all; this
is equivalent to calling `remove-specifier' for each of the elements
in the list.

Only instantiators where TAG-SET (a list of zero or more tags) is a
subset of (or possibly equal to) the instantiator's tag set are removed.
The default value of nil is a subset of all tag sets, so in this case
no instantiators will be screened out. If EXACT-P is non-nil, however,
TAG-SET must be equal to an instantiator's tag set for the instantiator
to be removed.
*/
       (specifier, locale, tag_set, exact_p))
{
  CHECK_SPECIFIER (specifier);
  check_modifiable_specifier (specifier);

  map_specifier (specifier, locale, remove_specifier_mapfun,
		 tag_set, exact_p, 0);
  recompute_cached_specifier_everywhere (specifier);
  return Qnil;
}

void
remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
			Lisp_Object tag_set, Lisp_Object exact_p)
{
  int depth = unlock_ghost_specifiers_protected ();
  Fremove_specifier (XSPECIFIER(specifier)->fallback,
		     locale, tag_set, exact_p);
  unbind_to (depth, Qnil);
}

struct copy_specifier_closure
{
  Lisp_Object dest;
  enum spec_add_meth add_meth;
  int add_meth_is_nil;
};

static int
copy_specifier_mapfun (Lisp_Object specifier,
		       Lisp_Object locale,
		       enum spec_locale_type locale_type,
		       Lisp_Object tag_set,
		       int exact_p,
		       void *closure)
{
  struct copy_specifier_closure *cl =
    (struct copy_specifier_closure *) closure;

  if (NILP (locale))
    specifier_copy_locale_type (specifier, cl->dest, locale_type,
				tag_set, exact_p,
				cl->add_meth_is_nil ?
				SPEC_REMOVE_LOCALE_TYPE :
				cl->add_meth);
  else
    specifier_copy_spec (specifier, cl->dest, locale, locale_type,
			 tag_set, exact_p,
			 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
			 cl->add_meth);
  return 0;
}

DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
Copy SPECIFIER to DEST, or create a new one if DEST is nil.

If DEST is nil or omitted, a new specifier will be created and the
specifications copied into it.  Otherwise, the specifications will be
copied into the existing specifier in DEST.

If LOCALE is nil or 'all, all specifications will be copied.  If LOCALE
is a particular locale, the specification for that particular locale will
be copied.  If LOCALE is a locale type, the specifications for all locales
of that type will be copied.  LOCALE can also be a list of locales,
locale types, and/or 'all; this is equivalent to calling `copy-specifier'
for each of the elements of the list.  See `specifier-spec-list' for more
information about LOCALE.

Only instantiators where TAG-SET (a list of zero or more tags) is a
subset of (or possibly equal to) the instantiator's tag set are copied.
The default value of nil is a subset of all tag sets, so in this case
no instantiators will be screened out. If EXACT-P is non-nil, however,
TAG-SET must be equal to an instantiator's tag set for the instantiator
to be copied.

Optional argument HOW-TO-ADD specifies what to do with existing
specifications in DEST.  If nil, then whichever locales or locale types
are copied will first be completely erased in DEST.  Otherwise, it is
the same as in `add-spec-to-specifier'.
*/
       (specifier, dest, locale, tag_set, exact_p, how_to_add))
{
  struct gcpro gcpro1;
  struct copy_specifier_closure cl;

  CHECK_SPECIFIER (specifier);
  if (NILP (how_to_add))
    cl.add_meth_is_nil = 1;
  else
    cl.add_meth_is_nil = 0;
  cl.add_meth = decode_how_to_add_specification (how_to_add);
  if (NILP (dest))
    {
      /* #### What about copying the extra data? */
      dest = make_specifier (XSPECIFIER (specifier)->methods);
    }
  else
    {
      CHECK_SPECIFIER (dest);
      check_modifiable_specifier (dest);
      if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
	error ("Specifiers not of same type");
    }

  cl.dest = dest;
  GCPRO1 (dest);
  map_specifier (specifier, locale, copy_specifier_mapfun,
		 tag_set, exact_p, &cl);
  UNGCPRO;
  recompute_cached_specifier_everywhere (dest);
  return dest;
}


/************************************************************************/
/*                              Instancing                              */
/************************************************************************/

static Lisp_Object
call_validate_matchspec_method (Lisp_Object boxed_method,
				Lisp_Object matchspec)
{
  ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
  return Qt;
}

static Lisp_Object
check_valid_specifier_matchspec (Lisp_Object matchspec,
				 struct specifier_methods *meths,
				 Error_behavior errb)
{
  if (meths->validate_matchspec_method)
    {
      Lisp_Object retval;

      if (ERRB_EQ (errb, ERROR_ME))
	{
	  (meths->validate_matchspec_method) (matchspec);
	  retval = Qt;
	}
      else
	{
	  Lisp_Object opaque =
	    make_opaque_ptr ((void *) meths->validate_matchspec_method);
	  struct gcpro gcpro1;

	  GCPRO1 (opaque);
	  retval = call_with_suspended_errors
	    ((lisp_fn_t) call_validate_matchspec_method,
	     Qnil, Qspecifier, errb, 2, opaque, matchspec);

	  free_opaque_ptr (opaque);
	  UNGCPRO;
	}

      return retval;
    }
  else
    {
      maybe_signal_simple_error
	("Matchspecs not allowed for this specifier type",
	 intern (meths->name), Qspecifier, errb);
      return Qnil;
    }
}

DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
See `specifier-matching-instance' for a description of matchspecs.
*/
       (matchspec, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
							   ERROR_ME);

  return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
}

DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
See `specifier-matching-instance' for a description of matchspecs.
*/
       (matchspec, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
							   ERROR_ME);

  return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
}

/* This function is purposely not callable from Lisp.  If a Lisp
   caller wants to set a fallback, they should just set the
   global value. */

void
set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
{
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  assert (SPECIFIERP (fallback) ||
	  !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
  if (SPECIFIERP (fallback))
    assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
  if (BODILY_SPECIFIER_P (sp))
    GHOST_SPECIFIER(sp)->fallback = fallback;
  else
    sp->fallback = fallback;
  /* call the after-change method */
  MAYBE_SPECMETH (sp, after_change,
		  (bodily_specifier (specifier), Qfallback));
  recompute_cached_specifier_everywhere (specifier);
}

DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
Return the fallback value for SPECIFIER.
Fallback values are provided by the C code for certain built-in
specifiers to make sure that instancing won't fail even if all
specs are removed from the specifier, or to implement simple
inheritance behavior (e.g. this method is used to ensure that
faces other than 'default inherit their attributes from 'default).
By design, you cannot change the fallback value, and specifiers
created with `make-specifier' will never have a fallback (although
a similar, Lisp-accessible capability may be provided in the future
to allow for inheritance).

The fallback value will be an inst-list that is instanced like
any other inst-list, a specifier of the same type as SPECIFIER
\(results in inheritance), or nil for no fallback.

When you instance a specifier, you can explicitly request that the
fallback not be consulted. (The C code does this, for example, when
merging faces.) See `specifier-instance'.
*/
       (specifier))
{
  CHECK_SPECIFIER (specifier);
  return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
}

static Lisp_Object
specifier_instance_from_inst_list (Lisp_Object specifier,
				   Lisp_Object matchspec,
				   Lisp_Object domain,
				   Lisp_Object inst_list,
				   Error_behavior errb, int no_quit,
				   Lisp_Object depth)
{
  /* This function can GC */
  struct Lisp_Specifier *sp;
  Lisp_Object device;
  Lisp_Object rest;
  int count = specpdl_depth ();
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (specifier, inst_list);

  sp = XSPECIFIER (specifier);
  device = DFW_DEVICE (domain);

  if (no_quit)
  /* The instantiate method is allowed to call eval.  Since it
     is quite common for this function to get called from somewhere in
     redisplay we need to make sure that quits are ignored.  Otherwise
     Fsignal will abort. */
    specbind (Qinhibit_quit, Qt);

  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object tagged_inst = XCAR (rest);
      Lisp_Object tag_set = XCAR (tagged_inst);

      if (device_matches_specifier_tag_set_p (device, tag_set))
	{
	  Lisp_Object val = XCDR (tagged_inst);

	  if (HAS_SPECMETH_P (sp, instantiate))
	    val = call_with_suspended_errors
	      ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
	       Qunbound, Qspecifier, errb, 5, specifier,
	       matchspec, domain, val, depth);

	  if (!UNBOUNDP (val))
	    {
	      unbind_to (count, Qnil);
	      UNGCPRO;
	      return val;
	    }
	}
    }

  unbind_to (count, Qnil);
  UNGCPRO;
  return Qunbound;
}

/* Given a SPECIFIER and a DOMAIN, return a specific instance for that
   specifier. Try to find one by checking the specifier types from most
   specific (buffer) to most general (global).  If we find an instance,
   return it.  Otherwise return Qunbound. */

#define CHECK_INSTANCE_ENTRY(key, matchspec, type)			\
do {									\
  Lisp_Object *__inst_list =						\
    specifier_get_inst_list (specifier, key, type);			\
  if (__inst_list)							\
    {									\
      Lisp_Object __val__ =						\
	specifier_instance_from_inst_list (specifier, matchspec,	\
					   domain, *__inst_list,	\
					   errb, no_quit, depth);	\
      if (!UNBOUNDP (__val__))						\
	return __val__;							\
    }									\
} while (0)

/* We accept any window, frame or device domain and do our checking
   starting from as specific a locale type as we can determine from the
   domain we are passed and going on up through as many other locale types
   as we can determine.  In practice, when called from redisplay the
   arg will usually be a window and occasionally a frame.  If
   triggered by a user call, who knows what it will usually be. */
Lisp_Object
specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
		    Lisp_Object domain, Error_behavior errb, int no_quit,
		    int no_fallback, Lisp_Object depth)
{
  Lisp_Object buffer = Qnil;
  Lisp_Object window = Qnil;
  Lisp_Object frame = Qnil;
  Lisp_Object device = Qnil;
  Lisp_Object tag = Qnil;
  struct device *d;
  struct Lisp_Specifier *sp;

  sp = XSPECIFIER (specifier);

  /* Attempt to determine buffer, window, frame, and device from the
     domain. */
  if (WINDOWP (domain))
    window = domain;
  else if (FRAMEP (domain))
    frame = domain;
  else if (DEVICEP (domain))
    device = domain;
  else
    /* #### dmoore - dammit, this should just signal an error or something
       shouldn't it?
       #### No. Errors are handled in Lisp primitives implementation.
       Invalid domain is a design error here - kkm. */
    abort ();

  if (NILP (buffer) && !NILP (window))
    buffer = XWINDOW (window)->buffer;
  if (NILP (frame) && !NILP (window))
    frame = XWINDOW (window)->frame;
  if (NILP (device))
    /* frame had better exist; if device is undeterminable, something
       really went wrong. */
    device = XFRAME (frame)->device;

  /* device had better be determined by now; abort if not. */
  d = XDEVICE (device);
  tag = DEVICE_CLASS (d);

  depth = make_int (1 + XINT (depth));
  if (XINT (depth) > 20)
    {
      maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
      /* The specification is fucked; at least try the fallback
	 (which better not be fucked, because it's not changeable
	 from Lisp). */
      depth = Qzero;
      goto do_fallback;
    }

try_again:
  /* First see if we can generate one from the window specifiers. */
  if (!NILP (window))
    CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);

  /* Next see if we can generate one from the buffer specifiers. */
  if (!NILP (buffer))
    CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);

  /* Next see if we can generate one from the frame specifiers. */
  if (!NILP (frame))
    CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);

  /* If we still haven't succeeded try with the device specifiers. */
  CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);

  /* Last and least try the global specifiers. */
  CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);

do_fallback:
  /* We're out of specifiers and we still haven't generated an
     instance.  At least try the fallback ...  If this fails,
     then we just return Qunbound. */

  if (no_fallback || NILP (sp->fallback))
    /* I said, I don't want the fallbacks. */
    return Qunbound;

  if (SPECIFIERP (sp->fallback))
    {
      /* If you introduced loops in the default specifier chain,
	 then you're fucked, so you better not do this. */
      specifier = sp->fallback;
      sp = XSPECIFIER (specifier);
      goto try_again;
    }

  assert (CONSP (sp->fallback));
  return specifier_instance_from_inst_list (specifier, matchspec, domain,
					    sp->fallback, errb, no_quit,
					    depth);
}
#undef CHECK_INSTANCE_ENTRY

Lisp_Object
specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
			    Lisp_Object domain, Error_behavior errb,
			    int no_fallback, Lisp_Object depth)
{
  return specifier_instance (specifier, matchspec, domain, errb,
			     1, no_fallback, depth);
}

DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
Instantiate SPECIFIER (return its value) in DOMAIN.
If no instance can be generated for this domain, return DEFAULT.

DOMAIN should be a window, frame, or device.  Other values that are legal
as a locale (e.g. a buffer) are not valid as a domain because they do not
provide enough information to identify a particular device (see
`valid-specifier-domain-p').  DOMAIN defaults to the selected window
if omitted.

"Instantiating" a specifier in a particular domain means determining
the specifier's "value" in that domain.  This is accomplished by
searching through the specifications in the specifier that correspond
to all locales that can be derived from the given domain, from specific
to general.  In most cases, the domain is an Emacs window.  In that case
specifications are searched for as follows:

1. A specification whose locale is the window itself;
2. A specification whose locale is the window's buffer;
3. A specification whose locale is the window's frame;
4. A specification whose locale is the window's frame's device;
5. A specification whose locale is 'global.

If all of those fail, then the C-code-provided fallback value for
this specifier is consulted (see `specifier-fallback').  If it is
an inst-list, then this function attempts to instantiate that list
just as when a specification is located in the first five steps above.
If the fallback is a specifier, `specifier-instance' is called
recursively on this specifier and the return value used.  Note,
however, that if the optional argument NO-FALLBACK is non-nil,
the fallback value will not be consulted.

Note that there may be more than one specification matching a particular
locale; all such specifications are considered before looking for any
specifications for more general locales.  Any particular specification
that is found may be rejected because its tag set does not match the
device being instantiated over, or because the specification is not
valid for the device of the given domain (e.g. the font or color name
does not exist for this particular X server).

The returned value is dependent on the type of specifier.  For example,
for a font specifier (as returned by the `face-font' function), the returned
value will be a font-instance object.  For glyphs, the returned value
will be a string, pixmap, or subwindow.

See also `specifier-matching-instance'.
*/
       (specifier, domain, default_, no_fallback))
{
  Lisp_Object instance;

  CHECK_SPECIFIER (specifier);
  domain = decode_domain (domain);

  instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
				 !NILP (no_fallback), Qzero);
  return UNBOUNDP (instance) ? default_ : instance;
}

DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
If no instance can be generated for this domain, return DEFAULT.

This function is identical to `specifier-instance' except that a
specification will only be considered if it matches MATCHSPEC.
The definition of "match", and allowed values for MATCHSPEC, are
dependent on the particular type of specifier.  Here are some examples:

-- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
   character, and the specification (a chartable) must give a value for
   that character in order to be considered.  This allows you to specify,
   e.g., a buffer-local display table that only gives values for particular
   characters.  All other characters are handled as if the buffer-local
   display table is not there. (Chartable specifiers are not yet
   implemented.)

-- For font specifiers, MATCHSPEC should be a charset, and the specification
   (a font string) must have a registry that matches the charset's registry.
   (This only makes sense with Mule support.) This makes it easy to choose a
   font that can display a particular character. (This is what redisplay
   does, in fact.)
*/
       (specifier, matchspec, domain, default_, no_fallback))
{
  Lisp_Object instance;

  CHECK_SPECIFIER (specifier);
  check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
				   ERROR_ME);
  domain = decode_domain (domain);

  instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
				 0, !NILP (no_fallback), Qzero);
  return UNBOUNDP (instance) ? default_ : instance;
}

DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
       3, 4, 0, /*
Attempt to convert a particular inst-list into an instance.
This attempts to instantiate INST-LIST in the given DOMAIN,
as if INST-LIST existed in a specification in SPECIFIER.  If
the instantiation fails, DEFAULT is returned.  In most circumstances,
you should not use this function; use `specifier-instance' instead.
*/
       (specifier, domain, inst_list, default_))
{
  Lisp_Object val = Qunbound;
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  struct gcpro gcpro1;
  Lisp_Object built_up_list = Qnil;

  CHECK_SPECIFIER (specifier);
  check_valid_domain (domain);
  check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
  GCPRO1 (built_up_list);
  built_up_list = build_up_processed_list (specifier, domain, inst_list);
  if (!NILP (built_up_list))
    val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
					     built_up_list, ERROR_ME,
					     0, Qzero);
  UNGCPRO;
  return UNBOUNDP (val) ? default_ : val;
}

DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
       4, 5, 0, /*
Attempt to convert a particular inst-list into an instance.
This attempts to instantiate INST-LIST in the given DOMAIN
\(as if INST-LIST existed in a specification in SPECIFIER),
matching the specifications against MATCHSPEC.

This function is analogous to `specifier-instance-from-inst-list'
but allows for specification-matching as in `specifier-matching-instance'.
See that function for a description of exactly how the matching process
works.
*/
       (specifier, matchspec, domain, inst_list, default_))
{
  Lisp_Object val = Qunbound;
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  struct gcpro gcpro1;
  Lisp_Object built_up_list = Qnil;

  CHECK_SPECIFIER (specifier);
  check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
				   ERROR_ME);
  check_valid_domain (domain);
  check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
  GCPRO1 (built_up_list);
  built_up_list = build_up_processed_list (specifier, domain, inst_list);
  if (!NILP (built_up_list))
    val = specifier_instance_from_inst_list (specifier, matchspec, domain,
					     built_up_list, ERROR_ME,
					     0, Qzero);
  UNGCPRO;
  return UNBOUNDP (val) ? default_ : val;
}


/************************************************************************/
/*                 Caching in the struct window or frame                */
/************************************************************************/

/* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
   no caching in that sort of object. */

/* #### It would be nice if the specifier caching automatically knew
   about specifier fallbacks, so we didn't have to do it ourselves. */

void
set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
		       void (*value_changed_in_window)
		       (Lisp_Object specifier, struct window *w,
			Lisp_Object oldval),
		       int struct_frame_offset,
		       void (*value_changed_in_frame)
		       (Lisp_Object specifier, struct frame *f,
			Lisp_Object oldval))
{
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  assert (!GHOST_SPECIFIER_P (sp));

  if (!sp->caching)
    sp->caching = xnew_and_zero (struct specifier_caching);
  sp->caching->offset_into_struct_window = struct_window_offset;
  sp->caching->value_changed_in_window = value_changed_in_window;
  sp->caching->offset_into_struct_frame = struct_frame_offset;
  sp->caching->value_changed_in_frame = value_changed_in_frame;
  Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
  if (BODILY_SPECIFIER_P (sp))
    GHOST_SPECIFIER(sp)->caching = sp->caching;
  recompute_cached_specifier_everywhere (specifier);
}

static void
recompute_one_cached_specifier_in_window (Lisp_Object specifier,
					  struct window *w)
{
  Lisp_Object window;
  Lisp_Object newval, *location;

  assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));

  XSETWINDOW (window, w);

  newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
			       0, 0, Qzero);
  /* If newval ended up Qunbound, then the calling functions
     better be able to deal.  If not, set a default so this
     never happens or correct it in the value_changed_in_window
     method. */
  location = (Lisp_Object *)
    ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
  if (!EQ (newval, *location))
    {
      Lisp_Object oldval = *location;
      *location = newval;
      (XSPECIFIER (specifier)->caching->value_changed_in_window)
	(specifier, w, oldval);
    }
}

static void
recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
					 struct frame *f)
{
  Lisp_Object frame;
  Lisp_Object newval, *location;

  assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));

  XSETFRAME (frame, f);

  newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
			       0, 0, Qzero);
  /* If newval ended up Qunbound, then the calling functions
     better be able to deal.  If not, set a default so this
     never happens or correct it in the value_changed_in_frame
     method. */
  location = (Lisp_Object *)
    ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
  if (!EQ (newval, *location))
    {
      Lisp_Object oldval = *location;
      *location = newval;
      (XSPECIFIER (specifier)->caching->value_changed_in_frame)
	(specifier, f, oldval);
    }
}

void
recompute_all_cached_specifiers_in_window (struct window *w)
{
  Lisp_Object rest;

  LIST_LOOP (rest, Vcached_specifiers)
    {
      Lisp_Object specifier = XCAR (rest);
      if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
	recompute_one_cached_specifier_in_window (specifier, w);
    }
}

void
recompute_all_cached_specifiers_in_frame (struct frame *f)
{
  Lisp_Object rest;

  LIST_LOOP (rest, Vcached_specifiers)
    {
      Lisp_Object specifier = XCAR (rest);
      if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
	recompute_one_cached_specifier_in_frame (specifier, f);
    }
}

static int
recompute_cached_specifier_everywhere_mapfun (struct window *w,
					      void *closure)
{
  Lisp_Object specifier = Qnil;

  VOID_TO_LISP (specifier, closure);
  recompute_one_cached_specifier_in_window (specifier, w);
  return 0;
}

static void
recompute_cached_specifier_everywhere (Lisp_Object specifier)
{
  Lisp_Object frmcons, devcons, concons;

  specifier = bodily_specifier (specifier);

  if (!XSPECIFIER (specifier)->caching)
    return;

  if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
    {
      FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
	map_windows (XFRAME (XCAR (frmcons)),
		     recompute_cached_specifier_everywhere_mapfun,
		     LISP_TO_VOID (specifier));
    }

  if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
    {
      FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
	recompute_one_cached_specifier_in_frame (specifier,
						 XFRAME (XCAR (frmcons)));
    }
}

DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
Force recomputation of any caches associated with SPECIFIER.
Note that this automatically happens whenever you change a specification
 in SPECIFIER; you do not have to call this function then.
One example of where this function is useful is when you have a
 toolbar button whose `active-p' field is an expression to be
 evaluated.  Calling `set-specifier-dirty-flag' on the
 toolbar specifier will force the `active-p' fields to be
 recomputed.
*/
       (specifier))
{
  CHECK_SPECIFIER (specifier);
  recompute_cached_specifier_everywhere (specifier);
  return Qnil;
}


/************************************************************************/
/*                        Generic specifier type                        */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (generic);

#if 0

/* This is the string that used to be in `generic-specifier-p'.
   The idea is good, but it doesn't quite work in the form it's
   in. (One major problem is that validating an instantiator
   is supposed to require only that the specifier type is passed,
   while with this approach the actual specifier is needed.)

   What really needs to be done is to write a function
   `make-specifier-type' that creates new specifier types.
   #### I'll look into this for 19.14.
 */

"A generic specifier is a generalized kind of specifier with user-defined\n"
"semantics.  The instantiator can be any kind of Lisp object, and the\n"
"instance computed from it is likewise any kind of Lisp object.  The\n"
"SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
"works.  All methods are optional, and reasonable default methods will be\n"
"provided.  Currently there are two defined methods: 'instantiate and\n"
"'validate.\n"
"\n"
"'instantiate specifies how to do the instantiation; if omitted, the\n"
"instantiator itself is simply returned as the instance.  The method\n"
"should be a function that accepts three parameters (a specifier, the\n"
"instantiator that matched the domain being instantiated over, and that\n"
"domain), and should return a one-element list containing the instance,\n"
"or nil if no instance exists.  Note that the domain passed to this function\n"
"is the domain being instantiated over, which may not be the same as the\n"
"locale contained in the specification corresponding to the instantiator\n"
"(for example, the domain being instantiated over could be a window, but\n"
"the locale corresponding to the passed instantiator could be the window's\n"
"buffer or frame).\n"
"\n"
"'validate specifies whether a given instantiator is valid; if omitted,\n"
"all instantiators are considered valid.  It should be a function of\n"
"two arguments: an instantiator and a flag CAN-SIGNAL-ERROR.  If this\n"
"flag is false, the function must simply return t or nil indicating\n"
"whether the instantiator is valid.  If this flag is true, the function\n"
"is free to signal an error if it encounters an invalid instantiator\n"
"(this can be useful for issuing a specific error about exactly why the\n"
"instantiator is valid).  It can also return nil to indicate an invalid\n"
"instantiator; in this case, a general error will be signalled."

#endif /* 0 */

DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a generic specifier.

A generic specifier allows any kind of Lisp object as an instantiator,
and returns back the Lisp object unchanged when it is instantiated.
*/
       (object))
{
  return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
}


/************************************************************************/
/*                        Integer specifier type                        */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (integer);

static void
integer_validate (Lisp_Object instantiator)
{
  CHECK_INT (instantiator);
}

DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is an integer specifier.
*/
       (object))
{
  return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
}

/************************************************************************/
/*                   Non-negative-integer specifier type                */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (natnum);

static void
natnum_validate (Lisp_Object instantiator)
{
  CHECK_NATNUM (instantiator);
}

DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
*/
       (object))
{
  return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
}

/************************************************************************/
/*                        Boolean specifier type                        */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (boolean);

static void
boolean_validate (Lisp_Object instantiator)
{
  if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
    signal_simple_error ("Must be t or nil", instantiator);
}

DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a boolean specifier.
*/
       (object))
{
  return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
}

/************************************************************************/
/*                        Display table specifier type                  */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (display_table);

static void
display_table_validate (Lisp_Object instantiator)
{
  if (!NILP(instantiator) &&
      (!VECTORP (instantiator) ||
       XVECTOR_LENGTH (instantiator) != DISP_TABLE_SIZE))
    dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
			      instantiator);
}

DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a display-table specifier.
*/
       (object))
{
  return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
}


/************************************************************************/
/*                           Initialization                             */
/************************************************************************/

void
syms_of_specifier (void)
{
  defsymbol (&Qspecifierp, "specifierp");

  defsymbol (&Qconsole_type, "console-type");
  defsymbol (&Qdevice_class, "device-class");

  /* Qinteger, Qboolean, Qgeneric defined in general.c */
  defsymbol (&Qnatnum, "natnum");

  DEFSUBR (Fvalid_specifier_type_p);
  DEFSUBR (Fspecifier_type_list);
  DEFSUBR (Fmake_specifier);
  DEFSUBR (Fspecifierp);
  DEFSUBR (Fspecifier_type);

  DEFSUBR (Fvalid_specifier_locale_p);
  DEFSUBR (Fvalid_specifier_domain_p);
  DEFSUBR (Fvalid_specifier_locale_type_p);
  DEFSUBR (Fspecifier_locale_type_from_locale);

  DEFSUBR (Fvalid_specifier_tag_p);
  DEFSUBR (Fvalid_specifier_tag_set_p);
  DEFSUBR (Fcanonicalize_tag_set);
  DEFSUBR (Fdevice_matches_specifier_tag_set_p);
  DEFSUBR (Fdefine_specifier_tag);
  DEFSUBR (Fdevice_matching_specifier_tag_list);
  DEFSUBR (Fspecifier_tag_list);
  DEFSUBR (Fspecifier_tag_predicate);

  DEFSUBR (Fcheck_valid_instantiator);
  DEFSUBR (Fvalid_instantiator_p);
  DEFSUBR (Fcheck_valid_inst_list);
  DEFSUBR (Fvalid_inst_list_p);
  DEFSUBR (Fcheck_valid_spec_list);
  DEFSUBR (Fvalid_spec_list_p);
  DEFSUBR (Fadd_spec_to_specifier);
  DEFSUBR (Fadd_spec_list_to_specifier);
  DEFSUBR (Fspecifier_spec_list);
  DEFSUBR (Fspecifier_specs);
  DEFSUBR (Fremove_specifier);
  DEFSUBR (Fcopy_specifier);

  DEFSUBR (Fcheck_valid_specifier_matchspec);
  DEFSUBR (Fvalid_specifier_matchspec_p);
  DEFSUBR (Fspecifier_fallback);
  DEFSUBR (Fspecifier_instance);
  DEFSUBR (Fspecifier_matching_instance);
  DEFSUBR (Fspecifier_instance_from_inst_list);
  DEFSUBR (Fspecifier_matching_instance_from_inst_list);
  DEFSUBR (Fset_specifier_dirty_flag);

  DEFSUBR (Fgeneric_specifier_p);
  DEFSUBR (Finteger_specifier_p);
  DEFSUBR (Fnatnum_specifier_p);
  DEFSUBR (Fboolean_specifier_p);
  DEFSUBR (Fdisplay_table_specifier_p);

  /* Symbols pertaining to specifier creation.  Specifiers are created
     in the syms_of() functions. */

  /* locales are defined in general.c. */

  defsymbol (&Qprepend, "prepend");
  defsymbol (&Qappend, "append");
  defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
  defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
  defsymbol (&Qremove_locale, "remove-locale");
  defsymbol (&Qremove_locale_type, "remove-locale-type");
  defsymbol (&Qremove_all, "remove-all");

  defsymbol (&Qfallback, "fallback");
}

void
specifier_type_create (void)
{
  the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);

  Vspecifier_type_list = Qnil;
  staticpro (&Vspecifier_type_list);

  INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");

  INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");

  SPECIFIER_HAS_METHOD (integer, validate);

  INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");

  SPECIFIER_HAS_METHOD (natnum, validate);

  INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");

  SPECIFIER_HAS_METHOD (boolean, validate);

  INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");

  SPECIFIER_HAS_METHOD (display_table, validate);
}

void
vars_of_specifier (void)
{
  Vcached_specifiers = Qnil;
  staticpro (&Vcached_specifiers);

  /* Do NOT mark through this, or specifiers will never be GC'd.
     This is the same deal as for weak hashtables. */
  Vall_specifiers = Qnil;

  Vuser_defined_tags = Qnil;
  staticpro (&Vuser_defined_tags);

  Vunlock_ghost_specifiers = Qnil;
  staticpro (&Vunlock_ghost_specifiers);
}