[e90b2f]: src / lsp / top.lsp Maximize Restore History

Download this file

top.lsp    1506 lines (1405 with data), 52.6 kB

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*-
;;;;
;;;; top.lsp -- Top-level loop, break loop, and error handlers
;;;;
;;;; Copyright (c) 1990, Giuseppe Attardi.
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;;
;;;; Revised on July 11, by Carl Hoffman.
;;;; Modified Oct 1986 by Ken Rimey.
;;;; Reworked March 1987, by Edward Wang.
;;;; Merged into new distribution Sept 1987, by Edward Wang.
;;;; Reworked for Threads November 1988, by Giuseppe Attardi.
;;;; Reworked for CLOS November 1988, by Giuseppe Attardi.
;;;; Updated May 2009, by Jean-Claude Beaudoin
(in-package "SYSTEM")
(export '(*break-readtable* *break-on-warnings*
*tpl-evalhook* *tpl-prompt-hook*))
(defparameter *quit-tag* (cons nil nil))
(defparameter *quit-tags* nil)
(defparameter *break-level* 0) ; nesting level of error loops
(defparameter *break-env* nil)
(defparameter *ihs-base* 0)
(defparameter *ihs-top* (ihs-top))
(defparameter *ihs-current* 0)
(defparameter *frs-base* 0)
(defparameter *frs-top* 0)
(defparameter *tpl-continuable* t)
(defparameter *tpl-prompt-hook* nil)
(defparameter *eof* (cons nil nil))
(defparameter *last-error* nil)
(defparameter *break-message* nil)
(defparameter *break-readtable* nil)
(defparameter *tpl-level* -1) ; nesting level of top-level loops
(defparameter *step-level* 0) ; repeated from trace.lsp
(defparameter *break-hidden-functions* '(error cerror apply funcall invoke-debugger))
(defparameter *break-hidden-packages* (list #-ecl-min (find-package 'system)))
(defconstant tpl-commands
'(("Top level commands"
((:cf :compile-file) tpl-compile-command :string
":cf Compile file"
":compile-file &string &rest files [Top level command]~@
:cf &string &rest files [Abbreviation]~@
~@
Compile files. With no arguments, uses values from latest :cf~@
command. File extensions are optional.~%")
((:exit :eof) quit :eval
":exit or ^D Exit Lisp"
":exit &eval &optional (status 0) [Top level command]~@
~@
Exit Lisp without further confirmation.~%")
((:ld :load) tpl-load-command :string
":ld Load file"
":load &string &rest files [Top level command]~@
:ld &string &rest files [Abbreviation]~@
~@
Load files. With no arguments, uses values from latest :ld~@
or :cf command. File extensions are optional.~%")
((:step) tpl-step-command nil
":step Single step form"
":step form [Top level command]~@
~@
Evaluate form in single step mode. While stepping, a new break~@
level is invoked before every evaluation. Extra commands are~@
available at this time to control stepping and form evaluation.~%")
((:tr :trace) tpl-trace-command nil
":tr(ace) Trace function"
":trace &rest functions [Top level command]~@
:tr &rest functions [Abbreviation]~@
~@
Trace specified functions. With no arguments, show currently~@
traced functions.~@
~@
See also: :untrace.~%")
((:untr :untrace) tpl-untrace-command nil
":untr(ace) Untrace function"
":untrace &rest functions [Top level command]~@
:untr &rest functions [Abbreviation]~@
~@
Untrace specified functions. With no arguments, untrace~@
all functions.~@
~@
See also: :trace.~%")
#+threads
((:s :switch) tpl-switch-command nil
":s(witch) Switch to next process to debug"
":switch process [Break command]~@
:s processs [Abbreviation]~@
~@
Switch to next process in need to debugger attention. Argument~@
process, when provided, must be an integer indicating the rank~@
of the process in the debugger waiting list.~%")
#+threads
((:br :break) tpl-interrupt-command nil
":br(eak) Stop a given process"
":break process [Break command]~@
:br processs [Abbreviation]~@
~@
Interrupt a given process. Argument process, must be provided and
it must be an integer indicating the rank~@
of the process in the debugger waiting list (:waiting).~%")
#+threads
((:w :waiting) tpl-waiting-command nil
":w(aiting) Display list of active toplevels"
":waiting [Break command]~@
:w [Abbreviation]~@
~@
Display list of active toplevels, including open debug sessions.~%")
)
("Help commands"
((:apropos) tpl-apropos-command nil
":apropos Apropos"
":apropos string &optional package [Top level command]~@
~@
Finds all available symbols whose print names contain string.~@
If a non NIL package is specified, only symbols in that package are considered.~@
~%")
((:doc document) tpl-document-command nil
":doc(ument) Document"
":document symbol [Top level command]~@
~@
Displays documentation about function, print names contain string.~%")
((? :h :help) tpl-help-command nil
":h(elp) or ? Help. Type \":help help\" for more information"
":help &optional topic [Top level command]~@
:h &optional topic [Abbrevation]~@
~@
Print information on specified topic. With no arguments, print~@
quick summery of top level commands.~@
~@
Help information for top level commands follows the documentation~@
style found in \"Common Lisp, the Language\"; and, in general, the~@
commands themselves follow the conventions of Common Lisp functions,~@
with the exception that arguments are normally not evaluated.~@
Those commands that do evaluate their arguments are indicated by the~@
keyword &eval in their description. A third class of commands~@
treat their arguments as whitespace-separated, case-sensitive~@
strings, requiring double quotes only when necessary. This style~@
of argument processing is indicated by the keyword &string.~@
For example, the :load command accepts a list of file names:
~@
:load &string &rest files [Top level Command]~@
~@
whereas :exit, which requires an optional evaluated argument, is~@
~@
:exit &eval &optional status [Top level Command]~%")
)))
(defparameter *tpl-commands* tpl-commands)
(defconstant break-commands
'("Break commands"
((:q :quit) tpl-quit-command nil
":q(uit) Return to some previous break level"
":quit &optional n [Break command]~@
:q &optional n [Abbreviation]~@
~@
Without argument, return to top level;~@
otherwise return to break level n.~%")
((:pop) (tpl-pop-command) :constant
":pop Pop to previous break level"
":pop [Break command]~@
~@
Pop to previous break level, or if already in top level,~@
exit Lisp after confirmation.~%")
((:c :continue) continue nil
":c(ontinue) Continue execution"
":continue [Break command]~@
:c [Abbreviation]~@
~@
Continue execution. Return from current break level to the caller.~@
This command is only available when the break level is continuable~@
(e.g., called from a correctable error or the function break).~%")
((:b :backtrace) tpl-backtrace nil
":b(acktrace) Print backtrace"
":backtrace &optional n [Break command]~@
:b &optional n [Abbreviation]~@
~@
Show function call history. Only those functions called since~@
the previous break level are shown. In addition, functions compiled~@
in-line or explicitly hidden are not displayed. Without an argument,~@
a concise backtrace is printed with the current function in upper~@
case. With integer argument n, the n functions above and including~@
the current one are printed in a verbose format.~@
~@
See also: :function, :previous, :next.~%")
((:f :function) tpl-print-current nil
":f(unction) Show current function"
":function [Break command]~@
:f [Abbreviation]~@
~@
Show current function. The current function is the implicit focus~@
of attention for several other commands. When it is an interpreted~@
function, its lexical environment is available for inspection and~@
becomes the environment for evaluating user input forms.~@
~@
See also: :backtrace, :next, previous, :disassemble, :variables.~%")
((:p :previous) tpl-previous nil
":p(revious) Go to previous function"
":previous &optional (n 1) [Break command]~@
:p &optional (n 1) [Abbreviation]~@
~@
Move to the nth previous visible function in the backtrace.~@
It becomes the new current function.~@
~@
See also: :backtrace, :function, :go, :next.~%")
((:d :down) tpl-previous nil
":d(own) Alias to :previous"
""
)
((:n :next) tpl-next nil
":n(ext) Go to next function"
":next &optional (n 1) [Break command]~@
:n &optional (n 1) [Abbreviation]~@
~@
Move to the nth next visible function in the backtrace. It becomes~@
the new current function.~@
~@
See also: :backtrace, :function, :go, :previous.~%")
((:u :up) tpl-next nil
":u(p) Alias to :next"
""
)
((:g :go) tpl-go nil
":g(o) Go to next function"
":go &optional (n 1) [Break command]~@
:g &optional (n 1) [Abbreviation]~@
~@
Move to the function at IHS[i].~@
See also: :backtrace, :function, :next, :previous.~%")
((:fs :forward-search) tpl-forward-search :string
":fs Search forward for function"
":forward-search &string substring [Break command]~@
:fs &string substring [Abbreviation]~@
~@
Search forward in the backtrace for function containing substring.~@
The match is case insensitive.~@
~@
See also: :backtrace, :function, :next.~%")
((:bs :backward-search) tpl-backward-search :string
":bs Search backward for function"
":backward-search &string substring [Break command]~@
:bs &string substring [Abbreviation]~@
~@
Search backward in the backtrace for function containing substring.~@
The match is case insensitive.~@
~@
See also: :backtrace, :function, :previous.~%")
((:disassemble) tpl-disassemble-command nil
":disassemble Disassemble current function"
":disassemble [Break command]~@
:disassemble [Abbreviation]~@
~@
Disassemble the current function. Currently, only interpreted functions~@
can be disassembled.~%")
((:le :lambda-expression) tpl-lambda-expression-command nil
":l(ambda-)e(expression) Show lisp code for current function"
":lambda-expression [Break command]~@
:le [Abbreviation]~@
~@
Show the lisp code of the current function. Only works for interpreted~@
functions.~%")
((:v :variables) tpl-variables-command nil
":v(ariables) Show local variables, functions, blocks, and tags"
":variables &optional no-values [Break command]~@
:v &optional no-values [Abbreviation]~@
~@
Show lexical variables, functions, block names, and tags local~@
to the current function. The current function must be interpreted.~@
The values of local variables and functions are also shown,~@
unless the argument is non-null.~%")
#|
((:l :local) tpl-local-command nil
":l(ocal) Return the nth local value on the stack"
":local &optional (n 0) [Break command]~@
:l &optional (n 0) [Abbreviation]
~@
For compiled functions, return the value of the nth lexical variable.~@
As is done normally, the returned value is both printed by the top~@
level as well as saved in the variable *.~%")
|#
((:hide) tpl-hide nil
":hide Hide function"
":hide function [Break command]~@
~@
Hide function. A hidden function is not displayed in a backtrace.~@
~@
See also: :backtrace, :unhide, :hide-package.~%")
((:unhide) tpl-unhide nil
":unhide Unhide function"
":unhide function [Break command]~@
~@
Unhide function. The specified function will be displayed in future~@
backtraces, unless its home package is also hidden.~@
~@
See also: :backtrace, :hide, :unhide-package.~%")
((:hp :hide-package) tpl-hide-package nil
":hp Hide package"
":hide-package package [Break command]~@
:hp package [Abbreviation]~@
~@
Hide package. Functions in a hidden package are not displayed~@
in a backtrace.~@
~@
See also: :backtrace, :unhide-package.~%")
((:unhp :unhide-package) tpl-unhide-package nil
":unhp Unhide package"
":unhide-package package [Break command]~@
:unhp package [Abbreviation]~@
~@
Unhide package. Functions in the specified package will be displayed~@
in future backtraces, unless they are individually hidden.~@
~@
See also: :backtrace, :hide-package, :hide, :unhide.~%")
((:unhide-all) tpl-unhide-all nil
":unhide-all Unhide all variables and packages"
":unhide-all [Break command]~@
~@
Unhide all variables and packages. All functions will be displayed~@
in future backtraces.~@
~@
See also: :hide, :unhide, :hide-package, :unhide-package.~%")
#|
((:vs :value-stack) tpl-vs-command nil
":vs Show value stack"
":value-stack &optional n [Break command]~@
:vs &optional n [Abbreviation]~@
~@
Without an argument, show the entire value stack since the previous~@
break level. With an integer argument n, print nothing, but return~@
the nth value stack entry.~@
~@
See also: :local.~%")
|#
((:bds :binding-stack) tpl-bds-command nil
":bds Show binding stack"
":binding-stack &optional variable [Break command]~@
:bds &optional variable [Abbreviation]~@
~@
Without an argument, show the entire binding stack since the previous~@
break level. With a variable name, print nothing, but return the~@
value of the given variable on the binding stack.~%")
((:frs :frame-stack) tpl-frs-command nil
":frs Show frame stack"
""
)
((:m :message) tpl-print-message nil
":m(essage) Show error message"
":message [Break command]~@
:m [Abbreviation]~@
~@
Show current error message.~%")
((:hs :help-stack) tpl-help-stack-command nil
":hs Help stack"
":help-stack [Break command]~@
:hs [Abbrevation]~@
~@
Lists the functions to access the LISP system stacks.~%")
((:i :inspect) tpl-inspect-command nil
":i(nspect) Inspect value of local variable"
":inspect var-name [Break command]~@
:i var-name [Abbreviation]~@
~@
Inspect value of local variable named by var-name. Argument~@
var-name can be a string or a symbol whose name string will~@
then be used regardless of of the symbol's package.~@
~@
See also: :variables.~%")
))
(defparameter *lisp-initialized* nil)
(defun top-level (&optional (process-command-line nil))
"Args: ()
ECL specific.
The top-level loop of ECL. It is called by default when ECL is invoked."
(catch *quit-tag*
(let* ((*debugger-hook* nil)
+ ++ +++ - * ** *** / // ///)
(in-package "CL-USER")
(unless (or *lisp-initialized* (null process-command-line))
(process-command-args)
(format t "ECL (Embeddable Common-Lisp) ~A (git:~D)"
(lisp-implementation-version)
(ext:lisp-implementation-vcs-id))
(format t "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@
Copyright (C) 1993 Giuseppe Attardi~@
Copyright (C) 2000 Juan J. Garcia-Ripoll
ECL is free software, and you are welcome to redistribute it~@
under certain conditions; see file 'Copyright' for details.")
(format *standard-output* "~%Type :h for Help. "))
(setq *lisp-initialized* t)
(let ((*tpl-level* -1))
(tpl))
0)))
#+threads
(progn
(defparameter *console-lock* (mp:make-lock :name "Console lock"))
(defparameter *console-available* (mp:make-condition-variable))
(defparameter *console-owner* nil)
(defparameter *console-waiting-list* '())
(defun candidate-to-get-console-p (process)
(or (null *console-owner*)
(eq *console-owner* process)
(not (mp:process-active-p *console-owner*))))
(defun register-in-waiting-list (process)
(mp:with-lock (*console-lock*)
(push process *console-waiting-list*)))
(defun delete-from-waiting-list (process)
(mp:with-lock (*console-lock*)
(setf *console-waiting-list* (delete process *console-waiting-list*))))
(defun grab-console (process)
(loop with repeat = t
while repeat
do (mp:with-lock (*console-lock*)
(cond ((candidate-to-get-console-p process)
(setf *console-owner* process)
(setf repeat nil))
(t
(mp:condition-variable-wait *console-available* *console-lock*))))))
(defun release-console (process)
(mp:with-lock (*console-lock*)
(and (eq process *console-owner*) (setf *console-owner* nil))
(mp:condition-variable-signal *console-available*)))
) ; #+threads
(defmacro with-grabbed-console (&rest body)
#-threads
`(progn ,@body)
#+threads
`(unwind-protect
(progn
(register-in-waiting-list mp:*current-process*)
(grab-console mp:*current-process*)
,@body)
(delete-from-waiting-list mp:*current-process*)
(release-console mp:*current-process*)))
(defparameter *allow-recursive-debug* nil)
(defparameter *debug-status* nil)
(defun simple-terminal-interrupt ()
(error 'ext:interactive-interrupt))
#+threads
(defun show-process-list (&optional (process-list (mp:all-processes)))
(loop with current = mp:*current-process*
for rank from 1
for process in process-list
do (format t (if (eq process current)
"~% >~D: ~s"
"~% ~D: ~s")
rank process)))
#+threads
(defun query-process (&optional (process-list (mp:all-processes)))
(format t "~&Choose the integer code of process to interrupt.
Use special code 0 to cancel this operation.")
(loop for code = (progn
(show-process-list process-list)
(tpl-prompt)
(tpl-read))
do (cond ((zerop code)
(return nil))
((and (fixnump code) (<= 1 code (length process-list)))
(return (list (elt process-list (1- code)))))
(t
(format t "~&Not a valid process number")))))
(defparameter *interrupt-lonely-threads-p* t)
(defun single-threaded-terminal-interrupt ()
(restart-case (simple-terminal-interrupt)
(continue ())))
(defun terminal-interrupt (&key process (correctablep t))
(declare (ignore correctablep))
#+threads
(mp:without-interrupts
(let* ((suspended '())
(break-process nil)
(all-processes
(loop with this = mp:*current-process*
for p in (mp:all-processes)
unless (or (eq p this)
(member (mp:process-name p)
'(si:signal-servicing si::handle-signal)))
collect p)))
(when (and (= (length all-processes) 1) *interrupt-lonely-threads-p*)
(mp:interrupt-process (first all-processes)
#'single-threaded-terminal-interrupt)
(return-from terminal-interrupt))
(loop for i in all-processes
do (progn (format t "~%;;; Suspending process ~A" i)
(push i suspended)
(mp:process-suspend i)))
(flet ((do-query-process ()
(print all-processes)
(query-process all-processes)))
(mp:with-local-interrupts
(restart-case (simple-terminal-interrupt)
(continue () (setf break-process nil))
(mp:interrupt-process (process)
:interactive do-query-process
:report (lambda (stream) (princ "Interrupt a certain process." stream))
(setf break-process process)))))
(loop for process in suspended
unless (eq process break-process)
do (mp:process-resume process))
(when break-process
(mp:interrupt-process break-process
#'single-threaded-terminal-interrupt))))
#-threads
(single-threaded-terminal-interrupt))
(defun tpl (&key ((:commands *tpl-commands*) tpl-commands)
((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*)
(broken-at nil)
(quiet nil))
#-ecl-min
(declare (c::policy-debug-ihs-frame))
(let* ((*ihs-base* *ihs-top*)
(*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top)))
(*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*))
(*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
(*frs-top* (frs-top))
(*quit-tags* (cons *quit-tag* *quit-tags*))
(*quit-tag* *quit-tags*) ; any unique new value
(*tpl-level* (1+ *tpl-level*))
(break-level *break-level*)
values)
(set-break-env)
(set-current-ihs)
(flet ((rep ()
;; We let warnings pass by this way "warn" does the
;; work. It is conventional not to trap anything
;; that is not a SERIOUS-CONDITION. Otherwise we
;; would be interferring the behavior of code that relies
;; on conditions for communication (for instance our compiler)
;; and which expect nothing to happen by default.
(handler-bind
((serious-condition
(lambda (condition)
(cond ((< break-level 1)
;; Toplevel should enter the debugger on any condition.
)
(*allow-recursive-debug*
;; We are told to let the debugger handle this.
)
(t
(format t "~&Debugger received error of type: ~A~%~A~%~
Error flushed.~%"
(type-of condition) condition)
(clear-input)
(return-from rep t) ;; go back into the debugger loop.
)
)
)))
(with-grabbed-console
(unless quiet
(break-where)
(setf quiet t))
(setq - (locally (declare (notinline tpl-read))
(tpl-prompt)
(tpl-read))
values (multiple-value-list
(eval-with-env - *break-env*))
/// // // / / values *** ** ** * * (car /))
(tpl-print values)))))
(loop
(setq +++ ++ ++ + + -)
(when
(catch *quit-tag*
(if (zerop break-level)
(with-simple-restart
(restart-toplevel "Go back to Top-Level REPL.")
(rep))
(with-simple-restart
(restart-debugger "Go back to debugger level ~D." break-level)
(rep)))
nil)
(setf quiet nil))))))
(defun tpl-prompt ()
(typecase *tpl-prompt-hook*
(string (format t *tpl-prompt-hook*))
(function (funcall *tpl-prompt-hook*))
(t (fresh-line)
(format t "~A~V,,,'>A "
(if (eq *package* (find-package 'user))
""
(package-name *package*))
(- *tpl-level* *step-level* -1)
""))))
(defun tpl-read (&aux (*read-suppress* nil))
(finish-output)
(loop
(case (peek-char nil *standard-input* nil :EOF)
((#\))
(warn "Ignoring an unmatched right parenthesis.")
(read-char))
((#\space #\tab)
(read-char))
((#\newline #\return)
(read-char)
;; avoid repeating prompt on successive empty lines:
(let ((command (tpl-make-command :newline "")))
(when command (return command))))
(:EOF
(terpri)
(return (tpl-make-command :EOF "")))
(#\:
(return (tpl-make-command (read-preserving-whitespace)
(read-line))))
(#\?
(read-char)
(case (peek-char nil *standard-input* nil :EOF)
((#\space #\tab #\newline #\return :EOF)
(return (tpl-make-command :HELP (read-line))))
(t
(unread-char #\?)
(return (read-preserving-whitespace)))))
;; We use READ-PRESERVING-WHITESPACE because with READ, if an
;; error happens within the reader, and we perform a ":C" or
;; (CONTINUE), the reader will wait for an inexistent #\Newline.
(t
(return (read))))))
(defparameter *debug-tpl-commands* nil)
(defun harden-command (cmd-form)
`(block
tpl-command
(handler-bind
((error (lambda (condition)
(unless *debug-tpl-commands*
(format t "~&Command aborted.~%Received condition of type: ~A~%~A"
(type-of condition) condition)
(clear-input)
(return-from tpl-command nil)
)
)
))
,cmd-form
)
)
)
(defun tpl-make-command (name line &aux (c nil))
(dolist (commands *tpl-commands*)
(when (setq c (assoc name (cdr commands) :test #'member))
(return)))
(cond ((null c)
(if (eq name :newline) ; special handling for Newline.
nil
`(tpl-unknown-command ',name)))
((eq (third c) :restart)
`(progn
(invoke-restart-interactively ,(second c))))
((eq (third c) :eval)
`(,(second c) . ,(tpl-parse-forms line)))
((eq (third c) :string)
(harden-command `(,(second c) . ,(tpl-parse-strings line))))
((eq (third c) :constant)
(harden-command (second c)))
(t
(harden-command `(,(second c) . ,(tpl-parse-forms line t))))))
(defun tpl-parse-forms (line &optional quote)
(with-input-from-string (stream line)
(do ((form (read stream nil *eof*) (read stream nil *eof*))
(list nil))
((eq form *eof*) (nreverse list))
(push (if quote `',form form) list))))
(defun tpl-parse-strings (line)
(do ((i 0 end)
(start)
(end)
(list nil)
(space-p #'(lambda (c) (or (eql c #\space) (eql c #\tab))))
(length (length line)))
((>= i length) (nreverse list))
(cond ((null (setq start (position-if-not space-p line :START i)))
(setq end length))
((eql (schar line start) #\")
(multiple-value-bind
(string n)
(read-from-string line t nil :START start)
(push string list)
(setq end n)))
(t
(setq end (or (position-if space-p line :START start) length))
(push (subseq line start end) list)))))
(defun tpl-print (values)
(fresh-line)
(dolist (v values)
(prin1 v)
(terpri)))
(defun tpl-unknown-command (command)
(format t "Unknown top level command: ~s~%" command)
(values))
(defun tpl-pop-command (&rest any)
(declare (ignore any))
(throw (pop *quit-tags*) t))
(defun tpl-quit-command (&optional (level 0))
(when (and (>= level 0) (< level *tpl-level*))
(let ((x (nth (- *tpl-level* level 1) *quit-tags*)))
(throw x x)))
(tpl-print-current))
(defun tpl-previous (&optional (n 1))
(do ((i (si::ihs-prev *ihs-current*) (si::ihs-prev i)))
((or (< i *ihs-base*) (<= n 0)))
(when (ihs-visible i)
(setq *ihs-current* i)
(decf n)))
(set-break-env)
(tpl-print-current))
(defun tpl-next (&optional (n 1))
(do ((i (si::ihs-next *ihs-current*) (si::ihs-next i)))
((or (> i *ihs-top*) (<= n 0)))
(when (ihs-visible i)
(setq *ihs-current* i)
(decf n)))
(set-break-env)
(tpl-print-current))
(defun tpl-go (ihs-index)
(setq *ihs-current* (min (max ihs-index *ihs-base*) *ihs-top*))
(if (ihs-visible *ihs-current*)
(progn (set-break-env) (tpl-print-current))
(tpl-previous)))
(defun tpl-print-message ()
(when *break-message*
(princ *break-message*)
(terpri))
(values))
(defun tpl-disassemble-command ()
(let*((*print-level* 2)
(*print-length* 4)
(*print-pretty* t)
(*print-escape* nil)
(*print-readably* nil)
(functions) (blocks) (variables))
(unless (si::bc-disassemble (ihs-fun *ihs-current*))
(tpl-print-current)
(format t " Function cannot be disassembled.~%"))
(values)))
(defun tpl-lambda-expression-command ()
(let*(;;(*print-level* 2)
;;(*print-length* 4)
;;(*print-pretty* t)
;;(*print-readably* nil)
(function (ihs-fun *ihs-current*))
(le (function-lambda-expression function)))
(if le
(pprint le)
(format t " No source code available for this function.~%"))
(values)))
(defun reconstruct-bytecodes-lambda-list (data)
(declare (si::c-local data))
(let ((output '()))
(dotimes (n (pop data)) ;; required values
(declare (fixnum n))
(push (pop data) output))
(let ((l (pop data))) ;; optional values
(declare (fixnum l))
(unless (zerop l)
(push '&optional output)
(dotimes (n l)
(push (first data) output)
(setf data (cdddr data)))))
(let ((rest (pop data))) ;; &rest value
(when rest
(push '&rest output)
(push rest output)))
(let* ((allow-other-keys (pop data))) ;; &keys and &allow-other-keys
(unless (eql allow-other-keys 0)
(push '&key output)
(let ((l (pop data)))
(declare (fixnum l))
(dotimes (n l)
(let* ((key (first data))
(var (second data)))
(unless (and (keywordp key) (string= key var))
(setf var (list (list key var))))
(push var output))))
(when allow-other-keys
(push '&allow-other-keys output))))
(nreverse output)))
(defun function-lambda-list (function)
(cond
((symbolp function)
(if (or (not (fboundp function))
(special-operator-p function)
(macro-function function))
(values nil nil)
(function-lambda-list (fdefinition function))))
((typep function 'generic-function)
(values (clos:generic-function-lambda-list function) t))
;; Use the lambda list from the function definition, if available,
;; but remove &aux arguments.
((let ((f (function-lambda-expression function)))
(when f
(let* ((list (if (eql (first f) 'LAMBDA)
(second f)
(third f)))
(ndx (position '&aux list)))
(return-from function-lambda-list
(values (if ndx (subseq list 0 (1- ndx)) list) t))))))
;; Reconstruct the lambda list from the bytecodes
((multiple-value-bind (lex-env bytecodes data)
(si::bc-split function)
(declare (ignore lex-env))
(when bytecodes
(setq data (coerce data 'list))
(return-from function-lambda-list
(values (reconstruct-bytecodes-lambda-list data) t)))))
;; If it's a compiled function of ECL itself, reconstruct the
;; lambda-list from its documentation string.
(t
(let* ((name (compiled-function-name function))
(args (ext:get-annotation name :lambda-list nil)))
(values args (and args t))))))
#-ecl-min
(defun decode-env-elt (env ndx)
(ffi:c-inline (env ndx) (:object :fixnum) :object
"
cl_object v = #0;
cl_index ndx = #1;
typedef struct ecl_var_debug_info *pinfo;
pinfo d = (pinfo)(v->vector.self.t[1]) + ndx;
cl_object name = make_constant_base_string(d->name);
void *value = (void*)(v->vector.self.t[2+ndx]);
cl_object output;
switch (d->type) {
case _ecl_object_loc:
output = *((cl_object*)value);
break;
case _ecl_fixnum_loc: {
cl_fixnum *p = (cl_fixnum*)value;
output = ecl_make_integer(*p);
break;
}
case _ecl_float_loc: {
float *p = (float*)value;
output = ecl_make_single_float(*p);
break;
}
case _ecl_double_loc: {
double *p = (double*)value;
output = ecl_make_double_float(*p);
break;
}
#ifdef ECL_SSE2
case _ecl_int_sse_pack_loc: {
__m128i *p = (__m128i*)value;
output = ecl_make_int_sse_pack(_mm_loadu_si128(p));
break;
}
case _ecl_float_sse_pack_loc: {
__m128 *p = (__m128*)value;
output = ecl_make_float_sse_pack(_mm_loadu_ps((float*)p));
break;
}
case _ecl_double_sse_pack_loc: {
__m128d *p = (__m128d*)value;
output = ecl_make_double_sse_pack(_mm_loadu_pd((double*)p));
break;
}
#endif
default: {
ecl_base_char *p = (ecl_base_char*)value;
output = ECL_CODE_CHAR(*p);
break;
}
}
@(return) = CONS(name,output);
" :one-liner nil))
(defun decode-ihs-env (*break-env*)
(let ((env *break-env*))
(if (vectorp env)
#+ecl-min
nil
#-ecl-min
(let* ((next (decode-ihs-env
(ffi:c-inline (env) (:object) :object
"(#0)->vector.self.t[0]" :one-liner t))))
(nreconc (loop with l = (- (length env) 2)
for i from 0 below l
do (push (decode-env-elt env i) next))
next))
env)))
(defun ihs-environment (ihs-index)
(labels ((newly-bound-special-variables (bds-min bds-max)
(loop for i from bds-min to bds-max
for variable = (bds-var i)
unless (member variable output :test #'eq)
collect variable into output
finally (return output)))
(special-variables-alist (ihs-index)
(let ((top (ihs-top)))
(unless (> ihs-index top)
(let* ((bds-min (1+ (ihs-bds ihs-index)))
(bds-top (bds-top))
(bds-max (if (= ihs-index top)
bds-top
(ihs-bds (1+ ihs-index))))
(variables (newly-bound-special-variables bds-min bds-max)))
(loop with output = '()
for i from (1+ bds-max) to bds-top
for var = (bds-var i)
when (member var variables :test #'eq)
do (setf variables (delete var variables)
output (acons var (bds-val i) output))
finally (return
(append (loop for v in variables
collect (cons v (symbol-value v)))
output)))))))
(extract-restarts (variables-alist)
(let ((record (assoc '*restart-clusters* variables-alist)))
(if record
(let* ((bindings (cdr record))
(new-bindings (first bindings)))
(values (delete record variables-alist) new-bindings))
(values variables-alist nil)))))
(let* ((functions '())
(blocks '())
(local-variables '())
(special-variables '())
(restarts '())
record0 record1)
(dolist (record (decode-ihs-env (ihs-env ihs-index)))
(cond ((atom record)
(push (compiled-function-name record) functions))
((progn
(setf record0 (car record) record1 (cdr record))
(when (stringp record0)
(setf record0
(let ((*package* (find-package "KEYWORD")))
(with-standard-io-syntax
(read-from-string record0)))))
(or (symbolp record0) (stringp record0)))
(setq local-variables (acons record0 record1 local-variables)))
((symbolp record1)
(push record1 blocks))
(t
)))
(multiple-value-bind (special-variables restarts)
(extract-restarts (special-variables-alist ihs-index))
(values (nreverse local-variables)
special-variables
functions blocks restarts)))))
(defun tpl-print-variables (prefix variables no-values)
;; This format is what was in the orignal code.
;; It simply does not work when no-values is t.
;; If you care to debug this kind of conundrum then have fun!
;;(format t "Local variables: ~:[~:[none~;~:*~{~a~1*~:@{, ~a~1*~}~}~]~;~
;; ~:[none~;~:*~{~% ~a: ~s~}~]~]~%"
;; (not no-values) variables)
(format t prefix)
(if variables
(loop for (var . value) in variables
do (if no-values
(format t "~% ~S" var)
(format t "~% ~S: ~S" var value)))
(format t "none")))
(defun tpl-variables-command (&optional no-values)
(let*((*print-level* 2)
(*print-length* 4)
(*print-pretty* t)
(*print-escape* nil)
(*print-readably* nil))
(multiple-value-bind (local-variables special-variables functions blocks restarts)
(ihs-environment *ihs-current*)
(format t "~:[~;Local functions: ~:*~{~s~^, ~}.~%~]" functions)
(format t "~:[~;Block names: ~:*~{~s~^, ~}.~%~]" blocks)
(when restarts
(format t "New restarts:")
(loop for r in restarts
do (format t "~% ~A: ~A" (restart-name r) r)))
(tpl-print-variables "~%Local variables: " local-variables no-values)
(tpl-print-variables "~%Special variables: "
special-variables no-values))
(terpri)
(values)))
(defun tpl-inspect-command (var-name)
(when (symbolp var-name)
(setq var-name (symbol-name var-name)))
(let ((val-pair (assoc var-name (decode-ihs-env *break-env*)
:test #'(lambda (s1 s2)
(when (symbolp s2) (setq s2 (symbol-name s2)))
(if (stringp s2)
(string-equal s1 s2)
nil)))))
(when val-pair
;;(format t "~&In tpl-inspect-command: val-pair = ~S~%" val-pair)
(let ((val (cdr val-pair)))
(inspect val)))))
(defun tpl-bds-command (&optional var)
(if var
(do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi))
(last (frs-bds (1+ *frs-top*))))
((> bi last)
(format t "Variable not found.~%")
(values))
(when (eq (bds-var bi) var)
(return (let ((val (bds-val bi)))
(if (eq val si::unbound) "<unbound value>" val)))))
(do ((bi (1+ (frs-bds (max 0 (1- *frs-base*)))) (1+ bi))
(last (frs-bds (1+ *frs-top*)))
(fi *frs-base*)
(*print-level* 2)
(*print-length* 4)
(*print-pretty* t))
((> bi last) (values))
(do ()
((or (> fi *frs-top*) (>= (frs-bds fi) bi)))
(print-frs fi)
(incf fi))
(format t "BDS[~d]: ~s = ~s~%"
bi (bds-var bi)
(let ((val (bds-val bi)))
(if (eq val si::unbound) "<unbound value>" val))))))
(defun tpl-backtrace (&optional n)
(let ((*print-pretty* nil) ;; because CLOS allows (setf foo) as function names
(base *ihs-base*)
(top *ihs-top*))
(format t "~&Backtrace:~%")
(if (null n)
(do ((i top (si::ihs-prev i))
;;(b nil t)
)
((< i base))
(when (ihs-visible i)
(let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE))
(*print-readably* nil)
(func-name (ihs-fname i)))
;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB
(format t " > ~S" func-name)
(when (eq func-name 'si::bytecodes)
(format t " [Evaluation of: ~S]"
(function-lambda-expression (ihs-fun i))))
(terpri)
)))
(progn
(if (eq t n)
(setq base 0)
(progn
(unless (integerp n)
(error "Argument to command :backtrace must be an integer or t."))
(setq top *ihs-current*)
)
)
(do ((i top (si::ihs-prev i))
;;(b nil t)
(j 0 (1+ j))
(max (if (eq t n) *ihs-top* n))
)
((or (< i base) (>= j max))
(when (zerop i) (format t " > ---end-of-stack---~%"))
)
(when (or (ihs-visible i) (eq t n))
(let ((*print-case* (if (= i *ihs-current*) :UPCASE :DOWNCASE))
(*print-readably* nil)
(func-name (ihs-fname i)))
;;(format t "~:[~; >~] ~S" b (ihs-fname i)) ;; JCB
(format t " > ~S" (ihs-fname i))
(when (eq func-name 'si::bytecodes)
(format t " [Evaluation of: ~S]"
(function-lambda-expression (ihs-fun i))))
(terpri)
))))
)
(terpri))
(values))
(defun tpl-frs-command (&optional n)
(unless n (setq n *ihs-top*))
(unless (integerp n)
(error "Argument to command :frs must be an integer."))
(do ((i *ihs-top* (si::ihs-prev i))
(k n (1- k)))
((= k 0) (values))
(let*((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*)))
(*print-level* 2)
(*print-length* 4)
(*print-pretty* t))
(do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
(print-frs j)
(incf j)))))
(defun print-frs (i)
(format *debug-io* " FRS[~d]: ---> IHS[~d],BDS[~d]~%"
i (frs-ihs i) (frs-bds i)))
(defun break-where ()
(if (<= *tpl-level* 0)
#-threads (format t "~&Top level.~%")
#+threads (format t "~&Top level in: ~A.~%" mp:*current-process*)
(tpl-print-current)))
(defun tpl-print-current ()
(let ((*print-readably* nil)
(name (ihs-fname *ihs-current*)))
(format t "~&Broken at ~:@(~S~)." name)
(when (eq name 'si::bytecodes)
(format t " [Evaluation of: ~S]"
(function-lambda-expression (ihs-fun *ihs-current*)))))
#-threads (terpri)
#+threads (format t " In: ~A.~%" mp:*current-process*)
(let ((fun (ihs-fun *ihs-current*)))
(when (and (symbolp fun) (fboundp fun))
(setf fun (fdefinition fun)))
(multiple-value-bind (file position)
(ext:compiled-function-file fun)
(when file
(format t " File: ~S (Position #~D)~%" file position))))
(values))
(defun tpl-hide (fname)
(unless (member fname *break-hidden-functions* :test #'eq)
(push fname *break-hidden-functions*)
(unless (ihs-visible *ihs-current*)
(set-current-ihs)))
(values))
(defun tpl-unhide (fname)
(setq *break-hidden-functions*
(delete fname *break-hidden-functions* :test #'eq))
(values))
(defun tpl-unhide-package (package)
(setq *break-hidden-packages*
(delete (find-package package) *break-hidden-packages* :test #'eq))
(values))
(defun tpl-unhide-all ()
(setq *break-hidden-functions* nil)
(setq *break-hidden-packages* nil)
(values))
(defun tpl-hide-package (package)
(setq package (find-package package))
(unless (member package *break-hidden-packages* :test #'eq)
(push package *break-hidden-packages*)
(unless (ihs-visible *ihs-current*)
(set-current-ihs)))
(values))
(defun ihs-visible (i)
(let ((fname (ihs-fname i)))
#+clos
(when (and (consp fname) (eq 'SETF (car fname)))
(setq fname (second fname)))
(or (eq fname 'EVAL)
(eq fname 'BYTECODES)
(and (not (member (symbol-package fname) *break-hidden-packages*
:TEST #'eq))
(not (null fname))
(not (member fname *break-hidden-functions* :TEST #'eq))))))
(defun ihs-fname (i)
(let ((function (ihs-fun i)))
(cond ((symbolp function) function)
((compiled-function-p function)
(or (compiled-function-name function) 'lambda))
#+clos
((si:instancep function) (slot-value function 'name))
(t :zombi))))
(defun set-current-ihs ()
(do ((i *ihs-current* (si::ihs-prev i)))
((or (and (ihs-visible i) (setq *ihs-current* i))
(<= i *ihs-base*))))
(set-break-env))
(defun set-break-env ()
(setq *break-env* (ihs-env *ihs-current*)))
(defun ihs-search (string unrestricted &optional (start (si::ihs-top)))
(do ((ihs start (si::ihs-prev ihs)))
((< ihs *ihs-base*)
(return nil))
(when (and (or unrestricted (ihs-visible ihs))
(search (string string) (symbol-name (ihs-fname ihs))
:test #'char-equal))
(return ihs))))
(defun tpl-backward-search (string)
(let ((new-ihs (ihs-search string nil *ihs-current*)))
(cond (new-ihs
(setf *ihs-current* new-ihs)
(set-current-ihs)
(tpl-print-current))
(t
(format *debug-io* "Search for ~a failed.~%" string)))
(values)))
(defun tpl-forward-search (string)
(do ((ihs (si::ihs-next *ihs-current*) (si::ihs-next ihs)))
((> ihs *ihs-top*)
(format *debug-io* "Search for ~a failed.~%" string))
(when (and (ihs-visible ihs)
(search string (symbol-name (ihs-fname ihs))
:test #'char-equal))
(setq *ihs-current* ihs)
(set-current-ihs)
(tpl-print-current)
(return)))
(values))
(defun tpl-apropos-command (&optional string pkg)
(when string (apropos string pkg)))
(defun tpl-document-command (&optional symbol)
(when symbol (help symbol)))
(defun tpl-step-command (&optional form)
(when form (step* form)))
(defun tpl-trace-command (&rest functions)
(trace* functions))
(defun tpl-untrace-command (&rest functions)
(untrace* functions))
(defparameter *tpl-last-load* nil)
(defun tpl-load-command (&rest files)
(when files
(setq *tpl-last-load* files))
(dolist (file *tpl-last-load*) (load file))
*tpl-last-load*)
(defparameter *tpl-last-compile* nil)
(defun tpl-compile-command (&rest files)
(when files
(setq *tpl-last-compile* files))
(dolist (file *tpl-last-compile*) (compile-file file))
(setq *tpl-last-load* *tpl-last-compile*))
(defun tpl-help-command (&optional topic)
(cond ((null topic)
(dolist (commands *tpl-commands*)
(format t "~%~A:~%" (car commands))
(dolist (c (cdr commands))
(when (fourth c)
(format t "~A.~%" (fourth c))))))
((or (stringp topic) (symbolp topic))
(let (c)
(setq topic (intern (string topic) (find-package 'keyword)))
(dolist (commands *tpl-commands*)
(when (setq c (assoc topic (cdr commands) :test #'member))
(return)))
(cond ((null (fifth c))
(format t "No such help topic: ~s~%"
(string topic)))
(t
(terpri)
(format t (fifth c))
(terpri)))))
(t
(format t "Not a valid help topic: ~s~%" topic)))
(values))
(defun tpl-help-stack-command ()
(format t "
Use the following functions to directly access ECL stacks.
Invocation History Stack:
(sys:IHS-TOP) Returns the index of the TOP of the IHS.
(SYS:IHS-FUN i) Returns the function of the i-th entity in IHS.
(SYS:IHS-ENV i)
(SYS:IHS-PREV i)
(SYS:IHS-NEXT i)
Frame (catch, block) Stack:
(sys:FRS-TOP) Returns the index of the TOP of the FRS.
(SYS:FRS-BDS i) Returns the BDS index of the i-th entity in FRS.
(SYS:FRS-IHS i) Returns the IHS index of the i-th entity in FRS.
(SYS:FRS-TAG i)
Binding Stack:
(sys:BDS-TOP) Returns the index of the TOP of the BDS.
(SYS:BDS-VAR i) Returns the symbol of the i-th entity in BDS.
(SYS:BDS-VAL i) Returns the value of the i-th entity in BDS.
Note that these functions are named by external symbols in the SYSTEM
package."
))
(defun compute-restart-commands (condition &key display)
(let ((restarts (compute-restarts condition))
(restart-commands (list "Restart commands")))
(when display
(format display (if restarts
"~&Available restarts:~2%"
"~&No restarts available.~%")))
(loop for restart in restarts
and i from 1
do (let ((user-command (format nil "r~D" i))
(name (format nil "~@[(~A)~]" (restart-name restart)))
(helpstring (princ-to-string restart)))
(push (list
(list (intern (string-upcase user-command) :keyword))
restart :restart
(format nil ":~A~16T~A~24T~A" user-command helpstring name)
(format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command)
"[Restart command]" name helpstring))
restart-commands)
(when display
(format display "~D. ~A ~A~%" i name restart))))
(when display (terpri display))
(nreverse restart-commands)))
(defun update-debug-commands (restart-commands)
(let ((commands (copy-list *tpl-commands*)))
(unless (member break-commands commands)
(setq commands (nconc commands (list break-commands)))
)
(delete-if
#'(lambda (x) (string= "Restart commands" (car x)))
commands)
(nconc commands (list restart-commands))))
(defparameter *default-debugger-maximum-depth* 16)
(defun check-default-debugger-runaway ()
(when (< *default-debugger-maximum-depth* *break-level*)
#+threads
(progn
(format *error-output*
"~&Excessive debugger depth! Probable infinite recursion!~%~
Quitting process: ~A.~%" mp:*current-process*)
(when (< (+ *default-debugger-maximum-depth* 3) *break-level*)
;; we tried to be polite but it does not seem to work.
(quit -1))
(exit-process))
#-threads
(progn
(format *error-output*
"~&Excessive debugger depth! Probable infinite recursion!~%~
Quitting.~%")
(quit -1))))
#+threads
(defun tpl-switch-command (&optional rank)
(let (elect)
(cond ((integerp rank)
(let ((max (list-length *console-waiting-list*)))
(unless (and (< 0 rank) (<= rank max))
(error "Debugger switch command: Invalid argument value.")))
(setf elect (elt *console-waiting-list* (1- rank))))
(t
(setf elect (find rank *console-waiting-list* :key #'mp:process-name))))
(when elect
(setq *console-owner* elect)))
(values))
#+threads
(defun tpl-waiting-command ()
(format t "~&~%Debugger's waiting list:~2%")
(loop for process in *console-waiting-list*
for rank from 1
do (format t (if (eq process mp:*current-process*)
" >~D: ~A~%"
" ~D: ~A~%")
rank process))
(terpri)
(values))
(defun default-debugger (condition)
(with-standard-io-syntax
(let* ((*standard-input* *debug-io*)
(*standard-output* *debug-io*)
;;(*tpl-prompt-hook* "[dbg] ")
(*print-readably* nil)
(*print-pretty* nil)
(*print-circle* t)
(*readtable* (or *break-readtable* *readtable*))
(*break-message* (format nil "~&Condition of type: ~A~%~A~%"
(type-of condition) condition))
(*break-level* (1+ *break-level*))
(break-level *break-level*)
(*break-env* nil))
(check-default-debugger-runaway)
#+threads
;; We give our process priority for grabbing the console.
(setq *console-owner* mp:*current-process*)
;; As of ECL 9.4.1 making a normal function return from the debugger
;; seems to be a very bad idea! Basically, it dumps core...
(when (listen *debug-io*)
(clear-input *debug-io*))
;; Like in SBCL, the error message is output through *error-output*
;; The rest of the interaction is performed through *debug-io*
(finish-output)
(fresh-line *error-output*)
(terpri *error-output*)
(princ *break-message* *error-output*)
(loop
;; Here we show a list of restarts and invoke the toplevel with
;; an extended set of commands which includes invoking the associated
;; restarts.
(let* ((restart-commands (compute-restart-commands condition :display t))
(debug-commands
;;(adjoin restart-commands (adjoin break-commands *tpl-commands*))
(update-debug-commands restart-commands)
))
(tpl :commands debug-commands))))))
(defun invoke-debugger (condition)
;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
;; called when the debugger is disabled. We adopt this mechanism
;; from SBCL.
#-ecl-min
(declare (c::policy-debug-ihs-frame))
(let ((old-hook *invoke-debugger-hook*))
(when old-hook
(let ((*invoke-debugger-hook* nil))
(funcall old-hook condition old-hook))))
(let* ((old-hook *debugger-hook*))
(when old-hook
(let ((*debugger-hook* nil))
(funcall old-hook condition old-hook))))
(locally
(declare (notinline default-debugger))
(if (<= 0 *tpl-level*) ;; Do we have a top-level REPL above us?
(default-debugger condition)
(let* (;; We do not have a si::top-level invocation above us
;; so we have to provide the environment for interactive use.
(*invoke-debugger-hook* *invoke-debugger-hook*)
(*debugger-hook* *debugger-hook*)
(*ihs-top* *ihs-top*) ;; Or should it be 1?
(*tpl-level* *tpl-level*) ;; Or should we simply say 0.
(*tpl-commands* *tpl-commands*)
+ ++ +++ - * ** *** / // ///)
(default-debugger condition))))
(finish-output))
(defun safe-eval (form env &optional (err-value nil err-value-p))
"Args: (FORM ENV &optional ERR-VALUE)
Evaluates FORM in the given environment, which may be NIL. If the form
signals an error, or tries to jump to an outer point, the function has two
choices: by default, it will invoke a debugger, but if a third value is
supplied, then SAFE-EVAL will not use a debugger but rather return that
value."
(let ((output nil) (ok nil))
(unwind-protect
(handler-bind ((serious-condition
(if err-value-p
#'(lambda (condition)
(declare (ignore condition))
(return-from safe-eval err-value))
#'invoke-debugger)))
(setf output (si::eval-with-env form env)
ok t))
(return-from safe-eval (if ok output err-value)))))