diff --git a/common/forth_namespace_tests.fs b/common/forth_namespace_tests.fs index fb754ea..acfa2fb 100644 --- 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 diff --git a/common/tier2_opcodes.h b/common/tier2_opcodes.h index 41bbafd..729fa42 100644 --- 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)) \ diff --git a/common/utils.fs b/common/utils.fs index 2483f46..d22cee8 100644 --- 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 diff --git a/common/utils_tests.fs b/common/utils_tests.fs index e2bbc0c..dfff49b 100644 --- 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