1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; and now
for something completely different
...
3 ;; UrForth
/C Forth Engine
!
4 ;; Copyright
(C
) 2023 Ketmar Dark
// Invisible Vector
6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 ;; interactive debugger
8 ;; optional
; not included by
default
9 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 $INCLUDE
-ONCE
<linore
.f
>
19 ;; task the we
're debugging now
25 0 VALUE source-name-stx
29 ;; are we on the alt (debugger) screen now?
34 FALSE VALUE DEBUG-SHOW-KEYS
37 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
41 ;; switch to alternative screen
50 TTY:RAW-TYPE \ TTY:RAW-FLUSH
55 ;; switch to main screen
63 TTY:RAW-TYPE TTY:RAW-FLUSH
69 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70 ;; replace standard emit
73 : (NEW-NORM-EMIT-CHAR) ( ch -- ch )
74 0xff AND ALT-SCR? IFNOT
80 OTHERWISE DROP [CHAR] ?
82 ELSE DUP 127 = IF DROP [CHAR] ? ENDIF
87 DEBUG:REPLACE (NORM-EMIT-CHAR) (NEW-NORM-EMIT-CHAR)
90 : (DEBUG-EMIT) ( ch -- )
91 ;; for alt-screen, prepend CR to LF
93 DUP NL = IF 13 TTY:RAW-EMIT ENDIF
97 ;; for main screen, flush on CR or LF
99 DUP NL = SWAP 10 = OR IF TTY:RAW-FLUSH ENDIF
104 DEBUG:REPLACE (EMIT) (DEBUG-EMIT)
107 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111 : SAME-SOURCE? ( addr count -- bool )
113 source-name-stx IF source-name-stx COUNT STRING:=
119 source-stx HANDLE:FREE 0-TO source-stx
120 source-name-stx HANDLE:FREE 0-TO source-name-stx
123 : LOAD-SOURCE-FILE ( addr count -- )
125 2DUP HANDLE:LOAD-FILE DUP TO source-stx
127 0 HANDLE:NEW TO source-name-stx
128 DUP 8 + source-name-stx HANDLE:SIZE!
129 DUP source-name-stx ! ;; counter
130 source-name-stx CELL+ SWAP MOVE
135 : LOAD-SOURCE ( addr count -- )
136 2DUP SAME-SOURCE? IF 2DROP
137 ELSE DUP 0> IF LOAD-SOURCE-FILE ELSE 2DROP ENDIF
142 : SOURCE-C@ ( ofs -- char )
144 DUP source-stx HANDLE:SIZE@ U< IF
154 : NORM-SOURCE-OFS ( ofs -- ofs )
155 source-stx IF 0 MAX source-stx HANDLE:SIZE@ MIN
160 : SOURCE-TO-BOL ( ofs -- ofs )
162 DUP 1- + SOURCE-C@ DUP 0= SWAP NL = OR
168 : SOURCE-TO-EOL ( ofs -- ofs )
170 DUP SOURCE-C@ DUP 0= SWAP NL = OR
177 : SOURCE-PREV-LINE ( ofs -- ofs )
178 1- SOURCE-TO-BOL NORM-SOURCE-OFS
182 : SOURCE-NEXT-LINE ( ofs -- ofs )
183 SOURCE-TO-EOL 1+ NORM-SOURCE-OFS
186 : FIND-SOURCE-LINE ( line -- ofs )
187 0 SWAP 1- FOR SOURCE-NEXT-LINE ENDFOR
190 : .-SOURCE-LINE ( ofs -- next-line-ofs )
193 DUP SOURCE-C@ DUP 0= OVER NL = OR
201 : SHOW-SOURCE-LINE ( addr count line -- )
204 R@ 8 - FIND-SOURCE-LINE
205 8 FOR .-SOURCE-LINE ENDFOR
206 ." \e[0;1m" .-SOURCE-LINE ." \e[0m"
207 8 FOR .-SOURCE-LINE ENDFOR
214 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
215 ;; M-F5 to show main screen
218 ALSO-DEFS: LINORE:OSC-ACTIONS
222 ALT-SCR? IF TO-MAIN-SCR ELSE TO-ALT-SCR ENDIF
226 // switch "show keys" mode
228 DEBUG-SHOW-KEYS NOT TO DEBUG-SHOW-KEYS
234 DEFER (LINORE-DRAW-PROMPT)
236 ;; return TRUE if key should be eaten
237 : (CHECK-KEY-ALT) ( flag -- FALSE / TRUE )
238 DROP ALT-SCR? IFNOT TO-ALT-SCR TRUE ELSE FALSE ENDIF
241 : (SHOW-KEYCODE) ( ch -- )
245 ." KEY: code: " DUP .
246 DUP 33 127 WITHIN IF ." char: " DUP XEMIT ENDIF
253 : (SHOW-OSC) ( addr count -- )
256 ." OSC-KEY(" DUP 0 U.R ." ): "
263 ..: LINORE:KEY-PROCESSOR ( ch FALSE -- ch FALSE / TRUE )
266 (CHECK-KEY-ALT) IF DROP TRUE ELSE FALSE ENDIF
267 DUP IFNOT >R DUP (SHOW-KEYCODE) R> ENDIF
272 ..: LINORE:OSC-KEY-PROCESSOR ( addr count FALSE -- addr count FALSE / TRUE )
275 (CHECK-KEY-ALT) IF 2DROP TRUE ELSE FALSE ENDIF
276 DUP IFNOT >R 2DUP (SHOW-OSC) R> ENDIF
281 ..: LINORE:ON-BEFORE-DRAW ( FALSE -- FALSE / TRUE )
285 DUP IFNOT (LINORE-DRAW-PROMPT) ENDIF
291 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
297 debuggee-stid MTASK:DEBUGGER-RESUME
302 debuggee-stid MTASK:DEBUGGER-SINGLE-STEP
306 : SHOW-CURRENT-WORD ( -- )
307 ." \r*** CURRENT WORD: "
308 debuggee-stid MTASK:STATE-IP@ DEBUG:IP->NFA ID-COUNT XTYPE CR
309 debuggee-stid MTASK:STATE-IP@ 6 U.R ." : "
310 debuggee-stid MTASK:STATE-IP@ @ ." [" 4 U.R ." ]: "
311 debuggee-stid MTASK:STATE-IP@ @ CFA->NFA ID-COUNT XTYPE CR
313 debuggee-stid MTASK:STATE-IP@ DEBUG:IP->FILE/LINE
314 ( ip -- addr count line TRUE / FALSE )
316 >R 2DUP R@ SHOW-SOURCE-LINE R>
317 ." line " . ." in `" XTYPE ." `" CR
321 : PROCESS-TASK-SWITCH ( action old-stid -- )
322 TO debuggee-stid DROP ;; drop action id
327 -1 OF ." yay, a breakpoint!" CR ENDOF
328 -2 OF ." yay, a single-step!" CR ENDOF
329 OTHERWISE " wutafuck?!" ERROR
332 BASE @ 10 <> " ass!" ?ERROR
333 STATE @ " hole!" ?ERROR
334 TRUE TO ALT-CLEAR TO-ALT-SCR FALSE TO ALT-CLEAR
340 0 VALUE STEP-FROM-LINE
341 0 VALUE STEP-FROM-FILE-HASH
342 0 VALUE STEP-FROM-FILE-NLEN
343 ;; used in step-l-over
344 0 VALUE STEP-CURR-NFA
345 0 VALUE STEP-OVER-LOOPS
348 ;; call before various dumps
350 FLUSH-EMIT CR TTY:RAW-FLUSH
353 : (.PUSH-ONE) ( n -- )
354 debuggee-stid MTASK:STATE-SP@ 1+ debuggee-stid MTASK:STATE-SP!
355 0 debuggee-stid MTASK:STATE-DS!
359 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
363 SIMPLE-VOCABULARY COMMANDS
373 debuggee-stid DEBUG:DUMP-STACK-TASK
379 debuggee-stid DEBUG:DUMP-RSTACK-TASK
385 debuggee-stid DEBUG:BACKTRACE-TASK
388 ;; drop value from the debuggee stack
390 debuggee-stid MTASK:STATE-SP@ DUP IF
391 1- debuggee-stid MTASK:STATE-SP!
392 debuggee-stid DEBUG:DUMP-STACK-TASK
393 ELSE DROP ." ERROR: debuggee stack is empty!" CR
397 ;; push value(s) to the debuggee stack
401 DEPTH debuggee-stid MTASK:STATE-SP@ + debuggee-stid MTASK:STATE-SP!
403 DEPTH FOR I debuggee-stid MTASK:STATE-DS! ENDFOR
404 debuggee-stid DEBUG:DUMP-STACK-TASK
405 ELSE ." ERROR: push what?" CR
409 ;; clear debugger data stack
414 ;; debugger data stack depth
416 ." debugger stack depth: " DEPTH . CR
420 TO-MAIN-SCR TTY:RAW-FLUSH
427 TO-MAIN-SCR TTY:RAW-FLUSH
434 TO-MAIN-SCR TTY:RAW-FLUSH
439 ;; run current line, stop when it changed
441 debuggee-stid MTASK:STATE-IP@ DEBUG:IP->FILE-HASH/LINE
442 // ( ip -- len hash line TRUE / FALSE )
445 TO STEP-FROM-FILE-HASH
446 TO STEP-FROM-FILE-NLEN
447 ;; now single-step until everything is the same
448 TO-MAIN-SCR TTY:RAW-FLUSH
451 ." line: " STEP-FROM-LINE .
452 ." hash: " STEP-FROM-FILE-HASH .
453 ." nlen: " STEP-FROM-FILE-NLEN .
454 ." ip: " debuggee-stid MTASK:STATE-IP@ .
459 debuggee-stid MTASK:DEBUGGER-SINGLE-STEP
460 TO debuggee-stid DROP ;; drop action id
461 debuggee-stid MTASK:STATE-IP@ DEBUG:IP->FILE-HASH/LINE
468 ." new-ip: " debuggee-stid MTASK:STATE-IP@ .
472 SWAP STEP-FROM-FILE-HASH = AND
473 SWAP STEP-FROM-FILE-NLEN = AND
478 -3 debuggee-stid ;; for PROCESS-TASK-SWITCH
484 ;; run current line, stop when we returned to the current word
485 : step-l-over ( over-loops -- )
487 ;; HACK: check for FORTH:(EXIT)
488 debuggee-stid MTASK:STATE-IP@ @
489 ['] FORTH
:(EXIT
) = IF step EXIT
ENDIF
490 debuggee
-stid MTASK
:STATE
-IP@ DEBUG
:IP
->FILE
-HASH
/LINE
491 // ( ip
-- len hash line TRUE
/ FALSE
)
494 TO STEP
-FROM
-FILE
-HASH
495 TO STEP
-FROM
-FILE
-NLEN
496 debuggee
-stid MTASK
:STATE
-IP@ DEBUG
:IP
->NFA
TO STEP
-CURR
-NFA
497 ;; now single
-step until everything is the same
498 TO-MAIN
-SCR TTY
:RAW
-FLUSH
502 debuggee
-stid MTASK
:DEBUGGER
-SINGLE
-STEP
503 TO debuggee
-stid DROP
;; drop action id
504 debuggee
-stid MTASK
:STATE
-IP@ DEBUG
:IP
->NFA
507 debuggee
-stid MTASK
:STATE
-IP@ DEBUG
:IP
->FILE
-HASH
/LINE
514 SWAP STEP
-FROM
-FILE
-HASH
= AND
515 SWAP STEP
-FROM
-FILE
-NLEN
= AND
521 -3 debuggee
-stid
;; for PROCESS
-TASK
-SWITCH
527 ;; run one forth instruction
, step when it changed
529 ;; HACK
: check
for FORTH
:(EXIT
)
530 debuggee
-stid MTASK
:STATE
-IP@ @
531 ['] FORTH:(EXIT) = IF step EXIT ENDIF
532 debuggee-stid MTASK:STATE-IP@ DEBUG:IP->NFA TO STEP-CURR-NFA
534 TO-MAIN-SCR TTY:RAW-FLUSH
538 debuggee-stid MTASK:DEBUGGER-SINGLE-STEP
539 TO debuggee-stid DROP ;; drop action id
540 debuggee-stid MTASK:STATE-IP@ DEBUG:IP->NFA
544 -3 debuggee-stid ;; for PROCESS-TASK-SWITCH
551 ." ? .source -- show source code (also enter)" CR
552 ." .s .stack -- dump debuggee data stack" CR
553 ." .r .rstack -- dump debuggee return stack" CR
554 ." bt -- show backtrace" CR
555 ." .drop -- drop value from debuggee data stack" CR
556 ." .push -- push values to debuggee data stack (use `:` to exec Forth in dbg)" CR
557 ." .dclear -- clear *debugger* data stack" CR
558 ." .depth -- print *debugger* data stack depth" CR
559 ." c continue -- leave debugger, continue program execution" CR
560 ." s step -- single-step (execute once Forth instruction)" CR
561 ." o step-over -- execute over once forth instruction (rstack check)" CR
562 ." q quit -- quit application" CR
563 ." step-line -- step over the current line (enter subroutines)" CR
564 ." step-l-over -- ( over-loops ) step over the current line (skip subroutines)" CR
571 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
572 ;; more LINORE hotkeys
575 ALSO-DEFS: LINORE:OSC-ACTIONS
578 : 18~ ( -- ) COMMANDS:step-line ;
580 : 19~ ( -- ) FALSE COMMANDS:step-over ;
582 : 32~ ( -- ) TRUE COMMANDS:step-over ;
587 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
588 ;; working with breakpoints
592 ;; breakpoint info in user buffer
593 16384 FORTH:(ADDR-TEMP-BIT) + CONSTANT BP-AREA
597 dd address ; 0: unused slot
598 dd old-value ; original value (~0: BP not set)
601 : (BP-REC) ( idx -- addr )
606 : BP-ADDR@ ( bpinfo -- addr ) @ ;
607 : BP-ADDR! ( value bpinfo -- ) ! ;
609 : BP-OLDVAL@ ( bpinfo -- oldval ) CELL+ @ ;
610 : BP-OLDVAL! ( value bpinfo -- ) CELL+ ! ;
613 : BP-ALLOC ( -- bpinfo )
615 I (BP-REC) @ IFNOT I (BP-REC) (UNLOOP) EXIT ENDIF
617 BP-USED (BP-REC) +1-TO BP-USED
620 : BP-FIND ( addr -- bpinfo / FALSE )
622 DUP I (BP-REC) @ = IF DROP I (BP-REC) (UNLOOP) EXIT ENDIF
626 ;; add new breakpoint
628 DUP BP-FIND IFNOT ;; create new breakpoint
629 BP-ALLOC 2DUP BP-ADDR! 0 BITNOT OVER BP-OLDVAL!
632 DUP BP-OLDVAL@ 0 BITNOT = IFNOT ;; not set yet
633 DUP BP-ADDR@ @ OVER BP-OLDVAL! ;; save old value
634 ['] DEBUG
:(BP
) SWAP BP
-ADDR@
! ;; and patch the code
640 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
644 : debugger
-draw
-prompt
( -- )
645 " \r\e[0;1;5m>\e[0m" TTY
:RAW
-TYPE
648 ' debugger-draw-prompt TO (LINORE-DRAW-PROMPT)
650 0 VALUE run-forth-ret-addr
652 : run-forth-done ( -- )
657 RP0! run-forth-ret-addr >R
660 ;; do not allow debugger to abort on bad forth word
661 ..: FORTH:(INTERPRET-WORD-NOT-FOUND) ( addr count FALSE -- addr count FALSE / TRUE )
663 DROP SPACE XTYPE ." ? -- wut?!" CR
669 ;; run Forth code in debugger context.
670 ;; this is used to execute all debugger commands, yay!
672 ;; set TIB and run one line
673 0 LINORE:LINE + C! ;; finish TIB with 0 byte
674 LINORE:LINE DROP TIB ! >IN 0! ;; setup TIB
675 ['] run
-forth
-done
(USER
-INTERPRET
-NEXT
-LINE
) !
676 R@
TO run
-forth
-ret
-addr
679 TIB @
>A BEGIN C@A
WHILE C@A XEMIT
+1>A REPEAT CR
688 : debugger
-main
-loop
( -- )
693 TTY
:SIZE DROP
TO LINORE
:DRAW
-WIDTH
694 \ LINORE
:VISIBLE
-AMOUNT
2* TO LINORE
:DRAW
-WIDTH
695 FLUSH
-EMIT LINORE
:EDIT
-LINE
696 LINORE
:ACCEPT
-RESULT
0<
698 LINORE
:ACCEPT
-RESULT LINORE
:RESULT
-ESC
<> IF
702 LINORE
:LINE NIP
0= IF " .source" LINORE
:LINE
! ENDIF
703 ONLY FORTH DEFINITIONS ALSO COMMANDS
709 : debugger
-startup \ multitask entry point
710 \
." yay, we are in debugger!" cr
711 \
." debugger stid: " MTASK
:ACTIVE
-STATE
. cr
712 ( ... argc old
-stid
)
713 SWAP
" wuta?!" ?ERROR
;; there should be no args
714 MTASK
:SET
-SELF
-AS
-DEBUGGER
715 0 SWAP MTASK
:YIELD
-TO ;; return to the caller
716 ['] debugger-main-loop EXECUTE-TAIL
720 : setup-debugger ( -- )
721 ['] debugger
-startup MTASK
:NEW
-STATE
TO debugger
-task
722 0 debugger
-task MTASK
:YIELD
-TO ;; init it
723 debugger
-task
<> " shit!" ?ERROR
724 " fuck!" ?ERROR
;; check number of args
730 DEBUGGER
:setup
-debugger