step-through debugger! level 6! level loading by number!

debug.jor

@@ -0,0 +1,98 @@
+( xp -- execution pointer - pointer to word definition
+  ip -- instruction pointer - pointer to pointer to word def
+  fp -- C function pointer used to drive the VM )
+
+var brk-xp
+var dbg-ip
+var dbg-task
+defer dbg-cmd
+
+: dbg-first-ip ( xp -- [ip|0] )
+  dup cell + swap @ ( worddata fp )
+  dup $DOCOLON = if drop else
+  dup $DOCREATE = if drop @ else
+  $DODEFERRED = if @ dbg-first-ip else
+  drop 0 then then then ;
+
+: tail :| rdrop dbg-first-ip >r |; , [ ' [ , ] ; immediate
+
+: get-dbg-xp ( ip -- xp ) brk-xp @ not if @ else drop brk-xp @ then ;
+: consume-dbg-xp ( ip -- xp ) get-dbg-xp 0 brk-xp ! ;
+
+: DBG-WAIT ( ip -- ip )
+  running dbg-task !
+  ' DBG-WAIT ' dbg-cmd redefine
+  dup dbg-ip !
+  suspend
+  ' dbg-cmd tail
+
+: .dbg ( ip -- ip )
+  cr dup .wordin s"  ip: " type dup . dup get-dbg-xp ` type cr
+  >r .s <r cr ;
+
+: debugger <r .dbg ' DBG-WAIT tail userword
+: debug ( xp -- ) dbg-first-ip .dbg ' DBG-WAIT tail userword
+
+: DBG-STEP-IN ( ip -- ip ) dup consume-dbg-xp swap emulate .dbg ' DBG-WAIT tail
+: DBG-STEP-OVER ( ip -- ip )
+  dup consume-dbg-xp swap over dbg-first-ip not if ( xp ip )
+    emulate ( is primitive - can't step over )
+  else
+    >r execute <r cell +
+  then .dbg ' DBG-WAIT tail
+: DBG-RUN-TO-END ( ip -- ) [ ' debugger dbg-first-ip lit ] >r >r ;
+: DBG-CONT ( ip -- ) >r ;
+
+: s ' DBG-STEP-IN ' dbg-cmd redefine ; userword
+: n ' DBG-STEP-OVER ' dbg-cmd redefine ; userword
+: c ' DBG-CONT ' dbg-cmd redefine ; userword
+: u ' DBG-RUN-TO-END ' dbg-cmd redefine ; userword
+: bt dbg-task @ task.bt ; userword
+: l dbg-ip @ decompile-from ; userword
+
+: bp.do 2 cells - ;
+: bp.ip ; immediate
+: bp.xp cell + ;
+
+( byte golfing is annoyingly satisfying - we don't need or want $DOCOLON
+  at the start nor ret at the end, so instead of using an inline function
+  or a :noname, we just turn on the compiler with "]" and go. )
+here ] bp.xp @ brk-xp ! <r cell - .dbg ' DBG-WAIT tail
+: bp, $DOCREATE , [ lit ] , 0 , 0 , ;
+
+array breakpoints bp, bp, bp, bp, bp,
+5 const MAX-BREAKPOINTS
+: breakpoint# ( n -- p ) 4 * 2 + cells breakpoints + ;
+
+: clear-breakpoint ( bp -- )
+  dup bp.ip @ if
+    dup bp.xp @ over bp.ip @ !
+    0 over bp.ip ! 0 swap bp.xp !
+  else drop then ;
+: set-breakpoint ( ip bp -- )
+  over if
+    2dup bp.ip !
+    over @ over bp.xp !
+    bp.do swap !
+  else drop drop then ;
+: reset-breakpoint ( ip bp -- ) dup clear-breakpoint set-breakpoint ;
+
+: free-breakpoint 0 MAX-BREAKPOINTS 0 for
+  i 1 - breakpoint# bp.ip @ not if
+    drop i 1 -
+  then next ;
+
+: set-next-breakpoint ( ip -- )
+  free-breakpoint >r r@ breakpoint# reset-breakpoint
+  <r s" bp " type . s" set" type cr ;
+
+: b word lookup drop dbg-first-ip dup if set-next-breakpoint
+  else s" word not found" type cr drop then ; userword
+: unb breakpoint# clear-breakpoint ; userword
+: .bp 0 MAX-BREAKPOINTS for
+    i .
+    i breakpoint# bp.ip @ dup .
+    ` type
+    i breakpoint# bp.xp @ ` type
+    cr
+  next ; userword

defs.jor

@@ -97,15 +97,13 @@
   begin r@ while <r <r swap ! repeat rdrop ;
 : preserve ( cp var -- ) 0 swap preserves ;
 
+: decompile-from ( ip -- )
+  begin dup @ ' ret != while
+    dup @ dup ` dup if type drop else drop . then bl
+    cell +
+  repeat drop ;
 
-: decompile
+: decompile word lookup if cell + decompile-from else drop then ; userword
-  word lookup if 1 begin ( cp i )
-    2dup cells + @ ( cp i @cp+i )
-    dup ' ret != ( cp i @cp+i bool )
-  while
-    dup ` dup if type drop else drop . then bl ( cp i )
-    1 + ( cp i+1 )
-  repeat drop drop then drop ; userword
 
 : words
   latest links each
@@ -139,6 +137,11 @@
     begin 2dup > while dup @ . cell + repeat
     cr drop drop more ; userword
 
+: task.bt ( task -- )
+  dup task-rsp @ swap task-rstack ( rstackLim rstack )
+  begin 2dup > while dup @ dup . .wordin cr cell + repeat
+  drop drop ; userword
+
 : doactivate ( task ip -- )
   over task-ip !
   dup task-stack over task-sp !

gameboot.jor

@@ -28,19 +28,15 @@ s" map.jor" loadfile
 s" state.jor" loadfile
 s" jiles.jor" loadfile
 s" job.jor" loadfile
+s" level.jor" loadfile
 s" game.jor" loadfile
+s" debug.jor" loadfile
 ; execute
 
-intern lev00001.jor
+' load-new-level checkpoint _loadlevel
-intern lev00002.jor
-intern lev00003.jor
-intern lev00004.jor
-intern lev00005.jor
-intern end.jor
-
-:noname loadfile ; checkpoint _loadlevel
 ' _loadlevel ' loadlevel redefine
 
-lev00005.jor loadlevel
+reset-level
+6 loadlevel
 
 draw unfuck load-footer

jorth.c

@@ -1077,6 +1077,18 @@ void f_rand() {
   PUSHI(rand());
 }
 
+// debugger support - emulate running the given word as if it had been
+// executed from inside the part of the definition pointed to by ip
+void f_emulate() { // cp ip -- ip
+  cell oldIP = IP;
+  IP = TOP();
+  DROP(1);
+  IP.p++;
+  f_execute();
+  PUSHP(IP.p);
+  IP = oldIP;
+}
+
 void f_init(char *exe) {
   f_calc_imagemagic(exe);
 
@@ -1208,6 +1220,7 @@ void f_init(char *exe) {
   CDEF("rstacksize", f_rstacksize);
   CDEF("task-user-size", f_taskusersize);
   CDEF("rand", f_rand);
+  CDEF("emulate", f_emulate);
   PCONST("$DOCREATE", f_docreate);
   PCONST("$DOVAR", f_dovar);
   PCONST("$DODEFERRED", f_dodeferred);

lev00001.jor

@@ -24,7 +24,7 @@ defer last-term
 ' c1 1 4 computer c2
 ' c2 ' last-term redefine
 
-lev00002.jor 10 0 exitdoor dexit
+2 10 0 exitdoor dexit
 ' dexit 9 0 scanner sexit
 
 d1 :noname
@@ -61,7 +61,6 @@ sexit :noname
 
 :noname O
 
-  s" lev00001.map" load-map
   0 player.state HASNEUT f!
   14 9 tile>world Jaye entity.pos!
   c1 entity>pos Neut entity.pos!

lev00002.jor

@@ -13,7 +13,7 @@ objects: O
 2 6 door d9
 4 2 door d10
 
-lev00003.jor 7 0 exitdoor dx
+3 7 0 exitdoor dx
 ' dx 6 0 scanner sx
 
 defer c10 ' c10 5 1 computer cx
@@ -50,7 +50,6 @@ c2 :noname
 
 :noname O
 
-  s" lev00002.map" load-map
   11 11 tile>world Jaye entity.pos!
   10 12 tile>world Neut entity.pos!
 

lev00003.jor

@@ -17,7 +17,7 @@ defer c1 ' c1 8 3 computer c3
 ' c3 12 11 computer c2
 ' c2 5 7 computer _c1 ' _c1 ' c1 redefine
 
-lev00004.jor 0 4 exitdoor dx
+4 0 4 exitdoor dx
 ' dx 0 5 scanner sx
 
 5 2 defrexx Rexx
@@ -120,7 +120,6 @@ var gord-up
     gord say" Let's go."
   then |; listener!
 
-  s" lev00003.map" load-map
   7 11 tile>world Jaye entity.pos!
   6 12 tile>world Neut entity.pos!
   6 7  tile>world Gord entity.pos!

lev00004.jor

@@ -5,7 +5,7 @@ objects: O
 15 6 door d1
 11 6 door d2
 10 4 door d3
-lev00005.jor 0 4 exitdoor dx
+5 0 4 exitdoor dx
 
 15 11 defrexx Rexx
 
@@ -36,7 +36,6 @@ var first-gord-sit
      then
   |; ' on-gord-sit redefine
 
-  s" lev00004.map" load-map
   18 4 tile>world Jaye entity.pos!
   19 5 tile>world Neut entity.pos!
   with-gord

lev00005.jor

@@ -11,7 +11,7 @@ lazy 60 over 19 9 timedswitch ts
 10 9 door d2
 5 6 door d3 >lazy!
 10 2 door d4
-end.jor 5 12 exitdoor dx
+LEV_END 5 12 exitdoor dx
 
 lazy dup 11 3 computer c1
 ' c1 7 11 computer c2 >lazy!
@@ -104,7 +104,6 @@ d2 :noname
 
   ' touch ' touch-override redefine
 
-  s" lev00005.map" load-map
   18 4 tile>world Jaye entity.pos!
   19 5 tile>world Neut entity.pos!
   with-gord

lev00006.jor

@@ -0,0 +1,8 @@
+( L E V E L 0 0 0 0 6 )
+
+:noname
+  5 1 tile>world Jaye entity.pos!
+  4 0 tile>world Neut entity.pos!
+  with-gord
+
+; ' onload redefine

level.jor

@@ -0,0 +1,40 @@
+array levelfile 13 allot
+var ilevelfile
+: emit-levelfile ( c -- )
+  dup sp != if
+    ilevelfile @ levelfile + b!
+    1 ilevelfile +!
+    0 ilevelfile @ levelfile + b!
+  else drop then ;
+
+: 0padplace ( n place -- ) < if [ key 0 lit ] emit then ;
+: 0pad ( n -- )
+  dup 10 0padplace
+  dup 100 0padplace
+  dup 1000 0padplace
+  dup 10000 0padplace
+  . ;
+
+: genlevelfn ( n ext -- s )
+  0 ilevelfile !
+  task-emit @ >rot ' emit-levelfile task-emit !
+  s" lev" type swap 0pad type
+  task-emit ! levelfile ;
+
+: levelsrc ( n -- ) s" .jor" genlevelfn ;
+: levelmap ( n -- ) s" .map" genlevelfn ;
+
+intern end.jor
+
+-1 const LEV_END
+
+var current-level
+: load-new-level ( n -- )
+  dup current-level !
+  dup 0 > if dup levelmap load-map then
+  dup LEV_END =
+    if drop end.jor
+    else levelsrc
+    then loadfile ;
+
+: save-level ( -- ) current-level @ levelmap save-map ;

map.jor

@@ -27,13 +27,14 @@ array tileflags
 ( 14:chair-brok )      RUBBLE b,
 ( 15:bookcase )        0 b,
 ( 16:bookcase-broke )  RUBBLE b,
-( 17:scattered books ) WALKABLE b,
+( 17:scattered books ) WALKABLE RUBBLE | b,
 ( 18:plant )           0 b,
 ( 19:tipped plant )    RUBBLE b,
 ( 20:scanner-off )     NEUTABLE b,
 ( 21:scanner-on )      NEUTABLE b,
 ( 22:cracked-wall )    0 b,
 ( 23:rexx-pod )        NEUTABLE b,
+( 24:keypad )          NEUTABLE b,
 
 here tileflags - 1 - const MAXTILE
 

testbed.c

@@ -764,7 +764,6 @@ int main(int argc, char *argv[]) {
   while (!keyIsDown(K_ESC)) {
     kbd_debounce();
     f_poll();
-    f_taskloop();
     f_execcp(tick);
     f_taskloop();
     f_execcp(draw);