Source

dotfiles / emacs.d / slime-2012-01-20 / xref.lisp

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
;;; -*- Mode: LISP; Package: XREF; Syntax: Common-lisp;  -*- 
;;; Mon Jan 21 16:21:20 1991 by Mark Kantrowitz <mkant@GLINDA.OZ.CS.CMU.EDU>
;;; xref.lisp

;;; ****************************************************************
;;; List Callers: A Static Analysis Cross Referencing Tool for Lisp 
;;; ****************************************************************
;;; 
;;; The List Callers system is a portable Common Lisp cross referencing
;;; utility. It grovels over a set of files and compiles a database of the
;;; locations of all references for each symbol used in the files.
;;; List Callers is similar to the Symbolics Who-Calls and the
;;; Xerox Masterscope facilities.
;;;
;;; When you change a function or variable definition, it can be useful
;;; to know its callers, in order to update each of them to the new
;;; definition. Similarly, having a graphic display of the structure 
;;; (e.g., call graph) of a program can help make undocumented code more
;;; understandable. This static code analyzer facilitates both capabilities.
;;; The database compiled by xref is suitable for viewing by a graphical 
;;; browser. (Note: the reference graph is not necessarily a DAG. Since many
;;; graphical browsers assume a DAG, this will lead to infinite loops.
;;; Some code which is useful in working around this problem is included,
;;; as well as a sample text-indenting outliner and an interface to Bates'
;;; PSGraph Postscript Graphing facility.) 
;;;
;;; Written by Mark Kantrowitz, July 1990.
;;;
;;; Address: School of Computer Science
;;;          Carnegie Mellon University
;;;          Pittsburgh, PA 15213
;;;
;;; Copyright (c) 1990. All rights reserved.
;;;
;;; See general license below.
;;;

;;; ****************************************************************
;;; General License Agreement and Lack of Warranty *****************
;;; ****************************************************************
;;;
;;; This software is distributed in the hope that it will be useful (both
;;; in and of itself and as an example of lisp programming), but WITHOUT
;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
;;; the consequences of using it or for whether it serves any particular
;;; purpose or works at all. No warranty is made about the software or its
;;; performance. 
;;; 
;;; Use and copying of this software and the preparation of derivative
;;; works based on this software are permitted, so long as the following
;;; conditions are met:
;;; 	o  The copyright notice and this entire notice are included intact
;;; 	   and prominently carried on all copies and supporting documentation.
;;; 	o  No fees or compensation are charged for use, copies, or
;;; 	   access to this software. You may charge a nominal
;;; 	   distribution fee for the physical act of transferring a
;;; 	   copy, but you may not charge for the program itself. 
;;; 	o  If you modify this software, you must cause the modified
;;; 	   file(s) to carry prominent notices (a Change Log)
;;; 	   describing the changes, who made the changes, and the date
;;; 	   of those changes.
;;; 	o  Any work distributed or published that in whole or in part
;;; 	   contains or is a derivative of this software or any part 
;;; 	   thereof is subject to the terms of this agreement. The 
;;; 	   aggregation of another unrelated program with this software
;;; 	   or its derivative on a volume of storage or distribution
;;; 	   medium does not bring the other program under the scope
;;; 	   of these terms.
;;; 	o  Permission is granted to manufacturers and distributors of
;;; 	   lisp compilers and interpreters to include this software
;;; 	   with their distribution. 
;;; 
;;; This software is made available AS IS, and is distributed without 
;;; warranty of any kind, either expressed or implied.
;;; 
;;; In no event will the author(s) or their institutions be liable to you
;;; for damages, including lost profits, lost monies, or other special,
;;; incidental or consequential damages arising out of or in connection
;;; with the use or inability to use (including but not limited to loss of
;;; data or data being rendered inaccurate or losses sustained by third
;;; parties or a failure of the program to operate as documented) the 
;;; program, even if you have been advised of the possibility of such
;;; damanges, or for any claim by any other party, whether in an action of
;;; contract, negligence, or other tortious action.
;;; 
;;; The current version of this software and a variety of related utilities
;;; may be obtained by anonymous ftp from ftp.cs.cmu.edu in the directory
;;;    user/ai/lang/lisp/code/tools/xref/
;;; 
;;; Please send bug reports, comments, questions and suggestions to
;;; mkant@cs.cmu.edu. We would also appreciate receiving any changes
;;; or improvements you may make. 
;;; 
;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, 
;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
;;; address, and affiliation. This mailing list is primarily for
;;; notification about major updates, bug fixes, and additions to the lisp
;;; utilities collection. The mailing list is intended to have low traffic.
;;;

;;; ********************************
;;; Change Log *********************
;;; ********************************
;;;
;;; 27-FEB-91 mk   Added insert arg to psgraph-xref to allow the postscript
;;;                graphs to be inserted in Scribe documents.
;;; 21-FEB-91 mk   Added warning if not compiled.
;;; 07-FEB-91 mk   Fixed bug in record-callers with regard to forms at 
;;;                toplevel.
;;; 21-JAN-91 mk   Added file xref-test.lisp to test xref.
;;; 16-JAN-91 mk   Added definition WHO-CALLS to parallel the Symbolics syntax.
;;; 16-JAN-91 mk   Added macroexpansion capability to record-callers. Also
;;;                added parameter *handle-macro-forms*, defaulting to T.
;;; 16-JAN-91 mk   Modified print-caller-tree and related functions
;;;                to allow the user to specify root nodes. If the user
;;;                doesn't specify them, it will default to all root
;;;                nodes, as before. 
;;; 16-JAN-91 mk   Added parameter *default-graphing-mode* to specify
;;;                the direction of the graphing. Either :call-graph,
;;;                where the children of a node are those functions called
;;;                by the node, or :caller-graph where the children of a
;;;                node are the callers of the node. :call-graph is the
;;;                default.
;;; 16-JAN-91 mk   Added parameter *indent-amount* to control the indentation
;;;                in print-indented-tree.
;;; 16-JUL-90 mk   Functions with argument lists of () were being ignored
;;;                because of a (when form) wrapped around the body of
;;;                record-callers. Then intent of (when form) was as an extra
;;;                safeguard against infinite looping. This wasn't really
;;;                necessary, so it has been removed.
;;; 16-JUL-90 mk   PSGraph-XREF now has keyword arguments, instead of
;;;                optionals.
;;; 16-JUL-90 mk   Added PRINT-CLASS-HIERARCHY to use psgraph to graph the
;;;                CLOS class hierarchy. This really doesn't belong here,
;;;                and should be moved to psgraph.lisp as an example of how
;;;                to use psgraph.
;;; 16-JUL-90 mk   Fixed several caller patterns. The pattern for member
;;;                had an error which caused many references to be missed.
;;; 16-JUL-90 mk   Added ability to save/load processed databases.
;;;  5-JUL-91 mk    Fixed warning of needing compilation to occur only when the
;;;                 source is loaded.
;;; 20-SEP-93 mk    Added fix from Peter Norvig to allow Xref to xref itself.
;;;                 The arg to macro-function must be a symbol.

;;; ********************************
;;; To Do **************************
;;; ********************************
;;;
;;; Verify that:
;;;    o  null forms don't cause it to infinite loop.
;;;    o  nil matches against null argument lists.
;;;    o  declarations and doc are being ignored.
;;;
;;; Would be nice if in addition to showing callers of a function, it
;;; displayed the context of the calls to the function (e.g., the
;;; immediately surrounding form). This entails storing entries of
;;; the form (symbol context*) in the database and augmenting
;;; record-callers to keep the context around. The only drawbacks is
;;; that it would cons a fair bit. If we do this, we should store
;;; additional information as well in the database, such as the caller
;;; pattern type (e.g., variable vs. function).
;;;
;;; Write a translator from BNF (at least as much of BNF as is used
;;; in CLtL2), to the format used here.
;;;
;;; Should automatically add new patterns for new functions and macros
;;; based on their arglists. Probably requires much more than this
;;; simple code walker, so there isn't much we can do.
;;;
;;; Defmacro is a problem, because it often hides internal function
;;; calls within backquote and quote, which we normally ignore. If
;;; we redefine QUOTE's pattern so that it treats the arg like a FORM,
;;; we'll probably get them (though maybe the syntax will be mangled),
;;; but most likely a lot of spurious things as well. 
;;;
;;; Define an operation for Defsystem which will run XREF-FILE on the
;;; files of the system. Or yet simpler, when XREF sees a LOAD form
;;; for which the argument is a string, tries to recursively call
;;; XREF-FILE on the specified file. Then one could just XREF-FILE
;;; the file which loads the system. (This should be a program
;;; parameter.)
;;;
;;; Have special keywords which the user may place in a file to have
;;; XREF-FILE ignore a region.
;;;
;;; Should we distinguish flet and labels from defun? I.e., note that
;;; flet's definitions are locally defined, instead of just lumping
;;; them in with regular definitions.
;;;
;;; Add patterns for series, loop macro.
;;;
;;; Need to integrate the variable reference database with the other
;;; databases, yet maintain separation. So we can distinguish all
;;; the different types of variable and function references, without
;;; multiplying databases.
;;;
;;; Would pay to comment record-callers and record-callers* in more
;;; depth.
;;; 
;;; (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT)

;;; ********************************
;;; Notes **************************
;;; ********************************
;;;
;;;    XREF has been tested (successfully) in the following lisps:
;;;       CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
;;;       Macintosh Allegro Common Lisp (1.3.2)
;;;       ExCL (Franz Allegro CL 3.1.12 [DEC 3100] 3/30/90)
;;;       Lucid CL (Version 2.1 6-DEC-87)
;;;    
;;;    XREF has been tested (unsuccessfully) in the following lisps:
;;;       Ibuki Common Lisp (01/01, October 15, 1987)
;;;           - if interpreted, runs into stack overflow
;;;           - does not compile (tried ibcl on Suns, PMAXes and RTs)
;;;             seems to be due to a limitation in the c compiler.
;;;    
;;;    XREF needs to be tested in the following lisps:
;;;       Symbolics Common Lisp (8.0)
;;;       Lucid Common Lisp (3.0, 4.0)
;;;       KCL (June 3, 1987 or later)
;;;       AKCL (1.86, June 30, 1987 or later)
;;;       TI (Release 4.1 or later)
;;;       Golden Common Lisp (3.1 IBM-PC)
;;;       VAXLisp (2.0, 3.1)
;;;       HP Common Lisp (same as Lucid?)
;;;       Procyon Common Lisp


;;; ****************************************************************
;;; Documentation **************************************************
;;; ****************************************************************
;;;
;;; XREF analyzes a user's program, determining which functions call a
;;; given function, and the location of where variables are bound/assigned
;;; and used. The user may retrieve this information for either a single
;;; symbol, or display the call graph of portions of the program
;;; (including the entire program). This allows the programmer to debug
;;; and document the program's structure.
;;; 
;;; XREF is primarily intended for analyzing large programs, where it is
;;; difficult, if not impossible, for the programmer to grasp the structure
;;; of the whole program. Nothing precludes using XREF for smaller programs,
;;; where it can be useful for inspecting the relationships between pieces
;;; of the program and for documenting the program.
;;; 
;;; Two aspects of the Lisp programming language greatly simplify the
;;; analysis of Lisp programs:
;;; 	o  Lisp programs are naturally represented as data.
;;; 	   Successive definitions from a file are easily read in
;;; 	   as list structure.
;;; 	o  The basic syntax of Lisp is uniform. A list program
;;; 	   consists of a set of nested forms, where each form is
;;; 	   a list whose car is a tag (e.g., function name) that
;;; 	   specifies the structure of the rest of the form.
;;; Thus Lisp programs, when represented as data, can be considered to be
;;; parse trees. Given a grammar of syntax patterns for the language, XREF
;;; recursively descends the parse tree for a given definition, computing
;;; a set of relations that hold for the definition at each node in the
;;; tree. For example, one kind of relation is that the function defined
;;; by the definition calls the functions in its body. The relations are
;;; stored in a database for later examination by the user.
;;; 
;;; While XREF currently only works for programs written in Lisp, it could
;;; be extended to other programming languages by writing a function to
;;; generate parse trees for definitions in that language, and a core
;;; set of patterns for the language's syntax.
;;; 
;;; Since XREF normally does a static syntactic analysis of the program, 
;;; it does not detect references due to the expansion of a macro definition. 
;;; To do this in full generality XREF would have to have knowledge about the
;;; semantics of the program (e.g., macros which call other functions to
;;; do the expansion). This entails either modifying the compiler to
;;; record the relationships (e.g., Symbolics Who-Calls Database) or doing
;;; a walk of loaded code and macroexpanding as needed (PCL code walker).
;;; The former is not portable, while the latter requires that the code
;;; used by macros be loaded and in working order. On the other hand, then
;;; we would need no special knowledge about macros (excluding the 24 special
;;; forms of Lisp).
;;;
;;; Parameters may be set to enable macro expansion in XREF. Then XREF
;;; will expand any macros for which it does not have predefined patterns.
;;; (For example, most Lisps will implement dolist as a macro. Since XREF
;;; has a pattern defined for dolist, it will not call macroexpand-1 on
;;; a form whose car is dolist.) For this to work properly, the code must
;;; be loaded before being processed by XREF, and XREF's parameters should
;;; be set so that it processes forms in their proper packages. 
;;;
;;; If macro expansion is disabled, the default rules for handling macro
;;; references may not be sufficient for some user-defined macros, because
;;; macros allow a variety of non-standard syntactic extensions to the
;;; language. In this case, the user may specify additional templates in
;;; a manner similar to that in which the core Lisp grammar was specified.
;;;


;;; ********************************
;;; User Guide *********************
;;; ********************************
;;; -----
;;; The following functions are called to cross reference the source files.
;;;
;;; XREF-FILES (&rest files)                                      [FUNCTION]
;;;    Grovels over the lisp code located in source file FILES, using
;;;    xref-file.
;;;
;;; XREF-FILE (filename &optional clear-tables verbose)       [Function]
;;;    Cross references the function and variable calls in FILENAME by
;;;    walking over the source code located in the file. Defaults type of
;;;    filename to ".lisp". Chomps on the code using record-callers and
;;;    record-callers*. If CLEAR-TABLES is T (the default), it clears the
;;;    callers database before processing the file. Specify CLEAR-TABLES as
;;;    nil to append to the database. If VERBOSE is T (the default), prints
;;;    out the name of the file, one progress dot for each form processed,
;;;    and the total number of forms.
;;;
;;; -----
;;; The following functions display information about the uses of the 
;;; specified symbol as a function, variable, or constant.
;;;
;;; LIST-CALLERS (symbol)                                         [FUNCTION]
;;;    Lists all functions which call SYMBOL as a function (function
;;;    invocation).
;;;
;;; LIST-READERS (symbol)                                         [FUNCTION]
;;;    Lists all functions which refer to SYMBOL as a variable
;;;    (variable reference).
;;;
;;; LIST-SETTERS (symbol)                                         [FUNCTION]
;;;    Lists all functions which bind/set SYMBOL as a variable
;;;    (variable mutation).
;;;
;;; LIST-USERS (symbol)                                           [FUNCTION]
;;;    Lists all functions which use SYMBOL as a variable or function.
;;;
;;; WHO-CALLS (symbol &optional how)                              [FUNCTION]
;;;    Lists callers of symbol. HOW may be :function, :reader, :setter,
;;;    or :variable."
;;;
;;; WHAT-FILES-CALL (symbol)                                      [FUNCTION]
;;;    Lists names of files that contain uses of SYMBOL
;;;    as a function, variable, or constant.
;;;
;;; SOURCE-FILE (symbol)                                          [FUNCTION]
;;;    Lists the names of files in which SYMBOL is defined/used.
;;;
;;; LIST-CALLEES (symbol)                                         [FUNCTION]
;;;    Lists names of functions and variables called by SYMBOL.
;;;
;;; -----
;;; The following functions may be useful for viewing the database and
;;; debugging the calling patterns.
;;;
;;; *LAST-FORM* ()                                                [VARIABLE]
;;;    The last form read from the file. Useful for figuring out what went
;;;    wrong when xref-file drops into the debugger.
;;;
;;; *XREF-VERBOSE* t                                              [VARIABLE]
;;;    When T, xref-file(s) prints out the names of the files it looks at,
;;;    progress dots, and the number of forms read.
;;;
;;; *TYPES-TO-IGNORE* (quote (:lisp :lisp2))                      [VARIABLE]
;;;    Default set of caller types (as specified in the patterns) to ignore
;;;    in the database handling functions. :lisp is CLtL 1st edition,
;;;    :lisp2 is additional patterns from CLtL 2nd edition.
;;;
;;; *HANDLE-PACKAGE-FORMS* ()                                     [VARIABLE]
;;;    When non-NIL, and XREF-FILE sees a package-setting form like
;;;    IN-PACKAGE, sets the current package to the specified package by
;;;    evaluating the form. When done with the file, xref-file resets the
;;;    package to its original value. In some of the displaying functions,
;;;    when this variable is non-NIL one may specify that all symbols from a
;;;    particular set of packages be ignored. This is only useful if the
;;;    files use different packages with conflicting names.
;;;
;;; *HANDLE-FUNCTION-FORMS* t                                     [VARIABLE]
;;;    When T, XREF-FILE tries to be smart about forms which occur in
;;;    a function position, such as lambdas and arbitrary Lisp forms.
;;;    If so, it recursively calls record-callers with pattern 'FORM.
;;;    If the form is a lambda, makes the caller a caller of
;;;    :unnamed-lambda.
;;;
;;; *HANDLE-MACRO-FORMS* t                                        [VARIABLE]
;;;    When T, if the file was loaded before being processed by XREF, and
;;;    the car of a form is a macro, it notes that the parent calls the
;;;    macro, and then calls macroexpand-1 on the form.
;;;
;;; *DEFAULT-GRAPHING-MODE* :call-graph                           [VARIABLE]
;;;    Specifies whether we graph up or down. If :call-graph, the children
;;;    of a node are the functions it calls. If :caller-graph, the
;;;    children of a node are the functions that call it.
;;;
;;; *INDENT-AMOUNT* 3                                             [VARIABLE]
;;;    Number of spaces to indent successive levels in PRINT-INDENTED-TREE.
;;;
;;; DISPLAY-DATABASE (&optional database types-to-ignore)         [FUNCTION]
;;;    Prints out the name of each symbol and all its callers. Specify
;;;    database :callers (the default) to get function call references,
;;;    :file to the get files in which the symbol is called, :readers to get
;;;    variable references, and :setters to get variable binding and
;;;    assignments. Ignores functions of types listed in types-to-ignore.
;;;
;;; PRINT-CALLER-TREES (&key (mode *default-graphing-mode*)       [FUNCTION]
;;;                     (types-to-ignore *types-to-ignore*)
;;;                     compact root-nodes)
;;;    Prints the calling trees (which may actually be a full graph and not
;;;    necessarily a DAG) as indented text trees using
;;;    PRINT-INDENTED-TREE. MODE is :call-graph for trees where the children
;;;    of a node are the functions called by the node, or :caller-graph for
;;;    trees where the children of a node are the functions the node calls.
;;;    TYPES-TO-IGNORE is a list of funcall types (as specified in the
;;;    patterns) to ignore in printing out the database. For example,
;;;    '(:lisp) would ignore all calls to common lisp functions. COMPACT is
;;;    a flag to tell the program to try to compact the trees a bit by not
;;;    printing trees if they have already been seen. ROOT-NODES is a list
;;;    of root nodes of trees to display. If ROOT-NODES is nil, tries to
;;;    find all root nodes in the database.
;;;
;;; MAKE-CALLER-TREE (&optional (mode *default-graphing-mode*)    [FUNCTION]
;;;                   (types-to-ignore *types-to-ignore*)
;;;                   compact)
;;;    Outputs list structure of a tree which roughly represents the
;;;    possibly cyclical structure of the caller database.
;;;    If mode is :call-graph, the children of a node are the functions
;;;    it calls. If mode is :caller-graph, the children of a node are the
;;;    functions that call it.
;;;    If compact is T, tries to eliminate the already-seen nodes, so
;;;    that the graph for a node is printed at most once. Otherwise it will
;;;    duplicate the node's tree (except for cycles). This is usefull
;;;    because the call tree is actually a directed graph, so we can either
;;;    duplicate references or display only the first one.
;;;
;;; DETERMINE-FILE-DEPENDENCIES (&optional database)          [FUNCTION]
;;;    Makes a hash table of file dependencies for the references listed in
;;;    DATABASE. This function may be useful for automatically resolving
;;;    file references for automatic creation of a system definition
;;;    (defsystem).
;;;
;;; PRINT-FILE-DEPENDENCIES (&optional database)              [FUNCTION]
;;;    Prints a list of file dependencies for the references listed in
;;;    DATABASE. This function may be useful for automatically computing
;;;    file loading constraints for a system definition tool.
;;;
;;; WRITE-CALLERS-DATABASE-TO-FILE (filename)                     [FUNCTION]
;;;    Saves the contents of the current callers database to a file. This
;;;    file can be loaded to restore the previous contents of the
;;;    database. (For large systems it can take a long time to crunch
;;;    through the code, so this can save some time.)
;;;
;;; -----
;;; The following macros define new function and macro call patterns.
;;; They may be used to extend the static analysis tool to handle
;;; new def forms, extensions to Common Lisp, and program defs.
;;;
;;; DEFINE-PATTERN-SUBSTITUTION (name pattern)                    [MACRO]
;;;    Defines NAME to be equivalent to the specified pattern. Useful for
;;;    making patterns more readable. For example, the LAMBDA-LIST is
;;;    defined as a pattern substitution, making the definition of the
;;;    DEFUN caller-pattern simpler.
;;;
;;; DEFINE-CALLER-PATTERN (name pattern &optional caller-type)    [MACRO]
;;;    Defines NAME as a function/macro call with argument structure
;;;    described by PATTERN. CALLER-TYPE, if specified, assigns a type to
;;;    the pattern, which may be used to exclude references to NAME while
;;;    viewing the database. For example, all the Common Lisp definitions
;;;    have a caller-type of :lisp or :lisp2, so that you can exclude
;;;    references to common lisp functions from the calling tree.
;;;
;;; DEFINE-VARIABLE-PATTERN (name &optional caller-type)          [MACRO]
;;;    Defines NAME as a variable reference of type CALLER-TYPE. This is
;;;    mainly used to establish the caller-type of the variable.
;;;
;;; DEFINE-CALLER-PATTERN-SYNONYMS (source destinations)          [MACRO]
;;;    For defining function caller pattern syntax synonyms. For each name
;;;    in DESTINATIONS, defines its pattern as a copy of the definition
;;;    of SOURCE. Allows a large number of identical patterns to be defined
;;;    simultaneously. Must occur after the SOURCE has been defined.
;;;
;;; -----
;;; This system includes pattern definitions for the latest
;;; common lisp specification, as published in Guy Steele,
;;; Common Lisp: The Language, 2nd Edition.
;;;
;;; Patterns may be either structures to match, or a predicate
;;; like symbolp/numberp/stringp. The pattern specification language
;;; is similar to the notation used in CLtL2, but in a more lisp-like 
;;; form:
;;;    (:eq name)           The form element must be eq to the symbol NAME.
;;;    (:test test)         TEST must be true when applied to the form element.
;;;    (:typep type)        The form element must be of type TYPE.
;;;    (:or pat1 pat2 ...)  Tries each of the patterns in left-to-right order,
;;;                         until one succeeds.
;;;                         Equivalent to { pat1 | pat2 | ... }
;;;    (:rest pattern)      The remaining form elements are grouped into a
;;;                         list which is matched against PATTERN.
;;;    (:optional pat1 ...) The patterns may optionally match against the
;;;                         form element.
;;;                         Equivalent to [ pat1 ... ].
;;;    (:star pat1 ...)     The patterns may match against the patterns
;;;                         any number of times, including 0.
;;;                         Equivalent to { pat1 ... }*.
;;;    (:plus pat1 ...)     The patterns may match against the patterns
;;;                         any number of times, but at least once.
;;;                         Equivalent to { pat1 ... }+.
;;;    &optional, &key,     Similar in behavior to the corresponding
;;;    &rest                lambda-list keywords.
;;;    FORM                 A random lisp form. If a cons, assumes the
;;;                         car is a function or macro and tries to
;;;                         match the args against that symbol's pattern.
;;;                         If a symbol, assumes it's a variable reference.
;;;    :ignore              Ignores the corresponding form element.
;;;    NAME                 The corresponding form element should be
;;;                         the name of a new definition (e.g., the
;;;                         first arg in a defun pattern is NAME.
;;;    FUNCTION, MACRO      The corresponding form element should be
;;;                         a function reference not handled by FORM.
;;;                         Used in the definition of apply and funcall.
;;;    VAR                  The corresponding form element should be
;;;                         a variable definition or mutation. Used
;;;                         in the definition of let, let*, etc.
;;;    VARIABLE             The corresponding form element should be
;;;                         a variable reference. 
;;;
;;; In all other pattern symbols, it looks up the symbols pattern substitution
;;; and recursively matches against the pattern. Automatically destructures
;;; list structure that does not include consing dots.
;;;
;;; Among the pattern substitution names defined are:
;;;    STRING, SYMBOL, NUMBER    Appropriate :test patterns.
;;;    LAMBDA-LIST               Matches against a lambda list.
;;;    BODY                      Matches against a function body definition.
;;;    FN                        Matches against #'function, 'function,
;;;                              and lambdas. This is used in the definition
;;;                              of apply, funcall, and the mapping patterns.
;;;    and others...
;;;
;;; Here's some sample pattern definitions:
;;; (define-caller-pattern defun 
;;;   (name lambda-list
;;;	(:star (:or documentation-string declaration))
;;;	(:star form))
;;;  :lisp)
;;; (define-caller-pattern funcall (fn (:star form)) :lisp)
;;;
;;; In general, the system is intelligent enough to handle any sort of
;;; simple funcall. One only need specify the syntax for functions and
;;; macros which use optional arguments, keyword arguments, or some
;;; argument positions are special, such as in apply and funcall, or
;;; to indicate that the function is of the specified caller type.
;;;
;;;
;;; NOTES:
;;;
;;;    XRef assumes syntactically correct lisp code.
;;;
;;;    This is by no means perfect. For example, let and let* are treated
;;;    identically, instead of differentiating between serial and parallel
;;;    binding. But it's still a useful tool. It can be helpful in 
;;;    maintaining code, debugging problems with patch files, determining
;;;    whether functions are multiply defined, and help you remember where
;;;    a function is defined or called.
;;;
;;;    XREF runs best when compiled.

;;; ********************************
;;; References *********************
;;; ********************************
;;;
;;; Xerox Interlisp Masterscope Program:
;;;   Larry M Masinter, Global program analysis in an interactive environment
;;;   PhD Thesis, Stanford University, 1980. 
;;;
;;; Symbolics Who-Calls Database:
;;;   User's Guide to Symbolics Computers, Volume 1, Cambridge, MA, July 1986
;;;   Genera 7.0, pp 183-185.
;;;   

;;; ********************************
;;; Example ************************
;;; ********************************
;;; 
;;; Here is an example of running XREF on a short program.
;;; [In Scribe documentation, give a simple short program and resulting
;;;  XREF output, including postscript call graphs.]
#|
<cl> (xref:xref-file  "/afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp")
Cross-referencing file /afs/cs/user/mkant/Lisp/Graph-Dag/graph-dag.lisp.
................................................
48 forms processed.
<cl> (xref:display-database :readers)

*DISPLAY-CUTOFF-DEPTH* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*OFFSET-FROM-EDGE-OF-PANE* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE.
*WITHIN-LEVEL-SPACING* is referenced by BREADTH CALCULATE-POSITION-INFO.
*DIRECTION* is referenced by CREATE-POSITION-INFO.
*LINK-OFFSET* is referenced by OFFSET-OF-LINK-FROM-ATTACHMENT-POINT.
*ROOT-IS-SEQUENCE* is referenced by GRAPH.
*LEVEL-SPACING* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE.
*ORIENTATION* is referenced by BREADTH CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CALCULATE-POSITION-IN-LEVEL.
*DEFAULT-GRAPH-POSITION* is referenced by CREATE-POSITION-INFO.
*GRAPHING-CUTOFF-DEPTH* is referenced by CREATE-NODE-STRUCTURE.
*LIST-OF-NODES* is referenced by CALCULATE-LEVEL-POSITION CALCULATE-LEVEL-POSITION-BEFORE CREATE-NODE FIND-NODE.
*GRAPH-TYPE* is referenced by CREATE-NODE-STRUCTURE.
<cl> (xref:print-caller-trees :root-nodes '(display-graph))

Rooted calling trees:
  DISPLAY-GRAPH
     CREATE-POSITION-INFO
        CALCULATE-POSITION-INFO
           CALCULATE-POSITION
              NODE-POSITION-ALREADY-SET-FLAG
              NODE-LEVEL-ALREADY-SET-FLAG
              CALCULATE-POSITION-IN-LEVEL
                 NODE-CHILDREN
                 NODE-LEVEL
                 CALCULATE-POSITION
                 NEW-CALCULATE-BREADTH
                    NODE-CHILDREN
                    BREADTH
                       OPPOSITE-DIMENSION
                          NODE-HEIGHT
                          NODE-WIDTH
                    NEW-CALCULATE-BREADTH
                    NODE-PARENTS
                 OPPOSITE-DIMENSION
                    NODE-HEIGHT
                    NODE-WIDTH
                 OPPOSITE-POSITION
                    NODE-Y
                    NODE-X
        NODE-LEVEL
        CALCULATE-LEVEL-POSITION
           NODE-LEVEL
           NODE-POSITION
              NODE-X
              NODE-Y
           DIMENSION
              NODE-WIDTH
              NODE-HEIGHT
        CALCULATE-LEVEL-POSITION-BEFORE
           NODE-LEVEL
           NODE-POSITION
              NODE-X
              NODE-Y
           NODE-WIDTH
           NODE-HEIGHT
           DIMENSION
              NODE-WIDTH
              NODE-HEIGHT
|#

;;; ****************************************************************
;;; List Callers ***************************************************
;;; ****************************************************************

(defpackage :pxref
  (:use :common-lisp)
  (:export #:list-callers 
	   #:list-users 
	   #:list-readers 
	   #:list-setters
	   #:what-files-call
	   #:who-calls 
	   #:list-callees 
	   #:source-file 
	   #:clear-tables
	   #:define-pattern-substitution 
	   #:define-caller-pattern 
	   #:define-variable-pattern 
	   #:define-caller-pattern-synonyms
	   #:clear-patterns
	   #:*last-form* 
	   #:*xref-verbose* 
	   #:*handle-package-forms* 
	   #:*handle-function-forms*
	   #:*handle-macro-forms*
	   #:*types-to-ignore*
	   #:*last-caller-tree* 
	   #:*default-graphing-mode* 
	   #:*indent-amount*
	   #:xref-file 
	   #:xref-files
	   #:write-callers-database-to-file
	   #:display-database
	   #:print-caller-trees 
	   #:make-caller-tree 
	   #:print-indented-tree 
	   #:determine-file-dependencies 
	   #:print-file-dependencies
	   #:psgraph-xref
	   ))

(in-package "PXREF")

;;; Warn user if they're loading the source instead of compiling it first.
;(eval-when (compile load eval)
;  (defvar compiled-p nil))
;(eval-when (compile load)
;  (setq compiled-p t))
;(eval-when (load eval)
;  (unless compiled-p
;    (warn "This file should be compiled before loading for best results.")))
(eval-when (eval)
   (warn "This file should be compiled before loading for best results."))


;;; ********************************
;;; Primitives *********************
;;; ********************************
(defun lookup (symbol environment)
  (dolist (frame environment)
    (when (member symbol frame)
      (return symbol))))

(defun car-eq (list item)
  (and (consp list)
       (eq (car list) item)))

;;; ********************************
;;; Callers Database ***************
;;; ********************************
(defvar *file-callers-database* (make-hash-table :test #'equal)
  "Contains name and list of file callers (files which call) for that name.")
(defvar *callers-database* (make-hash-table :test #'equal)
  "Contains name and list of callers (function invocation) for that name.")
(defvar *readers-database* (make-hash-table :test #'equal)
  "Contains name and list of readers (variable use) for that name.")
(defvar *setters-database* (make-hash-table :test #'equal)
  "Contains name and list of setters (variable mutation) for that name.")
(defvar *callees-database* (make-hash-table :test #'equal)
  "Contains name and list of functions and variables it calls.")
(defun callers-list (name &optional (database :callers))
  (case database
    (:file    (gethash name *file-callers-database*))
    (:callees (gethash name *callees-database*))
    (:callers (gethash name *callers-database*))
    (:readers (gethash name *readers-database*))
    (:setters (gethash name *setters-database*))))
(defsetf callers-list (name &optional (database :callers)) (caller)
  `(setf (gethash ,name (case ,database
			  (:file    *file-callers-database*)
			  (:callees *callees-database*)
			  (:callers *callers-database*)
			  (:readers *readers-database*)
			  (:setters *setters-database*)))
	 ,caller))

(defun list-callers (symbol)
  "Lists all functions which call SYMBOL as a function (function invocation)."
  (callers-list symbol :callers))
(defun list-readers (symbol)
  "Lists all functions which refer to SYMBOL as a variable 
   (variable reference)."
  (callers-list symbol :readers))
(defun list-setters (symbol)
  "Lists all functions which bind/set SYMBOL as a variable 
   (variable mutation)."
  (callers-list symbol :setters))
(defun list-users (symbol)
  "Lists all functions which use SYMBOL as a variable or function."
  (values (list-callers symbol)
	  (list-readers symbol)
	  (list-setters symbol)))
(defun who-calls (symbol &optional how)
  "Lists callers of symbol. HOW may be :function, :reader, :setter,
   or :variable."
  ;; would be nice to have :macro and distinguish variable
  ;; binding from assignment. (i.e., variable binding, assignment, and use)
  (case how
    (:function (list-callers symbol))
    (:reader   (list-readers symbol))
    (:setter   (list-setters symbol))
    (:variable (append (list-readers symbol) 
		       (list-setters symbol)))
    (otherwise (append (list-callers symbol)
		       (list-readers symbol)
		       (list-setters symbol)))))
(defun what-files-call (symbol)
  "Lists names of files that contain uses of SYMBOL 
   as a function, variable, or constant."
  (callers-list symbol :file))
(defun list-callees (symbol)
  "Lists names of functions and variables called by SYMBOL."
  (callers-list symbol :callees))

(defvar *source-file* (make-hash-table :test #'equal)
  "Contains function name and source file for that name.")
(defun source-file (symbol)
  "Lists the names of files in which SYMBOL is defined/used."
  (gethash symbol *source-file*))
(defsetf source-file (name) (value)
  `(setf (gethash ,name *source-file*) ,value))

(defun clear-tables ()
  (clrhash *file-callers-database*)
  (clrhash *callers-database*)
  (clrhash *callees-database*)
  (clrhash *readers-database*)
  (clrhash *setters-database*)
  (clrhash *source-file*))


;;; ********************************
;;; Pattern Database ***************
;;; ********************************
;;; Pattern Types
(defvar *pattern-caller-type* (make-hash-table :test #'equal))
(defun pattern-caller-type (name)
  (gethash name *pattern-caller-type*))
(defsetf pattern-caller-type (name) (value)
  `(setf (gethash ,name *pattern-caller-type*) ,value))

;;; Pattern Substitutions
(defvar *pattern-substitution-table* (make-hash-table :test #'equal)
  "Stores general patterns for function destructuring.")
(defun lookup-pattern-substitution (name)
  (gethash name *pattern-substitution-table*))
(defmacro define-pattern-substitution (name pattern)
  "Defines NAME to be equivalent to the specified pattern. Useful for
   making patterns more readable. For example, the LAMBDA-LIST is 
   defined as a pattern substitution, making the definition of the
   DEFUN caller-pattern simpler."
  `(setf (gethash ',name *pattern-substitution-table*)
	 ',pattern))

;;; Function/Macro caller patterns: 
;;; The car of the form is skipped, so we don't need to specify
;;; (:eq function-name) like we would for a substitution.
;;;
;;; Patterns must be defined in the XREF package because the pattern
;;; language is tested by comparing symbols (using #'equal) and not
;;; their printreps. This is fine for the lisp grammer, because the XREF
;;; package depends on the LISP package, so a symbol like 'xref::cons is
;;; translated automatically into 'lisp::cons. However, since
;;; (equal 'foo::bar 'baz::bar) returns nil unless both 'foo::bar and
;;; 'baz::bar are inherited from the same package (e.g., LISP), 
;;; if package handling is turned on the user must specify package 
;;; names in the caller pattern definitions for functions that occur
;;; in packages other than LISP, otherwise the symbols will not match.
;;; 
;;; Perhaps we should enforce the definition of caller patterns in the
;;; XREF package by wrapping the body of define-caller-pattern in
;;; the XREF package:
;;;    (defmacro define-caller-pattern (name value &optional caller-type)
;;;      (let ((old-package *package*))
;;;        (setf *package* (find-package "XREF"))
;;;        (prog1
;;;    	     `(progn
;;;    	        (when ',caller-type
;;;         	     (setf (pattern-caller-type ',name) ',caller-type))
;;;    	        (when ',value 
;;;    	          (setf (gethash ',name *caller-pattern-table*)
;;;    		        ',value)))
;;;          (setf *package* old-package)))) 
;;; Either that, or for the purpose of pattern testing we should compare
;;; printreps. [The latter makes the primitive patterns like VAR
;;; reserved words.]
(defvar *caller-pattern-table* (make-hash-table :test #'equal)
  "Stores patterns for function destructuring.")
(defun lookup-caller-pattern (name)
  (gethash name *caller-pattern-table*))
(defmacro define-caller-pattern (name pattern &optional caller-type)
  "Defines NAME as a function/macro call with argument structure
   described by PATTERN. CALLER-TYPE, if specified, assigns a type to
   the pattern, which may be used to exclude references to NAME while
   viewing the database. For example, all the Common Lisp definitions
   have a caller-type of :lisp or :lisp2, so that you can exclude 
   references to common lisp functions from the calling tree."
  `(progn
     (when ',caller-type
       (setf (pattern-caller-type ',name) ',caller-type))
     (when ',pattern 
       (setf (gethash ',name *caller-pattern-table*)
	     ',pattern))))

;;; For defining variables
(defmacro define-variable-pattern (name &optional caller-type)
  "Defines NAME as a variable reference of type CALLER-TYPE. This is
   mainly used to establish the caller-type of the variable."
  `(progn
     (when ',caller-type
       (setf (pattern-caller-type ',name) ',caller-type))))

;;; For defining synonyms. Means much less space taken up by the patterns.
(defmacro define-caller-pattern-synonyms (source destinations)
  "For defining function caller pattern syntax synonyms. For each name
   in DESTINATIONS, defines its pattern as a copy of the definition of SOURCE.
   Allows a large number of identical patterns to be defined simultaneously.
   Must occur after the SOURCE has been defined."
  `(let ((source-type (pattern-caller-type ',source))
	 (source-pattern (gethash ',source *caller-pattern-table*)))
     (when source-type
       (dolist (dest ',destinations)
	 (setf (pattern-caller-type dest) source-type)))
     (when source-pattern
       (dolist (dest ',destinations)
	 (setf (gethash dest *caller-pattern-table*)
	       source-pattern)))))

(defun clear-patterns ()
  (clrhash *pattern-substitution-table*)
  (clrhash *caller-pattern-table*)
  (clrhash *pattern-caller-type*))

;;; ********************************
;;; Cross Reference Files **********
;;; ********************************
(defvar *last-form* ()
  "The last form read from the file. Useful for figuring out what went wrong
   when xref-file drops into the debugger.")

(defvar *xref-verbose* t
  "When T, xref-file(s) prints out the names of the files it looks at,
   progress dots, and the number of forms read.")

;;; This needs to first clear the tables?
(defun xref-files (&rest files)
  "Grovels over the lisp code located in source file FILES, using xref-file."
  ;; If the arg is a list, use it.
  (when (listp (car files)) (setq files (car files)))
  (dolist (file files)
    (xref-file file nil))
  (values))

(defvar *handle-package-forms* nil	;'(lisp::in-package)
  "When non-NIL, and XREF-FILE sees a package-setting form like IN-PACKAGE,
   sets the current package to the specified package by evaluating the
   form. When done with the file, xref-file resets the package to its 
   original value. In some of the displaying functions, when this variable
   is non-NIL one may specify that all symbols from a particular set of
   packages be ignored. This is only useful if the files use different
   packages with conflicting names.")

(defvar *normal-readtable* (copy-readtable nil)
  "Normal, unadulterated CL readtable.")

(defun xref-file (filename &optional (clear-tables t) (verbose *xref-verbose*))
  "Cross references the function and variable calls in FILENAME by
   walking over the source code located in the file. Defaults type of
   filename to \".lisp\". Chomps on the code using record-callers and
   record-callers*. If CLEAR-TABLES is T (the default), it clears the callers
   database before processing the file. Specify CLEAR-TABLES as nil to
   append to the database. If VERBOSE is T (the default), prints out the
   name of the file, one progress dot for each form processed, and the
   total number of forms."
  ;; Default type to "lisp"
  (when (and (null (pathname-type filename))
	     (not  (probe-file filename)))
    (cond ((stringp filename)
	   (setf filename (concatenate 'string filename ".lisp")))
	  ((pathnamep filename)
	   (setf filename (merge-pathnames filename
					   (make-pathname :type "lisp"))))))
  (when clear-tables (clear-tables))
  (let ((count 0)
	(old-package *package*)
	(*readtable* *normal-readtable*))
    (when verbose
      (format t "~&Cross-referencing file ~A.~&" filename))
    (with-open-file (stream filename :direction :input)
      (do ((form (read stream nil :eof) (read stream nil :eof)))
	  ((eq form :eof))
	(incf count)
	(when verbose
	  (format *standard-output* ".")
	  (force-output *standard-output*))
	(setq *last-form* form)
	(record-callers filename form)
	;; Package Magic.
	(when (and *handle-package-forms*
		   (consp form)
		   (member (car form) *handle-package-forms*))
	  (eval form))))
    (when verbose 
      (format t "~&~D forms processed." count))
    (setq *package* old-package)
    (values)))

(defvar *handle-function-forms* t
  "When T, XREF-FILE tries to be smart about forms which occur in
   a function position, such as lambdas and arbitrary Lisp forms.
   If so, it recursively calls record-callers with pattern 'FORM.
   If the form is a lambda, makes the caller a caller of :unnamed-lambda.") 

(defvar *handle-macro-forms* t
  "When T, if the file was loaded before being processed by XREF, and the
   car of a form is a macro, it notes that the parent calls the macro,
   and then calls macroexpand-1 on the form.") 

(defvar *callees-database-includes-variables* nil)

(defun record-callers (filename form 
				&optional pattern parent (environment nil)
				funcall)
  "RECORD-CALLERS is the main routine used to walk down the code. It matches
   the PATTERN against the FORM, possibly adding statements to the database.
   PARENT is the name defined by the current outermost definition; it is
   the caller of the forms in the body (e.g., FORM). ENVIRONMENT is used
   to keep track of the scoping of variables. FUNCALL deals with the type
   of variable assignment and hence how the environment should be modified.
   RECORD-CALLERS handles atomic patterns and simple list-structure patterns.
   For complex list-structure pattern destructuring, it calls RECORD-CALLERS*."
;  (when form)
  (unless pattern (setq pattern 'FORM))
  (cond ((symbolp pattern)
	 (case pattern
	   (:IGNORE
	    ;; Ignores the rest of the form.
	    (values t parent environment))
	   (NAME    
	    ;; This is the name of a new definition.
	    (push filename (source-file form))
	    (values t form   environment))
	   ((FUNCTION MACRO)
	    ;; This is the name of a call.
	    (cond ((and *handle-function-forms* (consp form))
		   ;; If we're a cons and special handling is on,
		   (when (eq (car form) 'lambda)
		     (pushnew filename (callers-list :unnamed-lambda :file))
		     (when parent
		       (pushnew parent (callers-list :unnamed-lambda
						     :callers))
		       (pushnew :unnamed-lambda (callers-list parent
							      :callees))))
		   (record-callers filename form 'form parent environment))
		  (t 
		   ;; If we're just a regular function name call.
		   (pushnew filename (callers-list form :file))
		   (when parent
		     (pushnew parent (callers-list form :callers))
		     (pushnew form (callers-list parent :callees)))
		   (values t parent environment)))) 
	   (VAR     
	    ;; This is the name of a new variable definition.
	    ;; Includes arglist parameters.
	    (when (and (symbolp form) (not (keywordp form))
		       (not (member form lambda-list-keywords)))
	      (pushnew form (car environment))
	      (pushnew filename (callers-list form :file))
	      (when parent 
;		  (pushnew form (callers-list parent :callees))
		(pushnew parent (callers-list form :setters)))
	      (values t parent environment)))
	   (VARIABLE
	    ;; VAR reference
	    (pushnew filename (callers-list form :file))
	    (when (and parent (not (lookup form environment)))
	      (pushnew parent (callers-list form :readers))
	      (when *callees-database-includes-variables*
		(pushnew form (callers-list parent :callees))))
	    (values t parent environment))
	   (FORM    
	    ;; A random form (var or funcall).
	    (cond ((consp form)
		   ;; Get new pattern from TAG.
		   (let ((new-pattern (lookup-caller-pattern (car form))))
		     (pushnew filename (callers-list (car form) :file))
		     (when parent
		       (pushnew parent (callers-list (car form) :callers))
		       (pushnew (car form) (callers-list parent :callees)))
		     (cond ((and new-pattern (cdr form))
			    ;; Special Pattern and there's stuff left
			    ;; to be processed. Note that we check if
			    ;; a pattern is defined for the form before
			    ;; we check to see if we can macroexpand it.
			    (record-callers filename (cdr form) new-pattern
					    parent environment :funcall))
			   ((and *handle-macro-forms*
				 (symbolp (car form)) ; pnorvig 9/9/93
				 (macro-function (car form)))
			    ;; The car of the form is a macro and
			    ;; macro processing is turned on. Macroexpand-1
			    ;; the form and try again.
			    (record-callers filename 
					    (macroexpand-1 form)
					    'form parent environment 
					    :funcall))
			   ((null (cdr form))
			    ;; No more left to be processed. Note that
			    ;; this must occur after the macros clause,
			    ;; since macros can expand into more code.
			    (values t parent environment))
			   (t
			    ;; Random Form. We assume it is a function call.
			    (record-callers filename (cdr form)
					    '((:star FORM))
					    parent environment :funcall)))))
		  (t 
		   (when (and (not (lookup form environment))
			      (not (numberp form))
			      ;; the following line should probably be 
			      ;; commented out?
			      (not (keywordp form))
			      (not (stringp form))
			      (not (eq form t))
			      (not (eq form nil)))
		     (pushnew filename (callers-list form :file))
		     ;; ??? :callers
		     (when parent
		       (pushnew parent (callers-list form :readers))
		       (when *callees-database-includes-variables*
			 (pushnew form (callers-list parent :callees)))))
		   (values t parent environment))))
	   (otherwise 
	    ;; Pattern Substitution
	    (let ((new-pattern (lookup-pattern-substitution pattern)))
	      (if new-pattern
		  (record-callers filename form new-pattern 
				  parent environment)
		  (when (eq pattern form)
		    (values t parent environment)))))))
	((consp pattern)
	 (case (car pattern)
	   (:eq    (when (eq (second pattern) form)
		     (values t parent environment)))
	   (:test  (when (funcall (eval (second pattern)) form)
		     (values t parent environment)))
	   (:typep (when (typep form (second pattern))
		     (values t parent environment)))
	   (:or    (dolist (subpat (rest pattern))
		     (multiple-value-bind (processed parent environment)
			 (record-callers filename form subpat
					 parent environment)
		       (when processed
			 (return (values processed parent environment))))))
	   (:rest			; (:star :plus :optional :rest)
	    (record-callers filename form (second pattern)
			    parent environment))
	   (otherwise
	    (multiple-value-bind (d p env)
		(record-callers* filename form pattern 
				 parent (cons nil environment))
	      (values d p (if funcall environment env))))))))

(defun record-callers* (filename form pattern parent environment
				 &optional continuation 
				 in-optionals in-keywords)
  "RECORD-CALLERS* handles complex list-structure patterns, such as
   ordered lists of subpatterns, patterns involving :star, :plus,
   &optional, &key, &rest, and so on. CONTINUATION is a stack of
   unprocessed patterns, IN-OPTIONALS and IN-KEYWORDS are corresponding
   stacks which determine whether &rest or &key has been seen yet in
   the current pattern."   
  ;; form must be a cons or nil.
;  (when form)
  (if (null pattern)
      (if (null continuation)
	  (values t parent environment)
	  (record-callers* filename form (car continuation) parent environment
			   (cdr continuation) 
			   (cdr in-optionals)
			   (cdr in-keywords)))
      (let ((pattern-elt (car pattern)))
	(cond ((car-eq pattern-elt :optional)
	       (if (null form) 
		   (values t parent environment)
		   (multiple-value-bind (processed par env)
		       (record-callers* filename form (cdr pattern-elt)
					parent environment
					(cons (cdr pattern) continuation)
					(cons (car in-optionals) in-optionals)
					(cons (car in-keywords) in-keywords))
		     (if processed
			 (values processed par env)
			 (record-callers* filename form (cdr pattern)
					  parent environment continuation
					  in-optionals in-keywords)))))
	      ((car-eq pattern-elt :star)
	       (if (null form)
		   (values t parent environment)
		   (multiple-value-bind (processed par env)
		       (record-callers* filename form (cdr pattern-elt)
					parent environment
					(cons pattern continuation)
					(cons (car in-optionals) in-optionals)
					(cons (car in-keywords) in-keywords))
		     (if processed
			 (values processed par env)
			 (record-callers* filename form (cdr pattern)
					  parent environment continuation
					  in-optionals in-keywords)))))
	      ((car-eq pattern-elt :plus)
	       (record-callers* filename form (cdr pattern-elt)
				parent environment
				(cons (cons (cons :star (cdr pattern-elt))
					    (cdr pattern))
				      continuation)
				(cons (car in-optionals) in-optionals)
				(cons (car in-keywords) in-keywords)))
	      ((car-eq pattern-elt :rest)
	       (record-callers filename form pattern-elt parent environment))
	      ((eq pattern-elt '&optional)
	       (record-callers* filename form (cdr pattern)
				parent environment continuation
				(cons t in-optionals)
				(cons (car in-keywords) in-keywords)))
	      ((eq pattern-elt '&rest)
	       (record-callers filename form (second pattern)
			       parent environment))
	      ((eq pattern-elt '&key)
	       (record-callers* filename form (cdr pattern)
				parent environment continuation
				(cons (car in-optionals) in-optionals)
				(cons t in-keywords)))
	      ((null form)
	       (when (or (car in-keywords) (car in-optionals))
		 (values t parent environment)))
	      ((consp form)
	       (multiple-value-bind (processed parent environment)
		   (record-callers filename (if (car in-keywords)
						(cadr form)
						(car form))
				   pattern-elt
				   parent environment)
		 (cond (processed
			(record-callers* filename (if (car in-keywords)
						      (cddr form)
						      (cdr form))
					 (cdr pattern)
					 parent environment
					 continuation
					 in-optionals in-keywords))
		       ((or (car in-keywords)
			    (car in-optionals))
			(values t parent environment)))))))))


;;; ********************************
;;; Misc Utilities *****************
;;; ********************************
(defvar *types-to-ignore*
  '(:lisp				; CLtL 1st Edition
    :lisp2				; CLtL 2nd Edition additional patterns
    )
  "Default set of caller types (as specified in the patterns) to ignore
   in the database handling functions. :lisp is CLtL 1st edition,
   :lisp2 is additional patterns from CLtL 2nd edition.")

(defun display-database (&optional (database :callers) 
				   (types-to-ignore *types-to-ignore*))
  "Prints out the name of each symbol and all its callers. Specify database
   :callers (the default) to get function call references, :fill to the get
   files in which the symbol is called, :readers to get variable references,
   and :setters to get variable binding and assignments. Ignores functions
   of types listed in types-to-ignore."
  (maphash #'(lambda (name callers)
	       (unless (or (member (pattern-caller-type name)
				   types-to-ignore)
			   ;; When we're doing fancy package crap,
			   ;; allow us to ignore symbols based on their
			   ;; packages.
			   (when *handle-package-forms*
			     (member (symbol-package name)
				     types-to-ignore
				     :key #'find-package)))
		 (format t "~&~S is referenced by~{ ~S~}."
			 name callers)))
	   (ecase database
	     (:file    *file-callers-database*)
	     (:callers *callers-database*)
	     (:readers *readers-database*)
	     (:setters *setters-database*))))

(defun write-callers-database-to-file (filename)
  "Saves the contents of the current callers database to a file. This
   file can be loaded to restore the previous contents of the
   database. (For large systems it can take a long time to crunch
   through the code, so this can save some time.)"
  (with-open-file (stream filename :direction :output)
    (format stream "~&(clear-tables)")
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (source-file '~S) '~S)"
			 x y))
	     *source-file*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :file) '~S)"
			 x y))
	     *file-callers-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :callers) '~S)"
			 x y))
	     *callers-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :callees) '~S)"
			 x y))
	     *callees-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :readers) '~S)"
			 x y))
	     *readers-database*)
    (maphash #'(lambda (x y) 
		 (format stream "~&(setf (callers-list '~S :setters) '~S)"
			 x y))
	     *setters-database*)))


;;; ********************************
;;; Print Caller Trees *************
;;; ********************************
;;; The following function is useful for reversing a caller table into
;;; a callee table. Possibly later we'll extend xref to create two 
;;; such database hash tables. Needs to include vars as well.
(defun invert-hash-table (table &optional (types-to-ignore *types-to-ignore*))
  "Makes a copy of the hash table in which (name value*) pairs
   are inverted to (value name*) pairs."
  (let ((target (make-hash-table :test #'equal)))
    (maphash #'(lambda (key values)
		 (dolist (value values)
		   (unless (member (pattern-caller-type key) 
				   types-to-ignore)
		     (pushnew key (gethash value target)))))
	     table)
    target))

;;; Resolve file references for automatic creation of a defsystem file.
(defun determine-file-dependencies (&optional (database *callers-database*))
  "Makes a hash table of file dependencies for the references listed in
   DATABASE. This function may be useful for automatically resolving
   file references for automatic creation of a system definition (defsystem)."
  (let ((file-ref-ht  (make-hash-table :test #'equal)))
    (maphash #'(lambda (key values)
		 (let ((key-file (source-file key)))
		   (when key
		     (dolist (value values)
		       (let ((value-file (source-file value)))
			 (when value-file
			   (dolist (s key-file)
			     (dolist (d value-file)
			       (pushnew d (gethash s file-ref-ht))))))))))
	     database)
    file-ref-ht))

(defun print-file-dependencies (&optional (database *callers-database*))
  "Prints a list of file dependencies for the references listed in DATABASE.
   This function may be useful for automatically computing file loading
   constraints for a system definition tool."
  (maphash #'(lambda (key value) (format t "~&~S --> ~S" key value))
	   (determine-file-dependencies database)))

;;; The following functions demonstrate a possible way to interface
;;; xref to a graphical browser such as psgraph to mimic the capabilities
;;; of Masterscope's graphical browser. 

(defvar *last-caller-tree* nil)

(defvar *default-graphing-mode* :call-graph
  "Specifies whether we graph up or down. If :call-graph, the children
   of a node are the functions it calls. If :caller-graph, the children
   of a node are the functions that call it.") 

(defun gather-tree (parents &optional already-seen 
			    (mode *default-graphing-mode*)
			    (types-to-ignore *types-to-ignore*) compact)
  "Extends the tree, copying it into list structure, until it repeats
   a reference (hits a cycle)."
  (let ((*already-seen* nil)
	(database (case mode
		    (:call-graph   *callees-database*)
		    (:caller-graph *callers-database*))))
    (declare (special *already-seen*))
    (labels 
	((amass-tree
	  (parents &optional already-seen)
	  (let (result this-item)
	    (dolist (parent parents)
	      (unless (member (pattern-caller-type parent)
			      types-to-ignore)
		(pushnew parent *already-seen*)
		(if (member parent already-seen)
		    (setq this-item nil) ; :ignore
		    (if compact 
			(multiple-value-setq (this-item already-seen)
			    (amass-tree (gethash parent database)
					(cons parent already-seen)))
			(setq this-item
			      (amass-tree (gethash parent database)
					  (cons parent already-seen)))))
		(setq parent (format nil "~S" parent))
		(when (consp parent) (setq parent (cons :xref-list parent)))
		(unless (eq this-item :ignore)
		  (push (if this-item
			    (list parent this-item)
			    parent) 
			result))))
	    (values result		;(reverse result)
		    already-seen))))
      (values (amass-tree parents already-seen)
	      *already-seen*))))

(defun find-roots-and-cycles (&optional (mode *default-graphing-mode*)
					(types-to-ignore *types-to-ignore*))
  "Returns a list of uncalled callers (roots) and called callers (potential
   cycles)."
  (let ((uncalled-callers nil)
	(called-callers nil)
	(database (ecase mode
		    (:call-graph   *callers-database*)
		    (:caller-graph *callees-database*)))
	(other-database (ecase mode
			  (:call-graph   *callees-database*)
			  (:caller-graph *callers-database*))))
    (maphash #'(lambda (name value)
		 (declare (ignore value))
		 (unless (member (pattern-caller-type name) 
				 types-to-ignore)
		   (if (gethash name database)
		       (push name called-callers)
		       (push name uncalled-callers))))
	     other-database)
    (values uncalled-callers called-callers)))

(defun make-caller-tree (&optional (mode *default-graphing-mode*)
				   (types-to-ignore *types-to-ignore*) compact)
  "Outputs list structure of a tree which roughly represents the possibly
   cyclical structure of the caller database.
   If mode is :call-graph, the children of a node are the functions it calls.
   If mode is :caller-graph, the children of a node are the functions that
   call it.
   If compact is T, tries to eliminate the already-seen nodes, so that
   the graph for a node is printed at most once. Otherwise it will duplicate
   the node's tree (except for cycles). This is usefull because the call tree
   is actually a directed graph, so we can either duplicate references or
   display only the first one."
  ;; Would be nice to print out line numbers and whenever we skip a duplicated
  ;; reference, print the line number of the full reference after the node.
  (multiple-value-bind (uncalled-callers called-callers)
      (find-roots-and-cycles mode types-to-ignore)
    (multiple-value-bind (trees already-seen)
	(gather-tree uncalled-callers nil mode types-to-ignore compact)
      (setq *last-caller-tree* trees)
      (let ((more-trees (gather-tree (set-difference called-callers
						     already-seen)
				     already-seen 
				     mode types-to-ignore compact)))
	(values trees more-trees)))))

(defvar *indent-amount* 3
  "Number of spaces to indent successive levels in PRINT-INDENTED-TREE.")

(defun print-indented-tree (trees &optional (indent 0))
  "Simple code to print out a list-structure tree (such as those created
   by make-caller-tree) as indented text."
  (when trees
    (dolist (tree trees)
      (cond ((and (listp tree) (eq (car tree) :xref-list))
	     (format t "~&~VT~A" indent (cdr tree)))
	    ((listp tree)
	     (format t "~&~VT~A" indent (car tree))
	     (print-indented-tree (cadr tree) (+ indent *indent-amount*)))
	    (t
	     (format t "~&~VT~A" indent tree))))))

(defun print-caller-trees (&key (mode *default-graphing-mode*)
				(types-to-ignore *types-to-ignore*)
				compact
				root-nodes)
  "Prints the calling trees (which may actually be a full graph and not
   necessarily a DAG) as indented text trees using PRINT-INDENTED-TREE.
   MODE is :call-graph for trees where the children of a node are the
   functions called by the node, or :caller-graph for trees where the
   children of a node are the functions the node calls. TYPES-TO-IGNORE
   is a list of funcall types (as specified in the patterns) to ignore
   in printing out the database. For example, '(:lisp) would ignore all
   calls to common lisp functions. COMPACT is a flag to tell the program
   to try to compact the trees a bit by not printing trees if they have
   already been seen. ROOT-NODES is a list of root nodes of trees to 
   display. If ROOT-NODES is nil, tries to find all root nodes in the
   database."
  (multiple-value-bind (rooted cycles)
      (if root-nodes
	  (values (gather-tree root-nodes nil mode types-to-ignore compact))
	  (make-caller-tree mode types-to-ignore compact))
    (when rooted
      (format t "~&Rooted calling trees:")
      (print-indented-tree rooted 2))
    (when cycles
      (when rooted      
	(format t "~2%"))
      (format t "~&Cyclic calling trees:")
      (print-indented-tree cycles 2))))


;;; ********************************
;;; Interface to PSGraph ***********
;;; ********************************
#|
;;; Interface to Bates' PostScript Graphing Utility
(load "/afs/cs/user/mkant/Lisp/PSGraph/psgraph")

(defparameter *postscript-output-directory* "")
(defun psgraph-xref (&key (mode *default-graphing-mode*)
			  (output-directory *postscript-output-directory*)
			  (types-to-ignore *types-to-ignore*)
			  (compact t)
			  (shrink t)
			  root-nodes
			  insert)
  ;; If root-nodes is a non-nil list, uses that list as the starting
  ;; position. Otherwise tries to find all roots in the database.
  (multiple-value-bind (rooted cycles)
      (if root-nodes
	  (values (gather-tree root-nodes nil mode types-to-ignore compact))
	  (make-caller-tree mode types-to-ignore compact))
    (psgraph-output (append rooted cycles) output-directory shrink insert)))

(defun psgraph-output (list-of-trees directory shrink &optional insert)
  (let ((psgraph:*fontsize* 9)
	(psgraph:*second-fontsize* 7)
;	(psgraph:*boxkind* "fill")
	(psgraph:*boxgray* "0") ; .8
	(psgraph:*edgewidth* "1")
	(psgraph:*edgegray* "0"))
    (labels ((stringify (thing)
		(cond ((stringp thing) (string-downcase thing))
		      ((symbolp thing) (string-downcase (symbol-name thing)))
		      ((and (listp thing) (eq (car thing) :xref-list))
		       (stringify (cdr thing)))
		      ((listp thing) (stringify (car thing)))
		      (t (string thing)))))
      (dolist (item list-of-trees)
	(let* ((fname (stringify item))
	       (filename (concatenate 'string directory
				      (string-trim '(#\: #\|) fname)
				      ".ps")))
	  (format t "~&Creating PostScript file ~S." filename)
	  (with-open-file (*standard-output* filename
					     :direction :output
					     :if-does-not-exist :create
					     :if-exists :supersede)
	    ;; Note that the #'eq prints the DAG as a tree. If
	    ;; you replace it with #'equal, it will print it as
	    ;; a DAG, which I think is slightly ugly.
	    (psgraph:psgraph item
			     #'caller-tree-children #'caller-info shrink
			     insert #'eq)))))))

(defun caller-tree-children (tree)
  (when (and tree (listp tree) (not (eq (car tree) :xref-list)))
    (cadr tree)))

(defun caller-tree-node (tree)
  (when tree
    (cond ((and (listp tree) (eq (car tree) :xref-list))
	   (cdr tree))
	  ((listp tree)
	   (car tree))
	  (t
	   tree))))

(defun caller-info (tree)
  (let ((node (caller-tree-node tree)))
    (list node)))
|#
#|
;;; Code to print out graphical trees of CLOS class hierarchies.
(defun print-class-hierarchy (&optional (start-class 'anything) 
					(file "classes.ps"))
  (let ((start (find-class start-class)))
    (when start
      (with-open-file (*standard-output* file :direction :output)
	(psgraph:psgraph start 
			 #'clos::class-direct-subclasses
			 #'(lambda (x) 
			     (list (format nil "~A" (clos::class-name x))))
			 t nil #'eq)))))

|#


;;; ****************************************************************
;;; Cross Referencing Patterns for Common Lisp *********************
;;; ****************************************************************
(clear-patterns)

;;; ********************************
;;; Pattern Substitutions **********
;;; ********************************
(define-pattern-substitution integer (:test #'integerp))
(define-pattern-substitution rational (:test #'rationalp))
(define-pattern-substitution symbol  (:test #'symbolp))
(define-pattern-substitution string  (:test #'stringp))
(define-pattern-substitution number  (:test #'numberp))
(define-pattern-substitution lambda-list
  ((:star var)
   (:optional (:eq &optional)
	      (:star (:or var
			  (var (:optional form (:optional var))))))
   (:optional (:eq &rest) var)
   (:optional (:eq &key) (:star (:or var
			       ((:or var
				     (keyword var))
				(:optional form (:optional var)))))
	      (:optional &allow-other-keys))
   (:optional (:eq &aux)
	      (:star (:or var
			  (var (:optional form)))))))
(define-pattern-substitution test form)
(define-pattern-substitution body
  ((:star (:or declaration documentation-string))
   (:star form)))
(define-pattern-substitution documentation-string string)
(define-pattern-substitution initial-value form)
(define-pattern-substitution tag symbol)
(define-pattern-substitution declaration ((:eq declare)(:rest :ignore)))
(define-pattern-substitution destination form)
(define-pattern-substitution control-string string)
(define-pattern-substitution format-arguments 
  ((:star form)))
(define-pattern-substitution fn
  (:or ((:eq quote) function) 
       ((:eq function) function)
       function))

;;; ********************************
;;; Caller Patterns ****************
;;; ********************************

;;; Types Related
(define-caller-pattern coerce (form :ignore) :lisp)
(define-caller-pattern type-of (form) :lisp)
(define-caller-pattern upgraded-array-element-type (:ignore) :lisp2)
(define-caller-pattern upgraded-complex-part-type (:ignore) :lisp2)

;;; Lambdas and Definitions
(define-variable-pattern lambda-list-keywords :lisp)
(define-variable-pattern lambda-parameters-limit :lisp)
(define-caller-pattern lambda (lambda-list (:rest body)) :lisp)

(define-caller-pattern defun 
  (name lambda-list
	(:star (:or documentation-string declaration))
	(:star form))
  :lisp)

;;; perhaps this should use VAR, instead of NAME
(define-caller-pattern defvar 
  (var (:optional initial-value (:optional documentation-string)))
  :lisp)
(define-caller-pattern defparameter
  (var initial-value (:optional documentation-string))
  :lisp)
(define-caller-pattern defconstant
  (var initial-value (:optional documentation-string))
  :lisp)

(define-caller-pattern eval-when
  (:ignore				; the situations
   (:star form))
  :lisp)

;;; Logical Values
(define-variable-pattern nil :lisp)
(define-variable-pattern t :lisp)

;;; Predicates
(define-caller-pattern typep (form form) :lisp)
(define-caller-pattern subtypep (form form) :lisp)

(define-caller-pattern null (form) :lisp)
(define-caller-pattern symbolp (form) :lisp)
(define-caller-pattern atom (form) :lisp)
(define-caller-pattern consp (form) :lisp)
(define-caller-pattern listp (form) :lisp)
(define-caller-pattern numberp (form) :lisp)
(define-caller-pattern integerp (form) :lisp)
(define-caller-pattern rationalp (form) :lisp)
(define-caller-pattern floatp (form) :lisp)
(define-caller-pattern realp (form) :lisp2)
(define-caller-pattern complexp (form) :lisp)
(define-caller-pattern characterp (form) :lisp)
(define-caller-pattern stringp (form) :lisp)
(define-caller-pattern bit-vector-p (form) :lisp)
(define-caller-pattern vectorp (form) :lisp)
(define-caller-pattern simple-vector-p (form) :lisp)
(define-caller-pattern simple-string-p (form) :lisp)
(define-caller-pattern simple-bit-vector-p (form) :lisp)
(define-caller-pattern arrayp (form) :lisp)
(define-caller-pattern packagep (form) :lisp)
(define-caller-pattern functionp (form) :lisp)
(define-caller-pattern compiled-function-p (form) :lisp)
(define-caller-pattern commonp (form) :lisp)

;;; Equality Predicates
(define-caller-pattern eq (form form) :lisp)
(define-caller-pattern eql (form form) :lisp)
(define-caller-pattern equal (form form) :lisp)
(define-caller-pattern equalp (form form) :lisp)

;;; Logical Operators
(define-caller-pattern not (form) :lisp)
(define-caller-pattern or ((:star form)) :lisp)
(define-caller-pattern and ((:star form)) :lisp)

;;; Reference

;;; Quote is a problem. In Defmacro & friends, we'd like to actually
;;; look at the argument, 'cause it hides internal function calls
;;; of the defmacro. 
(define-caller-pattern quote (:ignore) :lisp)

(define-caller-pattern function ((:or fn form)) :lisp)
(define-caller-pattern symbol-value (form) :lisp)
(define-caller-pattern symbol-function (form) :lisp)
(define-caller-pattern fdefinition (form) :lisp2)
(define-caller-pattern boundp (form) :lisp)
(define-caller-pattern fboundp (form) :lisp)
(define-caller-pattern special-form-p (form) :lisp)

;;; Assignment
(define-caller-pattern setq ((:star var form)) :lisp)
(define-caller-pattern psetq ((:star var form)) :lisp)
(define-caller-pattern set (form form) :lisp)
(define-caller-pattern makunbound (form) :lisp)
(define-caller-pattern fmakunbound (form) :lisp)

;;; Generalized Variables
(define-caller-pattern setf ((:star form form)) :lisp)
(define-caller-pattern psetf ((:star form form)) :lisp)
(define-caller-pattern shiftf ((:plus form) form) :lisp)
(define-caller-pattern rotatef ((:star form)) :lisp)
(define-caller-pattern define-modify-macro 
  (name
   lambda-list
   fn
   (:optional documentation-string))
  :lisp)
(define-caller-pattern defsetf 
  (:or (name name (:optional documentation-string))
       (name lambda-list (var)
	(:star (:or declaration documentation-string))
	(:star form)))
  :lisp)
(define-caller-pattern define-setf-method
  (name lambda-list
   (:star (:or declaration documentation-string))
   (:star form))
  :lisp)
(define-caller-pattern get-setf-method (form) :lisp)
(define-caller-pattern get-setf-method-multiple-value (form) :lisp)


;;; Function invocation
(define-caller-pattern apply (fn form (:star form)) :lisp)
(define-caller-pattern funcall (fn (:star form)) :lisp)


;;; Simple sequencing
(define-caller-pattern progn ((:star form)) :lisp)
(define-caller-pattern prog1 (form (:star form)) :lisp)
(define-caller-pattern prog2 (form form (:star form)) :lisp)

;;; Variable bindings
(define-caller-pattern let
  (((:star (:or var (var &optional form))))
   (:star declaration)
   (:star form))
  :lisp)
(define-caller-pattern let*
  (((:star (:or var (var &optional form))))
    (:star declaration)
    (:star form))
  :lisp)
(define-caller-pattern compiler-let
  (((:star (:or var (var form))))
    (:star form))
  :lisp)
(define-caller-pattern progv
  (form form (:star form)) :lisp)
(define-caller-pattern flet
  (((:star (name lambda-list 
		 (:star (:or declaration
			     documentation-string))
		 (:star form))))
   (:star form))
  :lisp)
(define-caller-pattern labels
  (((:star (name lambda-list 
		 (:star (:or declaration
			     documentation-string))
		 (:star form))))
   (:star form))
  :lisp)
(define-caller-pattern macrolet
  (((:star (name lambda-list 
		 (:star (:or declaration
			     documentation-string))
		 (:star form))))
   (:star form))
  :lisp)
(define-caller-pattern symbol-macrolet
  (((:star (var form))) (:star declaration) (:star form))
  :lisp2)

;;; Conditionals
(define-caller-pattern if (test form (:optional form)) :lisp)
(define-caller-pattern when (test (:star form)) :lisp)
(define-caller-pattern unless (test (:star form)) :lisp)
(define-caller-pattern cond ((:star (test (:star form)))) :lisp)
(define-caller-pattern case
  (form
   (:star ((:or symbol
		((:star symbol)))
	   (:star form)))) 
  :lisp)
(define-caller-pattern typecase (form (:star (symbol (:star form)))) 
  :lisp)

;;; Blocks and Exits
(define-caller-pattern block (name (:star form)) :lisp)
(define-caller-pattern return-from (function (:optional form)) :lisp)
(define-caller-pattern return ((:optional form)) :lisp)

;;; Iteration
(define-caller-pattern loop ((:star form)) :lisp)
(define-caller-pattern do
  (((:star (:or var
		(var (:optional form (:optional form)))))) ; init step
   (form (:star form)) ; end-test result
   (:star declaration)
   (:star (:or tag form)))		; statement
  :lisp)
(define-caller-pattern do*
  (((:star (:or var
		(var (:optional form (:optional form)))))) 
   (form (:star form))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern dolist
  ((var form (:optional form))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern dotimes
  ((var form (:optional form))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)

;;; Mapping
(define-caller-pattern mapcar (fn form (:star form)) :lisp)
(define-caller-pattern maplist (fn form (:star form)) :lisp)
(define-caller-pattern mapc (fn form (:star form)) :lisp)
(define-caller-pattern mapl (fn form (:star form)) :lisp)
(define-caller-pattern mapcan (fn form (:star form)) :lisp)
(define-caller-pattern mapcon (fn form (:star form)) :lisp)

;;; The "Program Feature"
(define-caller-pattern tagbody ((:star (:or tag form))) :lisp)
(define-caller-pattern prog
  (((:star (:or var (var (:optional form)))))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern prog*    
  (((:star (:or var (var (:optional form)))))
   (:star declaration)
   (:star (:or tag form)))
  :lisp)
(define-caller-pattern go (tag) :lisp)

;;; Multiple Values
(define-caller-pattern values ((:star form)) :lisp)
(define-variable-pattern multiple-values-limit :lisp)
(define-caller-pattern values-list (form) :lisp)
(define-caller-pattern multiple-value-list (form) :lisp)
(define-caller-pattern multiple-value-call (fn (:star form)) :lisp)
(define-caller-pattern multiple-value-prog1 (form (:star form)) :lisp)
(define-caller-pattern multiple-value-bind
  (((:star var)) form
   (:star declaration)
   (:star form))
  :lisp)
(define-caller-pattern multiple-value-setq (((:star var)) form) :lisp)
(define-caller-pattern nth-value (form form) :lisp2)

;;; Dynamic Non-Local Exits
(define-caller-pattern catch (tag (:star form)) :lisp)
(define-caller-pattern throw (tag form) :lisp)
(define-caller-pattern unwind-protect (form (:star form)) :lisp)

;;; Macros
(define-caller-pattern macro-function (form) :lisp)
(define-caller-pattern defmacro
  (name
   lambda-list
   (:star (:or declaration documentation-string))
   (:star form))
  :lisp)
(define-caller-pattern macroexpand (form (:optional :ignore)) :lisp)
(define-caller-pattern macroexpand-1 (form (:optional :ignore)) :lisp)
(define-variable-pattern *macroexpand-hook* :lisp)

;;; Destructuring
(define-caller-pattern destructuring-bind 
  (lambda-list form
	       (:star declaration)
	       (:star form))
  :lisp2)

;;; Compiler Macros
(define-caller-pattern define-compiler-macro
  (name lambda-list
	(:star (:or declaration documentation-string))
	(:star form))
  :lisp2)
(define-caller-pattern compiler-macro-function (form) :lisp2)
(define-caller-pattern compiler-macroexpand (form (:optional :ignore)) :lisp2)
(define-caller-pattern compiler-macroexpand-1 (form (:optional :ignore)) :lisp2)

;;; Environments
(define-caller-pattern variable-information (form &optional :ignore) 
  :lisp2)
(define-caller-pattern function-information (fn &optional :ignore) :lisp2)
(define-caller-pattern declaration-information (form &optional :ignore) :lisp2)
(define-caller-pattern augment-environment (form &key (:star :ignore)) :lisp2)
(define-caller-pattern define-declaration 
  (name
   lambda-list
   (:star form)) 
  :lisp2)
(define-caller-pattern parse-macro (name lambda-list form) :lisp2)
(define-caller-pattern enclose (form &optional :ignore) :lisp2)


;;; Declarations
(define-caller-pattern declare ((:rest :ignore)) :lisp)
(define-caller-pattern proclaim ((:rest :ignore)) :lisp)
(define-caller-pattern locally ((:star declaration) (:star form)) :lisp)
(define-caller-pattern declaim ((:rest :ignore)) :lisp2)
(define-caller-pattern the (form form) :lisp)

;;; Symbols
(define-caller-pattern get (form form (:optional form)) :lisp)
(define-caller-pattern remprop (form form) :lisp)
(define-caller-pattern symbol-plist (form) :lisp)
(define-caller-pattern getf (form form (:optional form)) :lisp)
(define-caller-pattern remf (form form) :lisp)
(define-caller-pattern get-properties (form form) :lisp)

(define-caller-pattern symbol-name (form) :lisp)
(define-caller-pattern make-symbol (form) :lisp)
(define-caller-pattern copy-symbol (form (:optional :ignore)) :lisp)
(define-caller-pattern gensym ((:optional :ignore)) :lisp)
(define-variable-pattern *gensym-counter* :lisp2)
(define-caller-pattern gentemp ((:optional :ignore :ignore)) :lisp)
(define-caller-pattern symbol-package (form) :lisp)
(define-caller-pattern keywordp (form) :lisp)

;;; Packages
(define-variable-pattern *package* :lisp)
(define-caller-pattern make-package ((:rest :ignore)) :lisp)
(define-caller-pattern in-package ((:rest :ignore)) :lisp)
(define-caller-pattern find-package ((:rest :ignore)) :lisp)
(define-caller-pattern package-name ((:rest :ignore)) :lisp)
(define-caller-pattern package-nicknames ((:rest :ignore)) :lisp)
(define-caller-pattern rename-package ((:rest :ignore)) :lisp)
(define-caller-pattern package-use-list ((:rest :ignore)) :lisp)
(define-caller-pattern package-used-by-list ((:rest :ignore)) :lisp)
(define-caller-pattern package-shadowing-symbols ((:rest :ignore)) :lisp)
(define-caller-pattern list-all-packages () :lisp)
(define-caller-pattern delete-package ((:rest :ignore)) :lisp2)
(define-caller-pattern intern (form &optional :ignore) :lisp)
(define-caller-pattern find-symbol (form &optional :ignore) :lisp)
(define-caller-pattern unintern (form &optional :ignore) :lisp)

(define-caller-pattern export ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern unexport ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern import ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern shadowing-import ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)
(define-caller-pattern shadow ((:or symbol ((:star symbol)))
			       &optional :ignore) :lisp)

(define-caller-pattern use-package ((:rest :ignore)) :lisp)
(define-caller-pattern unuse-package ((:rest :ignore)) :lisp)
(define-caller-pattern defpackage (name (:rest :ignore)) :lisp2)
(define-caller-pattern find-all-symbols (form) :lisp)
(define-caller-pattern do-symbols 
  ((var (:optional form (:optional form)))
   (:star declaration) 
   (:star (:or tag form))) 
  :lisp)
(define-caller-pattern do-external-symbols 
  ((var (:optional form (:optional form)))
   (:star declaration) 
   (:star (:or tag form))) 
  :lisp)
(define-caller-pattern do-all-symbols 
  ((var (:optional form))
   (:star declaration) 
   (:star (:or tag form))) 
  :lisp)
(define-caller-pattern with-package-iterator
  ((name form (:plus :ignore))
   (:star form))
  :lisp2)

;;; Modules
(define-variable-pattern *modules* :lisp)
(define-caller-pattern provide (form) :lisp)
(define-caller-pattern require (form &optional :ignore) :lisp)


;;; Numbers
(define-caller-pattern zerop (form) :lisp)
(define-caller-pattern plusp (form) :lisp)
(define-caller-pattern minusp (form) :lisp)
(define-caller-pattern oddp (form) :lisp)
(define-caller-pattern evenp (form) :lisp)

(define-caller-pattern = (form (:star form)) :lisp)
(define-caller-pattern /= (form (:star form)) :lisp)
(define-caller-pattern > (form (:star form)) :lisp)
(define-caller-pattern < (form (:star form)) :lisp)
(define-caller-pattern <= (form (:star form)) :lisp)
(define-caller-pattern >= (form (:star form)) :lisp)

(define-caller-pattern max (form (:star form)) :lisp)
(define-caller-pattern min (form (:star form)) :lisp)

(define-caller-pattern - (form (:star form)) :lisp)
(define-caller-pattern + (form (:star form)) :lisp)
(define-caller-pattern * (form (:star form)) :lisp)
(define-caller-pattern / (form (:star form)) :lisp)
(define-caller-pattern 1+ (form) :lisp)
(define-caller-pattern 1- (form) :lisp)

(define-caller-pattern incf (form form) :lisp)
(define-caller-pattern decf (form form) :lisp)

(define-caller-pattern conjugate (form) :lisp)

(define-caller-pattern gcd ((:star form)) :lisp)
(define-caller-pattern lcm ((:star form)) :lisp)

(define-caller-pattern exp (form) :lisp)
(define-caller-pattern expt (form form) :lisp)
(define-caller-pattern log (form (:optional form)) :lisp)
(define-caller-pattern sqrt (form) :lisp)
(define-caller-pattern isqrt (form) :lisp)

(define-caller-pattern abs (form) :lisp)
(define-caller-pattern phase (form) :lisp)
(define-caller-pattern signum (form) :lisp)
(define-caller-pattern sin (form) :lisp)
(define-caller-pattern cos (form) :lisp)
(define-caller-pattern tan (form) :lisp)
(define-caller-pattern cis (form) :lisp)
(define-caller-pattern asin (form) :lisp)
(define-caller-pattern acos (form) :lisp)
(define-caller-pattern atan (form &optional form) :lisp)
(define-variable-pattern pi :lisp)

(define-caller-pattern sinh (form) :lisp)
(define-caller-pattern cosh (form) :lisp)
(define-caller-pattern tanh (form) :lisp)
(define-caller-pattern asinh (form) :lisp)
(define-caller-pattern acosh (form) :lisp)
(define-caller-pattern atanh (form) :lisp)

;;; Type Conversions and Extractions
(define-caller-pattern float (form (:optional form)) :lisp)
(define-caller-pattern rational (form) :lisp)
(define-caller-pattern rationalize (form) :lisp)
(define-caller-pattern numerator (form) :lisp)
(define-caller-pattern denominator (form) :lisp)

(define-caller-pattern floor (form (:optional form)) :lisp)
(define-caller-pattern ceiling (form (:optional form)) :lisp)
(define-caller-pattern truncate (form (:optional form)) :lisp)
(define-caller-pattern round (form (:optional form)) :lisp)

(define-caller-pattern mod (form form) :lisp)
(define-caller-pattern rem (form form) :lisp)

(define-caller-pattern ffloor (form (:optional form)) :lisp)
(define-caller-pattern fceiling (form (:optional form)) :lisp)
(define-caller-pattern ftruncate (form (:optional form)) :lisp)
(define-caller-pattern fround (form (:optional form)) :lisp)

(define-caller-pattern decode-float (form) :lisp)
(define-caller-pattern scale-float (form form) :lisp)
(define-caller-pattern float-radix (form) :lisp)
(define-caller-pattern float-sign (form (:optional form)) :lisp)
(define-caller-pattern float-digits (form) :lisp)
(define-caller-pattern float-precision (form) :lisp)
(define-caller-pattern integer-decode-float (form) :lisp)

(define-caller-pattern complex (form (:optional form)) :lisp)
(define-caller-pattern realpart (form) :lisp)
(define-caller-pattern imagpart (form) :lisp)

(define-caller-pattern logior ((:star form)) :lisp)
(define-caller-pattern logxor ((:star form)) :lisp)
(define-caller-pattern logand ((:star form)) :lisp)
(define-caller-pattern logeqv ((:star form)) :lisp)

(define-caller-pattern lognand (form form) :lisp)
(define-caller-pattern lognor (form form) :lisp)
(define-caller-pattern logandc1 (form form) :lisp)
(define-caller-pattern logandc2 (form form) :lisp)
(define-caller-pattern logorc1 (form form) :lisp)
(define-caller-pattern logorc2 (form form) :lisp)

(define-caller-pattern boole (form form form) :lisp)
(define-variable-pattern boole-clr :lisp)
(define-variable-pattern boole-set :lisp)
(define-variable-pattern boole-1 :lisp)
(define-variable-pattern boole-2 :lisp)
(define-variable-pattern boole-c1 :lisp)
(define-variable-pattern boole-c2 :lisp)
(define-variable-pattern boole-and :lisp)
(define-variable-pattern boole-ior :lisp)
(define-variable-pattern boole-xor :lisp)
(define-variable-pattern boole-eqv :lisp)
(define-variable-pattern boole-nand :lisp)
(define-variable-pattern boole-nor :lisp)
(define-variable-pattern boole-andc1 :lisp)
(define-variable-pattern boole-andc2 :lisp)
(define-variable-pattern boole-orc1 :lisp)
(define-variable-pattern boole-orc2 :lisp)

(define-caller-pattern lognot (form) :lisp)
(define-caller-pattern logtest (form form) :lisp)
(define-caller-pattern logbitp (form form) :lisp)
(define-caller-pattern ash (form form) :lisp)
(define-caller-pattern logcount (form) :lisp)
(define-caller-pattern integer-length (form) :lisp)

(define-caller-pattern byte (form form) :lisp)
(define-caller-pattern byte-size (form) :lisp)
(define-caller-pattern byte-position (form) :lisp)
(define-caller-pattern ldb (form form) :lisp)
(define-caller-pattern ldb-test (form form) :lisp)
(define-caller-pattern mask-field (form form) :lisp)
(define-caller-pattern dpb (form form form) :lisp)
(define-caller-pattern deposit-field (form form form) :lisp)

;;; Random Numbers
(define-caller-pattern random (form (:optional form)) :lisp)
(define-variable-pattern *random-state* :lisp)
(define-caller-pattern make-random-state ((:optional form)) :lisp)
(define-caller-pattern random-state-p (form) :lisp)

;;; Implementation Parameters
(define-variable-pattern most-positive-fixnum :lisp)
(define-variable-pattern most-negative-fixnum :lisp)
(define-variable-pattern most-positive-short-float :lisp)
(define-variable-pattern least-positive-short-float :lisp)
(define-variable-pattern least-negative-short-float :lisp)
(define-variable-pattern most-negative-short-float :lisp)
(define-variable-pattern most-positive-single-float :lisp)
(define-variable-pattern least-positive-single-float :lisp)
(define-variable-pattern least-negative-single-float :lisp)
(define-variable-pattern most-negative-single-float :lisp)
(define-variable-pattern most-positive-double-float :lisp)
(define-variable-pattern least-positive-double-float :lisp)
(define-variable-pattern least-negative-double-float :lisp)
(define-variable-pattern most-negative-double-float :lisp)
(define-variable-pattern most-positive-long-float :lisp)
(define-variable-pattern least-positive-long-float :lisp)
(define-variable-pattern least-negative-long-float :lisp)
(define-variable-pattern most-negative-long-float :lisp)
(define-variable-pattern least-positive-normalized-short-float :lisp2)
(define-variable-pattern least-negative-normalized-short-float :lisp2)
(define-variable-pattern least-positive-normalized-single-float :lisp2)
(define-variable-pattern least-negative-normalized-single-float :lisp2)
(define-variable-pattern least-positive-normalized-double-float :lisp2)
(define-variable-pattern least-negative-normalized-double-float :lisp2)
(define-variable-pattern least-positive-normalized-long-float :lisp2)
(define-variable-pattern least-negative-normalized-long-float :lisp2)
(define-variable-pattern short-float-epsilon :lisp)
(define-variable-pattern single-float-epsilon :lisp)
(define-variable-pattern double-float-epsilon :lisp)
(define-variable-pattern long-float-epsilon :lisp)
(define-variable-pattern short-float-negative-epsilon :lisp)
(define-variable-pattern single-float-negative-epsilon :lisp)
(define-variable-pattern double-float-negative-epsilon :lisp)
(define-variable-pattern long-float-negative-epsilon :lisp)

;;; Characters 
(define-variable-pattern char-code-limit :lisp)
(define-variable-pattern char-font-limit :lisp)
(define-variable-pattern char-bits-limit :lisp)
(define-caller-pattern standard-char-p (form) :lisp)
(define-caller-pattern graphic-char-p (form) :lisp)
(define-caller-pattern string-char-p (form) :lisp)
(define-caller-pattern alpha-char-p (form) :lisp)
(define-caller-pattern upper-case-p (form) :lisp)
(define-caller-pattern lower-case-p (form) :lisp)
(define-caller-pattern both-case-p (form) :lisp)
(define-caller-pattern digit-char-p (form (:optional form)) :lisp)
(define-caller-pattern alphanumericp (form) :lisp)

(define-caller-pattern char= ((:star form)) :lisp)
(define-caller-pattern char/= ((:star form)) :lisp)
(define-caller-pattern char< ((:star form)) :lisp)
(define-caller-pattern char> ((:star form)) :lisp)
(define-caller-pattern char<= ((:star form)) :lisp)
(define-caller-pattern char>= ((:star form)) :lisp)

(define-caller-pattern char-equal ((:star form)) :lisp)
(define-caller-pattern char-not-equal ((:star form)) :lisp)
(define-caller-pattern char-lessp ((:star form)) :lisp)
(define-caller-pattern char-greaterp ((:star form)) :lisp)
(define-caller-pattern char-not-greaterp ((:star form)) :lisp)
(define-caller-pattern char-not-lessp ((:star form)) :lisp)

(define-caller-pattern char-code (form) :lisp)
(define-caller-pattern char-bits (form) :lisp)
(define-caller-pattern char-font (form) :lisp)
(define-caller-pattern code-char (form (:optional form form)) :lisp)
(define-caller-pattern make-char (form (:optional form form)) :lisp)
(define-caller-pattern characterp (form) :lisp)
(define-caller-pattern char-upcase (form) :lisp)
(define-caller-pattern char-downcase (form) :lisp)
(define-caller-pattern digit-char (form (:optional form form)) :lisp)
(define-caller-pattern char-int (form) :lisp)
(define-caller-pattern int-char (form) :lisp)
(define-caller-pattern char-name (form) :lisp)
(define-caller-pattern name-char (form) :lisp)
(define-variable-pattern char-control-bit :lisp)
(define-variable-pattern char-meta-bit :lisp)
(define-variable-pattern char-super-bit :lisp)
(define-variable-pattern char-hyper-bit :lisp)
(define-caller-pattern char-bit (form form) :lisp)
(define-caller-pattern set-char-bit (form form form) :lisp)

;;; Sequences
(define-caller-pattern complement (fn) :lisp2)
(define-caller-pattern elt (form form) :lisp)
(define-caller-pattern subseq (form form &optional form) :lisp)
(define-caller-pattern copy-seq (form) :lisp)
(define-caller-pattern length (form) :lisp)
(define-caller-pattern reverse (form) :lisp)
(define-caller-pattern nreverse (form) :lisp)
(define-caller-pattern make-sequence (form form &key form) :lisp)

(define-caller-pattern concatenate (form (:star form)) :lisp)
(define-caller-pattern map (form fn form (:star form)) :lisp)
(define-caller-pattern map-into (form fn (:star form)) :lisp2)

(define-caller-pattern some (fn form (:star form)) :lisp)
(define-caller-pattern every (fn form (:star form)) :lisp)
(define-caller-pattern notany (fn form (:star form)) :lisp)
(define-caller-pattern notevery (fn form (:star form)) :lisp)

(define-caller-pattern reduce (fn form &key (:star form)) :lisp)
(define-caller-pattern fill (form form &key (:star form)) :lisp)
(define-caller-pattern replace (form form &key (:star form)) :lisp)
(define-caller-pattern remove (form form &key (:star form)) :lisp)
(define-caller-pattern remove-if (fn form &key (:star form)) :lisp)
(define-caller-pattern remove-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern delete (form form &key (:star form)) :lisp)
(define-caller-pattern delete-if (fn form &key (:star form)) :lisp)
(define-caller-pattern delete-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern remove-duplicates (form &key (:star form)) :lisp)
(define-caller-pattern delete-duplicates (form &key (:star form)) :lisp)
(define-caller-pattern substitute (form form form &key (:star form)) :lisp)
(define-caller-pattern substitute-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern substitute-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubstitute (form form form &key (:star form)) :lisp)
(define-caller-pattern nsubstitute-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubstitute-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern find (form form &key (:star form)) :lisp)
(define-caller-pattern find-if (fn form &key (:star form)) :lisp)
(define-caller-pattern find-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern position (form form &key (:star form)) :lisp)
(define-caller-pattern position-if (fn form &key (:star form)) :lisp)
(define-caller-pattern position-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern count (form form &key (:star form)) :lisp)
(define-caller-pattern count-if (fn form &key (:star form)) :lisp)
(define-caller-pattern count-if-not (fn form &key (:star form)) :lisp)
(define-caller-pattern mismatch (form form &key (:star form)) :lisp)
(define-caller-pattern search (form form &key (:star form)) :lisp)
(define-caller-pattern sort (form fn &key (:star form)) :lisp)
(define-caller-pattern stable-sort (form fn &key (:star form)) :lisp)
(define-caller-pattern merge (form form form fn &key (:star form)) :lisp)

;;; Lists
(define-caller-pattern car (form) :lisp)
(define-caller-pattern cdr (form) :lisp)
(define-caller-pattern caar (form) :lisp)
(define-caller-pattern cadr (form) :lisp)
(define-caller-pattern cdar (form) :lisp)
(define-caller-pattern cddr (form) :lisp)
(define-caller-pattern caaar (form) :lisp)
(define-caller-pattern caadr (form) :lisp)
(define-caller-pattern cadar (form) :lisp)
(define-caller-pattern caddr (form) :lisp)
(define-caller-pattern cdaar (form) :lisp)
(define-caller-pattern cdadr (form) :lisp)
(define-caller-pattern cddar (form) :lisp)
(define-caller-pattern cdddr (form) :lisp)
(define-caller-pattern caaaar (form) :lisp)
(define-caller-pattern caaadr (form) :lisp)
(define-caller-pattern caadar (form) :lisp)
(define-caller-pattern caaddr (form) :lisp)
(define-caller-pattern cadaar (form) :lisp)
(define-caller-pattern cadadr (form) :lisp)
(define-caller-pattern caddar (form) :lisp)
(define-caller-pattern cadddr (form) :lisp)
(define-caller-pattern cdaaar (form) :lisp)
(define-caller-pattern cdaadr (form) :lisp)
(define-caller-pattern cdadar (form) :lisp)
(define-caller-pattern cdaddr (form) :lisp)
(define-caller-pattern cddaar (form) :lisp)
(define-caller-pattern cddadr (form) :lisp)
(define-caller-pattern cdddar (form) :lisp)
(define-caller-pattern cddddr (form) :lisp)

(define-caller-pattern cons (form form) :lisp)
(define-caller-pattern tree-equal (form form &key (:star fn)) :lisp)
(define-caller-pattern endp (form) :lisp)
(define-caller-pattern list-length (form) :lisp)
(define-caller-pattern nth (form form) :lisp)

(define-caller-pattern first (form) :lisp)
(define-caller-pattern second (form) :lisp)
(define-caller-pattern third (form) :lisp)
(define-caller-pattern fourth (form) :lisp)
(define-caller-pattern fifth (form) :lisp)
(define-caller-pattern sixth (form) :lisp)
(define-caller-pattern seventh (form) :lisp)
(define-caller-pattern eighth (form) :lisp)
(define-caller-pattern ninth (form) :lisp)
(define-caller-pattern tenth (form) :lisp)

(define-caller-pattern rest (form) :lisp)
(define-caller-pattern nthcdr (form form) :lisp)
(define-caller-pattern last (form (:optional form)) :lisp)
(define-caller-pattern list ((:star form)) :lisp)
(define-caller-pattern list* ((:star form)) :lisp)
(define-caller-pattern make-list (form &key (:star form)) :lisp)
(define-caller-pattern append ((:star form)) :lisp)
(define-caller-pattern copy-list (form) :lisp)
(define-caller-pattern copy-alist (form) :lisp)
(define-caller-pattern copy-tree (form) :lisp)
(define-caller-pattern revappend (form form) :lisp)
(define-caller-pattern nconc ((:star form)) :lisp)
(define-caller-pattern nreconc (form form) :lisp)
(define-caller-pattern push (form form) :lisp)
(define-caller-pattern pushnew (form form &key (:star form)) :lisp)
(define-caller-pattern pop (form) :lisp)
(define-caller-pattern butlast (form (:optional form)) :lisp)
(define-caller-pattern nbutlast (form (:optional form)) :lisp)
(define-caller-pattern ldiff (form form) :lisp)
(define-caller-pattern rplaca (form form) :lisp)
(define-caller-pattern rplacd (form form) :lisp)

(define-caller-pattern subst (form form form &key (:star form)) :lisp)
(define-caller-pattern subst-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern subst-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubst (form form form &key (:star form)) :lisp)
(define-caller-pattern nsubst-if (form fn form &key (:star form)) :lisp)
(define-caller-pattern nsubst-if-not (form fn form &key (:star form)) :lisp)
(define-caller-pattern sublis (form form &key (:star form)) :lisp)
(define-caller-pattern nsublis (form form &key (:star form)) :lisp)
(define-caller-pattern member (form form &key (:star form)) :lisp)
(define-caller-pattern member-if (fn form &key (:star form)) :lisp)
(define-caller-pattern member-if-not (fn form &key (:star form)) :lisp)

(define-caller-pattern tailp (form form) :lisp)
(define-caller-pattern adjoin (form form &key (:star form)) :lisp)
(define-caller-pattern union (form form &key (:star form)) :lisp)
(define-caller-pattern nunion (form form &key (:star form)) :lisp)
(define-caller-pattern intersection (form form &key (:star form)) :lisp)
(define-caller-pattern nintersection (form form &key (:star form)) :lisp)
(define-caller-pattern set-difference (form form &key (:star form)) :lisp)
(define-caller-pattern nset-difference (form form &key (:star form)) :lisp)
(define-caller-pattern set-exclusive-or (form form &key (:star form)) :lisp)
(define-caller-pattern nset-exclusive-or (form form &key (:star form)) :lisp)
(define-caller-pattern subsetp (form form &key (:star form)) :lisp)

(define-caller-pattern acons (form form form) :lisp)
(define-caller-pattern pairlis (form form (:optional form)) :lisp)
(define-caller-pattern assoc (form form &key (:star form)) :lisp)
(define-caller-pattern assoc-if (fn form) :lisp)
(define-caller-pattern assoc-if-not (fn form) :lisp)
(define-caller-pattern rassoc (form form &key (:star form)) :lisp)
(define-caller-pattern rassoc-if (fn form &key (:star form)) :lisp)
(define-caller-pattern rassoc-if-not (fn form &key (:star form)) :lisp)

;;; Hash Tables
(define-caller-pattern make-hash-table (&key (:star form)) :lisp)
(define-caller-pattern hash-table-p (form) :lisp)
(define-caller-pattern gethash (form form (:optional form)) :lisp)
(define-caller-pattern remhash (form form) :lisp)
(define-caller-pattern maphash (fn form) :lisp)
(define-caller-pattern clrhash (form) :lisp)
(define-caller-pattern hash-table-count (form) :lisp)
(define-caller-pattern with-hash-table-iterator
  ((name form) (:star form)) :lisp2)
(define-caller-pattern hash-table-rehash-size (form) :lisp2)
(define-caller-pattern hash-table-rehash-threshold (form) :lisp2)
(define-caller-pattern hash-table-size (form) :lisp2)
(define-caller-pattern hash-table-test (form) :lisp2)
(define-caller-pattern sxhash (form) :lisp)

;;; Arrays
(define-caller-pattern make-array (form &key (:star form)) :lisp)
(define-variable-pattern array-rank-limit :lisp)
(define-variable-pattern array-dimension-limit :lisp)
(define-variable-pattern array-total-size-limit :lisp)
(define-caller-pattern vector ((:star form)) :lisp)
(define-caller-pattern aref (form (:star form)) :lisp)
(define-caller-pattern svref (form form) :lisp)
(define-caller-pattern array-element-type (form) :lisp)
(define-caller-pattern array-rank (form) :lisp)
(define-caller-pattern array-dimension (form form) :lisp)
(define-caller-pattern array-dimensions (form) :lisp)
(define-caller-pattern array-total-size (form) :lisp)
(define-caller-pattern array-in-bounds-p (form (:star form)) :lisp)
(define-caller-pattern array-row-major-index (form (:star form)) :lisp)
(define-caller-pattern row-major-aref (form form) :lisp2)
(define-caller-pattern adjustable-array-p (form) :lisp)

(define-caller-pattern bit (form (:star form)) :lisp)
(define-caller-pattern sbit (form (:star form)) :lisp)

(define-caller-pattern bit-and (form form (:optional form)) :lisp)
(define-caller-pattern bit-ior (form form (:optional form)) :lisp)
(define-caller-pattern bit-xor (form form (:optional form)) :lisp)
(define-caller-pattern bit-eqv (form form (:optional form)) :lisp)
(define-caller-pattern bit-nand (form form (:optional form)) :lisp)
(define-caller-pattern bit-nor (form form (:optional form)) :lisp)
(define-caller-pattern bit-andc1 (form form (:optional form)) :lisp)
(define-caller-pattern bit-andc2 (form form (:optional form)) :lisp)
(define-caller-pattern bit-orc1 (form form (:optional form)) :lisp)
(define-caller-pattern bit-orc2 (form form (:optional form)) :lisp)
(define-caller-pattern bit-not (form (:optional form)) :lisp)

(define-caller-pattern array-has-fill-pointer-p (form) :lisp)
(define-caller-pattern fill-pointer (form) :lisp)
(define-caller-pattern vector-push (form form) :lisp)
(define-caller-pattern vector-push-extend (form form (:optional form)) :lisp)
(define-caller-pattern vector-pop (form) :lisp)
(define-caller-pattern adjust-array (form form &key (:star form)) :lisp)

;;; Strings
(define-caller-pattern char (form form) :lisp)
(define-caller-pattern schar (form form) :lisp)
(define-caller-pattern string= (form form &key (:star form)) :lisp)
(define-caller-pattern string-equal (form form &key (:star form)) :lisp)
(define-caller-pattern string< (form form &key (:star form)) :lisp)
(define-caller-pattern string> (form form &key (:star form)) :lisp)
(define-caller-pattern string<= (form form &key (:star form)) :lisp)
(define-caller-pattern string>= (form form &key (:star form)) :lisp)
(define-caller-pattern string/= (form form &key (:star form)) :lisp)
(define-caller-pattern string-lessp (form form &key (:star form)) :lisp)
(define-caller-pattern string-greaterp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-greaterp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-lessp (form form &key (:star form)) :lisp)
(define-caller-pattern string-not-equal (form form &key (:star form)) :lisp)

(define-caller-pattern make-string (form &key (:star form)) :lisp)
(define-caller-pattern string-trim (form form) :lisp)
(define-caller-pattern string-left-trim (form form) :lisp)
(define-caller-pattern string-right-trim (form form) :lisp)
(define-caller-pattern string-upcase (form &key (:star form)) :lisp)
(define-caller-pattern string-downcase (form &key (:star form)) :lisp)
(define-caller-pattern string-capitalize (form &key (:star form)) :lisp)
(define-caller-pattern nstring-upcase (form &key (:star form)) :lisp)
(define-caller-pattern nstring-downcase (form &key (:star form)) :lisp)
(define-caller-pattern nstring-capitalize (form &key (:star form)) :lisp)
(define-caller-pattern string (form) :lisp)

;;; Structures
(define-caller-pattern defstruct 
  ((:or name (name (:rest :ignore)))
   (:optional documentation-string)
   (:plus :ignore))
  :lisp)

;;; The Evaluator
(define-caller-pattern eval (form) :lisp)
(define-variable-pattern *evalhook* :lisp)
(define-variable-pattern *applyhook* :lisp)
(define-caller-pattern evalhook (form fn fn &optional :ignore) :lisp)
(define-caller-pattern applyhook (fn form fn fn &optional :ignore) :lisp)
(define-caller-pattern constantp (form) :lisp)

;;; Streams
(define-variable-pattern *standard-input* :lisp)
(define-variable-pattern *standard-output* :lisp)
(define-variable-pattern *error-output* :lisp)
(define-variable-pattern *query-io* :lisp)
(define-variable-pattern *debug-io* :lisp)
(define-variable-pattern *terminal-io* :lisp)
(define-variable-pattern *trace-output* :lisp)
(define-caller-pattern make-synonym-stream (symbol) :lisp)
(define-caller-pattern make-broadcast-stream ((:star form)) :lisp)
(define-caller-pattern make-concatenated-stream ((:star form)) :lisp)
(define-caller-pattern make-two-way-stream (form form) :lisp)
(define-caller-pattern make-echo-stream (form form) :lisp)
(define-caller-pattern make-string-input-stream (form &optional form form) :lisp) 
(define-caller-pattern make-string-output-stream (&key (:star form)) :lisp)
(define-caller-pattern get-output-stream-string (form) :lisp)

(define-caller-pattern with-open-stream
  ((var form)
   (:star declaration)
   (:star form))
  :lisp)

(define-caller-pattern with-input-from-string
  ((var form &key (:star form))
   (:star declaration)
   (:star form))
  :lisp)

(define-caller-pattern with-output-to-string
  ((var (:optional form))
   (:star declaration)
   (:star form))
  :lisp)
(define-caller-pattern streamp (form) :lisp)
(define-caller-pattern open-stream-p (form) :lisp2)
(define-caller-pattern input-stream-p (form) :lisp)
(define-caller-pattern output-stream-p (form) :lisp)
(define-caller-pattern stream-element-type (form) :lisp)
(define-caller-pattern close (form (:rest :ignore)) :lisp)
(define-caller-pattern broadcast-stream-streams (form) :lisp2)
(define-caller-pattern concatenated-stream-streams (form) :lisp2)
(define-caller-pattern echo-stream-input-stream (form) :lisp2)
(define-caller-pattern echo-stream-output-stream (form) :lisp2)
(define-caller-pattern synonym-stream-symbol (form) :lisp2)
(define-caller-pattern two-way-stream-input-stream (form) :lisp2)
(define-caller-pattern two-way-stream-output-stream (form) :lisp2)
(define-caller-pattern interactive-stream-p (form) :lisp2)
(define-caller-pattern stream-external-format (form) :lisp2)

;;; Reader
(define-variable-pattern *read-base* :lisp)
(define-variable-pattern *read-suppress* :lisp)
(define-variable-pattern *read-eval* :lisp2)
(define-variable-pattern *readtable* :lisp)
(define-caller-pattern copy-readtable (&optional form form) :lisp)
(define-caller-pattern readtablep (form) :lisp)
(define-caller-pattern set-syntax-from-char (form form &optional form form) :lisp)
(define-caller-pattern set-macro-character (form fn &optional form) :lisp)
(define-caller-pattern get-macro-character (form (:optional form)) :lisp)
(define-caller-pattern make-dispatch-macro-character (form &optional form form)
  :lisp)
(define-caller-pattern set-dispatch-macro-character
  (form form fn (:optional form)) :lisp)
(define-caller-pattern get-dispatch-macro-character
  (form form (:optional form)) :lisp)
(define-caller-pattern readtable-case (form) :lisp2)
(define-variable-pattern *print-readably* :lisp2)
(define-variable-pattern *print-escape* :lisp)
(define-variable-pattern *print-pretty* :lisp)
(define-variable-pattern *print-circle* :lisp)
(define-variable-pattern *print-base* :lisp)
(define-variable-pattern *print-radix* :lisp)
(define-variable-pattern *print-case* :lisp)
(define-variable-pattern *print-gensym* :lisp)
(define-variable-pattern *print-level* :lisp)
(define-variable-pattern *print-length* :lisp)
(define-variable-pattern *print-array* :lisp)
(define-caller-pattern with-standard-io-syntax 
  ((:star declaration)
   (:star form))
  :lisp2)

(define-caller-pattern read (&optional form form form form) :lisp)
(define-variable-pattern *read-default-float-format* :lisp)
(define-caller-pattern read-preserving-whitespace
  (&optional form form form form) :lisp)
(define-caller-pattern read-delimited-list (form &optional form form) :lisp)
(define-caller-pattern read-line (&optional form form form form) :lisp)
(define-caller-pattern read-char (&optional form form form form) :lisp)
(define-caller-pattern unread-char (form (:optional form)) :lisp)
(define-caller-pattern peek-char (&optional form form form form) :lisp)
(define-caller-pattern listen ((:optional form)) :lisp)
(define-caller-pattern read-char-no-hang ((:star form)) :lisp)
(define-caller-pattern clear-input ((:optional form)) :lisp)
(define-caller-pattern read-from-string (form (:star form)) :lisp)
(define-caller-pattern parse-integer (form &rest :ignore) :lisp)
(define-caller-pattern read-byte ((:star form)) :lisp)

(define-caller-pattern write (form &key (:star form)) :lisp)
(define-caller-pattern prin1 (form (:optional form)) :lisp)
(define-caller-pattern print (form (:optional form)) :lisp)
(define-caller-pattern pprint (form (:optional form)) :lisp)
(define-caller-pattern princ (form (:optional form)) :lisp)
(define-caller-pattern write-to-string (form &key (:star form)) :lisp)
(define-caller-pattern prin1-to-string (form) :lisp)
(define-caller-pattern princ-to-string (form) :lisp)
(define-caller-pattern write-char (form (:optional form)) :lisp)
(define-caller-pattern write-string (form &optional form &key (:star form)) :lisp)
(define-caller-pattern write-line (form &optional form &key (:star form)) :lisp)
(define-caller-pattern terpri ((:optional form)) :lisp)
(define-caller-pattern fresh-line ((:optional form)) :lisp)
(define-caller-pattern finish-output ((:optional form)) :lisp)
(define-caller-pattern force-output ((:optional form)) :lisp)
(define-caller-pattern clear-output ((:optional form)) :lisp)
(define-caller-pattern print-unreadable-object 
  ((form form &key (:star form))
   (:star declaration)
   (:star form))
  :lisp2)
(define-caller-pattern write-byte (form form) :lisp)
(define-caller-pattern format
  (destination
   control-string
   (:rest format-arguments))
  :lisp)

(define-caller-pattern y-or-n-p (control-string (:star form)) :lisp)
(define-caller-pattern yes-or-no-p (control-string (:star form)) :lisp)

;;; Pathnames
(define-caller-pattern wild-pathname-p (form &optional form) :lisp2)
(define-caller-pattern pathname-match-p (form form) :lisp2)
(define-caller-pattern translate-pathname (form form form &key (:star form))
  :lisp2)

(define-caller-pattern logical-pathname (form) :lisp2)
(define-caller-pattern translate-logical-pathname (form &key (:star form)) :lisp2)
(define-caller-pattern logical-pathname-translations (form) :lisp2)
(define-caller-pattern load-logical-pathname-translations (form) :lisp2)
(define-caller-pattern compile-file-pathname (form &key form) :lisp2)

(define-caller-pattern pathname (form) :lisp)
(define-caller-pattern truename (form) :lisp)
(define-caller-pattern parse-namestring ((:star form)) :lisp)
(define-caller-pattern merge-pathnames ((:star form)) :lisp)
(define-variable-pattern *default-pathname-defaults* :lisp)
(define-caller-pattern make-pathname ((:star form)) :lisp)
(define-caller-pattern pathnamep (form) :lisp)
(define-caller-pattern pathname-host (form) :lisp)
(define-caller-pattern pathname-device (form) :lisp)
(define-caller-pattern pathname-directory (form) :lisp)
(define-caller-pattern pathname-name (form) :lisp)
(define-caller-pattern pathname-type (form) :lisp)
(define-caller-pattern pathname-version (form) :lisp)
(define-caller-pattern namestring (form) :lisp)
(define-caller-pattern file-namestring (form) :lisp)
(define-caller-pattern directory-namestring (form) :lisp)
(define-caller-pattern host-namestring (form) :lisp)
(define-caller-pattern enough-namestring (form (:optional form)) :lisp)
(define-caller-pattern user-homedir-pathname (&optional form) :lisp)
(define-caller-pattern open (form &key (:star form)) :lisp)
(define-caller-pattern with-open-file
  ((var form (:rest :ignore))
   (:star declaration)
   (:star form))
 :lisp)

(define-caller-pattern rename-file (form form) :lisp)
(define-caller-pattern delete-file (form) :lisp)
(define-caller-pattern probe-file (form) :lisp)
(define-caller-pattern file-write-date (form) :lisp)
(define-caller-pattern file-author (form) :lisp)
(define-caller-pattern file-position (form (:optional form)) :lisp)
(define-caller-pattern file-length (form) :lisp)
(define-caller-pattern file-string-length (form form) :lisp2)
(define-caller-pattern load (form &key (:star form)) :lisp)
(define-variable-pattern *load-verbose* :lisp)
(define-variable-pattern *load-print* :lisp2)
(define-variable-pattern *load-pathname* :lisp2)
(define-variable-pattern *load-truename* :lisp2)
(define-caller-pattern make-load-form (form) :lisp2)
(define-caller-pattern make-load-form-saving-slots (form &optional form)
  :lisp2)
(define-caller-pattern directory (form &key (:star form)) :lisp)

;;; Errors
(define-caller-pattern error (form (:star form)) :lisp)
(define-caller-pattern cerror (form form (:star form)) :lisp)
(define-caller-pattern warn (form (:star form)) :lisp)
(define-variable-pattern *break-on-warnings* :lisp)
(define-caller-pattern break (&optional form (:star form)) :lisp)
(define-caller-pattern check-type (form form (:optional form)) :lisp)
(define-caller-pattern assert 
  (form
   (:optional ((:star var))
	      (:optional form (:star form)))) 
  :lisp)
(define-caller-pattern etypecase (form (:star (symbol (:star form)))) :lisp)
(define-caller-pattern ctypecase (form (:star (symbol (:star form)))) :lisp)
(define-caller-pattern ecase
  (form
   (:star ((:or symbol ((:star symbol)))
	   (:star form))))
  :lisp)
(define-caller-pattern ccase 
  (form
   (:star ((:or symbol ((:star symbol)))
	   (:star form))))
  :lisp)

;;; The Compiler
(define-caller-pattern compile (form (:optional form)) :lisp)
(define-caller-pattern compile-file (form &key (:star form)) :lisp)
(define-variable-pattern *compile-verbose* :lisp2)
(define-variable-pattern *compile-print* :lisp2)
(define-variable-pattern *compile-file-pathname* :lisp2)
(define-variable-pattern *compile-file-truename* :lisp2)
(define-caller-pattern load-time-value (form (:optional form)) :lisp2)
(define-caller-pattern disassemble (form) :lisp)
(define-caller-pattern function-lambda-expression (fn) :lisp2)
(define-caller-pattern with-compilation-unit (((:star :ignore)) (:star form)) 
  :lisp2)

;;; Documentation
(define-caller-pattern documentation (form form) :lisp)
(define-caller-pattern trace ((:star form)) :lisp)
(define-caller-pattern untrace ((:star form)) :lisp)
(define-caller-pattern step (form) :lisp)
(define-caller-pattern time (form) :lisp)
(define-caller-pattern describe (form &optional form) :lisp)
(define-caller-pattern describe-object (form &optional form) :lisp2)
(define-caller-pattern inspect (form) :lisp)
(define-caller-pattern room ((:optional form)) :lisp)
(define-caller-pattern ed ((:optional form)) :lisp)
(define-caller-pattern dribble ((:optional form)) :lisp)
(define-caller-pattern apropos (form (:optional form)) :lisp)
(define-caller-pattern apropos-list (form (:optional form)) :lisp)
(define-caller-pattern get-decoded-time () :lisp)
(define-caller-pattern get-universal-time () :lisp)
(define-caller-pattern decode-universal-time (form &optional form) :lisp)
(define-caller-pattern encode-universal-time 
  (form form form form form form &optional form) :lisp)
(define-caller-pattern get-internal-run-time () :lisp)
(define-caller-pattern get-internal-real-time () :lisp)
(define-caller-pattern sleep (form) :lisp)

(define-caller-pattern lisp-implementation-type () :lisp)
(define-caller-pattern lisp-implementation-version () :lisp)
(define-caller-pattern machine-type () :lisp)
(define-caller-pattern machine-version () :lisp)
(define-caller-pattern machine-instance () :lisp)
(define-caller-pattern software-type () :lisp)
(define-caller-pattern software-version () :lisp)
(define-caller-pattern short-site-name () :lisp)
(define-caller-pattern long-site-name () :lisp)
(define-variable-pattern *features* :lisp)

(define-caller-pattern identity (form) :lisp)

;;; Pretty Printing
(define-variable-pattern *print-pprint-dispatch* :lisp2)
(define-variable-pattern *print-right-margin* :lisp2)
(define-variable-pattern *print-miser-width* :lisp2)
(define-variable-pattern *print-lines* :lisp2)
(define-caller-pattern pprint-newline (form &optional form) :lisp2)
(define-caller-pattern pprint-logical-block
  ((var form &key (:star form))
   (:star form))
  :lisp2)
(define-caller-pattern pprint-exit-if-list-exhausted () :lisp2)
(define-caller-pattern pprint-pop () :lisp2)
(define-caller-pattern pprint-indent (form form &optional form) :lisp2)
(define-caller-pattern pprint-tab (form form form &optional form) :lisp2)
(define-caller-pattern pprint-fill (form form &optional form form) :lisp2)
(define-caller-pattern pprint-linear (form form &optional form form) :lisp2)
(define-caller-pattern pprint-tabular (form form &optional form form form) :lisp2)
(define-caller-pattern formatter (control-string) :lisp2)
(define-caller-pattern copy-pprint-dispatch (&optional form) :lisp2)
(define-caller-pattern pprint-dispatch (form &optional form) :lisp2)
(define-caller-pattern set-pprint-dispatch (form form &optional form form)
  :lisp2)

;;; CLOS
(define-caller-pattern add-method (fn form) :lisp2)
(define-caller-pattern call-method (form form) :lisp2)
(define-caller-pattern call-next-method ((:star form)) :lisp2)
(define-caller-pattern change-class (form form) :lisp2)
(define-caller-pattern class-name (form) :lisp2)
(define-caller-pattern class-of (form) :lisp2)
(define-caller-pattern compute-applicable-methods (fn (:star form)) :lisp2)
(define-caller-pattern defclass (name &rest :ignore) :lisp2)
(define-caller-pattern defgeneric (name lambda-list &rest :ignore) :lisp2)
(define-caller-pattern define-method-combination 
  (name lambda-list ((:star :ignore))
	(:optional ((:eq :arguments) :ignore))
	(:optional ((:eq :generic-function) :ignore))
	(:star (:or declaration documentation-string))
	(:star form))
  :lisp2)
(define-caller-pattern defmethod 
  (name (:star symbol) lambda-list
	(:star (:or declaration documentation-string))
	(:star form))
  :lisp2)
(define-caller-pattern ensure-generic-function (name &key (:star form)) :lisp2)
(define-caller-pattern find-class (form &optional form form) :lisp2)
(define-caller-pattern find-method (fn &rest :ignore) :lisp2)
(define-caller-pattern function-keywords (&rest :ignore) :lisp2)
(define-caller-pattern generic-flet (((:star (name lambda-list))) (:star form))
  :lisp2)
(define-caller-pattern generic-labels 
  (((:star (name lambda-list))) (:star form))
  :lisp2)
(define-caller-pattern generic-function (lambda-list) :lisp2)
(define-caller-pattern initialize-instance (form &key (:star form)) :lisp2)
(define-caller-pattern invalid-method-error (fn form (:star form)) :lisp2)
(define-caller-pattern make-instance (fn (:star form)) :lisp2)
(define-caller-pattern make-instances-obsolete (fn) :lisp2)
(define-caller-pattern method-combination-error (form (:star form)) :lisp2)
(define-caller-pattern method-qualifiers (fn) :lisp2)
(define-caller-pattern next-method-p () :lisp2)
(define-caller-pattern no-applicable-method (fn (:star form)) :lisp2)
(define-caller-pattern no-next-method (fn (:star form)) :lisp2)
(define-caller-pattern print-object (form form) :lisp2)
(define-caller-pattern reinitialize-instance (form (:star form)) :lisp2)
(define-caller-pattern remove-method (fn form) :lisp2)
(define-caller-pattern shared-initialize (form form (:star form)) :lisp2)
(define-caller-pattern slot-boundp (form form) :lisp2)
(define-caller-pattern slot-exists-p (form form) :lisp2)
(define-caller-pattern slot-makeunbound (form form) :lisp2)
(define-caller-pattern slot-missing (fn form form form &optional form) :lisp2)
(define-caller-pattern slot-unbound (fn form form) :lisp2)
(define-caller-pattern slot-value (form form) :lisp2)
(define-caller-pattern update-instance-for-different-class 
  (form form (:star form)) :lisp2)
(define-caller-pattern update-instance-for-redefined-class 
  (form form (:star form)) :lisp2)
(define-caller-pattern with-accessors
  (((:star :ignore)) form
   (:star declaration)
   (:star form))
  :lisp2)
(define-caller-pattern with-added-methods
  ((name lambda-list) form
   (:star form))
  :lisp2)
(define-caller-pattern with-slots
  (((:star :ignore)) form
   (:star declaration)
   (:star form))
  :lisp2)

;;; Conditions
(define-caller-pattern signal (form (:star form)) :lisp2)
(define-variable-pattern *break-on-signals* :lisp2)
(define-caller-pattern handler-case (form (:star (form ((:optional var))
						       (:star form))))
  :lisp2)
(define-caller-pattern ignore-errors ((:star form)) :lisp2)
(define-caller-pattern handler-bind (((:star (form form)))
				     (:star form))
  :lisp2)
(define-caller-pattern define-condition (name &rest :ignore) :lisp2)
(define-caller-pattern make-condition (form &rest :ignore) :lisp2)
(define-caller-pattern with-simple-restart
  ((name form (:star form)) (:star form)) :lisp2)
(define-caller-pattern restart-case 
  (form
   (:star (form form (:star form))))
  :lisp2)
(define-caller-pattern restart-bind
  (((:star (name fn &key (:star form))))
   (:star form))
  :lisp2)
(define-caller-pattern with-condition-restarts
  (form form
	(:star declaration)
	(:star form))
  :lisp2)
(define-caller-pattern compute-restarts (&optional form) :lisp2)
(define-caller-pattern restart-name (form) :lisp2)
(define-caller-pattern find-restart (form &optional form) :lisp2)
(define-caller-pattern invoke-restart (form (:star form)) :lisp2)
(define-caller-pattern invoke-restart-interactively (form) :lisp2)
(define-caller-pattern abort (&optional form) :lisp2)
(define-caller-pattern continue (&optional form) :lisp2)
(define-caller-pattern muffle-warning (&optional form) :lisp2)
(define-caller-pattern store-value (form &optional form) :lisp2)
(define-caller-pattern use-value (form &optional form) :lisp2)
(define-caller-pattern invoke-debugger (form) :lisp2)
(define-variable-pattern *debugger-hook* :lisp2)
(define-caller-pattern simple-condition-format-string (form) :lisp2)
(define-caller-pattern simple-condition-format-arguments (form) :lisp2)
(define-caller-pattern type-error-datum (form) :lisp2)
(define-caller-pattern type-error-expected-type (form) :lisp2)
(define-caller-pattern package-error-package (form) :lisp2)
(define-caller-pattern stream-error-stream (form) :lisp2)
(define-caller-pattern file-error-pathname (form) :lisp2)
(define-caller-pattern cell-error-name (form) :lisp2)
(define-caller-pattern arithmetic-error-operation (form) :lisp2)
(define-caller-pattern arithmetic-error-operands (form) :lisp2)

;;; For ZetaLisp Flavors
(define-caller-pattern send (form fn (:star form)) :flavors)