Adding indent.

2022-07-30 14:44:16 -07:00
parent 73d7181da2
commit 357bed3c1f
4 changed files with 145 additions and 32 deletions
--- a/common/forth_namespace_tests.fs
+++ b/common/forth_namespace_tests.fs
@ -139,6 +139,7 @@ e: check-boot

 e: check-tier2-opcodes
  out: >flags 
+  out: >flags& 
  out: >params 
  out: >size 
  out: >link& 
@ -396,6 +397,7 @@ e: check-utils
  out: str= 
  out: :noname 
  out: forget 
+  out: spaces 
  out: dump 
  out: assert 
 ;e
--- a/common/tier2_opcodes.h
+++ b/common/tier2_opcodes.h
@ -14,6 +14,7 @@

 #define TIER2_OPCODE_LIST \
  X(">flags", TOFLAGS, tos = *TOFLAGS(tos)) \
+  X(">flags&", TOFLAGSAT, tos = (cell_t) TOFLAGS(tos)) \
  X(">params", TOPARAMS, tos = *TOPARAMS(tos)) \
  X(">size", TOSIZE, tos = TOSIZE(tos)) \
  X(">link&", TOLINKAT, tos = (cell_t) TOLINK(tos)) \
--- a/common/utils.fs
+++ b/common/utils.fs
@ -21,14 +21,19 @@
 : dump ( a n -- )
   cr 0 do i 16 mod 0= if cr then dup i + c@ . loop drop cr ;

+( Print spaces )
+: spaces ( n -- ) for aft space then next ;
+
 ( Remove from Dictionary )
 : forget ( "name" ) ' dup >link current @ !  >name drop here - allot ;

 internals definitions
+1 constant IMMEDIATE_MARK
 2 constant SMUDGE
 4 constant BUILTIN_FORK
-1 constant IMMEDIATE_MARK
 16 constant NONAMED
+32 constant +TAB
+64 constant -TAB
 : mem= ( a a n -- f)
   for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ;
 forth definitions also internals
@ -39,28 +44,60 @@ forth definitions also internals
 : .s   ." <" depth n. ." > " raw.s cr ;
 only forth definitions

+( Tweak indent on branches )
+internals internalized definitions
+
+: flags'or! ( n -- ) ' >flags& dup >r c@ or r> c! ;
+TAB flags'or! BEGIN
+-TAB flags'or! AGAIN
+-TAB flags'or! UNTIL
+TAB flags'or! AHEAD
+-TAB flags'or! THEN
+TAB flags'or! IF
+TAB -TAB or flags'or! ELSE
+TAB -TAB or flags'or! WHILE
+-TAB flags'or! REPEAT
+TAB flags'or! AFT
+TAB flags'or! FOR
+-TAB flags'or! NEXT
+
+forth definitions 
+
 ( Definitions building to SEE and ORDER )
 internals definitions
+variable indent
 : see. ( xt -- ) >name type space ;
+: icr   cr indent @ 0 max 4* spaces ;
+: indent+! ( n -- ) indent +! icr ;
 : see-one ( xt -- xt+1 )
   dup cell+ swap @
   dup ['] DOLIT = if drop dup @ . cell+ exit then
-   dup ['] DOSET = if drop ." TO " dup @ cell - see. cell+ exit then
+   dup ['] DOSET = if drop ." TO " dup @ cell - see. cell+ icr exit then
   dup ['] DOFLIT = if drop dup sf@ <# [char] e hold #fs #> type space cell+ exit then
   dup ['] $@ = if drop ['] s" see.
                   dup @ dup >r >r dup cell+ r> type cell+ r> 1+ aligned +
                   [char] " emit space exit then
+   dup >flags -TAB AND if -1 indent+! then
+   dup see.
+   dup >flags +TAB AND if
+     1 indent+!
+   else
+     dup >flags -TAB AND if icr then
+   then
   dup  @ ['] BRANCH @ =
   over @ ['] 0BRANCH @ = or
   over @ ['] DONEXT @ = or
-       if see. cell+ exit then
-   see. ;
+       if swap cell+ swap then
+   drop
+;
 : see-loop   dup >body swap >params 1- cells over +
             begin 2dup < while swap see-one swap repeat 2drop ;
 : ?see-flags   >flags IMMEDIATE_MARK and if ." IMMEDIATE " then ;
 : see-xt ( xt -- )
  dup @ ['] see-loop @ = if
-    ['] : see.  dup see.  space dup see-loop   ['] ; see. ?see-flags cr  exit
+    ['] : see.  dup see.  1 indent !
+    icr dup see-loop   ['] ; see. ?see-flags cr
+    exit
  then
  dup >flags BUILTIN_FORK and if ." Built-in fork: " see. exit then
  dup @ ['] input-buffer @ = if ." CREATE/VARIABLE: " see. cr exit then
--- a/common/utils_tests.fs
+++ b/common/utils_tests.fs
@ -44,49 +44,80 @@ e: test-forget
 e: test-see-number
  : test 123 456 ;
  see test
-  out: : test  123 456 ; 
+  out: : test 
+  out:     123 456 ; 
 ;e

 e: test-see-string
  : test s" hello there" ;
  see test
-  out: : test  s" hello there" ; 
+  out: : test 
+  out:     s" hello there" ; 
 ;e

 e: test-see-begin-again
-  : test begin again ;
+  : test begin . again ;
  see test
-  out: : test  BEGIN AGAIN ; 
+  out: : test 
+  out:     BEGIN 
+  out:         . 
+  out:     AGAIN 
+  out:     ; 
 ;e

 e: test-see-begin-until
-  : test begin until ;
+  : test begin . until ;
  see test
-  out: : test  BEGIN UNTIL ; 
+  out: : test 
+  out:     BEGIN 
+  out:         . 
+  out:     UNTIL 
+  out:     ;  
 ;e

 e: test-see-begin-while-repeat
-  : test begin while repeat ;
+  : test begin . while . repeat ;
  see test
-  out: : test  BEGIN WHILE REPEAT ; 
+  out: : test 
+  out:     BEGIN 
+  out:         . 
+  out:     WHILE 
+  out:         . 
+  out:     REPEAT 
+  out:     ;  
 ;e

 e: test-see-ahead-then
-  : test ahead then ;
+  : test ahead . then ;
  see test
-  out: : test  AHEAD THEN ; 
+  out: : test 
+  out:     AHEAD 
+  out:         . 
+  out:     THEN 
+  out:     ; 
 ;e

 e: test-see-for-next
  : test for i . next ;
  see test
-  out: : test  FOR I . NEXT ; 
+  out: : test 
+  out:     FOR 
+  out:         I . 
+  out:     NEXT 
+  out:     ; 
 ;e

 e: test-see-for-aft-next
-  : test for aft i . then next ;
+  : test for aft i . then . next ;
  see test
-  out: : test  FOR AFT I . THEN NEXT ; 
+  out: : test 
+  out:     FOR 
+  out:         AFT 
+  out:             I . 
+  out:         THEN 
+  out:         . 
+  out:     NEXT 
+  out:     ; 
 ;e

 e: test-see-string-strides
@ -100,23 +131,59 @@ e: test-see-string-strides
  : test7 1 if ." ------>" then ;
  : test8 1 if ." ------->" then ;
  see test0
-  out: : test0  1 IF s" " type THEN ; 
+  out: : test0 
+  out:     1 IF 
+  out:         s" " type 
+  out:     THEN 
+  out:     ; 
  see test1
-  out: : test1  1 IF s" >" type THEN ; 
+  out: : test1 
+  out:     1 IF 
+  out:         s" >" type 
+  out:     THEN 
+  out:     ; 
  see test2
-  out: : test2  1 IF s" ->" type THEN ; 
+  out: : test2 
+  out:     1 IF 
+  out:         s" ->" type 
+  out:     THEN 
+  out:     ; 
  see test3
-  out: : test3  1 IF s" -->" type THEN ; 
+  out: : test3 
+  out:     1 IF 
+  out:         s" -->" type 
+  out:     THEN 
+  out:     ; 
  see test4
-  out: : test4  1 IF s" --->" type THEN ; 
+  out: : test4 
+  out:     1 IF 
+  out:         s" --->" type 
+  out:     THEN 
+  out:     ; 
  see test5
-  out: : test5  1 IF s" ---->" type THEN ; 
+  out: : test5 
+  out:     1 IF 
+  out:         s" ---->" type 
+  out:     THEN 
+  out:     ; 
  see test6
-  out: : test6  1 IF s" ----->" type THEN ; 
+  out: : test6 
+  out:     1 IF 
+  out:         s" ----->" type 
+  out:     THEN 
+  out:     ; 
  see test7
-  out: : test7  1 IF s" ------>" type THEN ; 
+  out: : test7 
+  out:     1 IF 
+  out:         s" ------>" type 
+  out:     THEN 
+  out:     ; 
  see test8
-  out: : test8  1 IF s" ------->" type THEN ; 
+  out: : test8 
+  out:     1 IF 
+  out:         s" ------->" type 
+  out:     THEN 
+  out:     ; 
 ;e

 e: test-noname
@ -131,32 +198,38 @@ e: test-see-variable
  variable foo
  : bar foo @ . ;
  see bar
-  out: : bar  foo @ . ; 
+  out: : bar 
+  out:     foo @ . ; 
 ;e

 e: test-see-create
  create foo
  : bar foo @ . ;
  see bar
-  out: : bar  foo @ . ; 
+  out: : bar 
+  out:     foo @ . ; 
 ;e

 e: test-see-value
  0 value foo
  : bar foo . ;
  see bar
-  out: : bar  foo . ; 
+  out: : bar 
+  out:     foo . ; 
 ;e

 e: test-see-to
  0 value foo
  : bar 123 to foo ;
  see bar
-  out: : bar  123 TO foo ; 
+  out: : bar 
+  out:     123 TO foo 
+  out:     ; 
 ;e

 e: test-see-immediate
  : foo 123 ; immediate
  see foo
-  out: : foo  123 ; IMMEDIATE 
+  out: : foo 
+  out:     123 ; IMMEDIATE 
 ;e