Add namespaces to Fift (#641)

* Add fift-based disassembler

* Fift improvements: namespaces, hashmaps, flow controls

* Fift: add lib with better block structuring and more

* Minor changes in fift HashMap + tests (#643)

* Minor changes in fift HashMap

* Add tests for extended fift

---------

Co-authored-by: OmicronTau <omicron@ton.org>
Co-authored-by: Tolya <1449561+tolya-yanot@users.noreply.github.com>
Co-authored-by: SpyCheese <mikle98@yandex.ru>

crypto/fift/lib/Asm.fif

@@ -1,12 +1,14 @@
 library TVM_Asm
 // simple TVM Assembler
+namespace Asm
+Asm definitions
 variable @atend
 variable @was-split
 false @was-split !
 { "not in asm context" abort } @atend !
 { `normal eq? not abort"must be terminated by }>" } : @normal?
-{ @atend @ 1 { @atend ! @normal? } does @atend ! } : @pushatend
-{ @pushatend <b } : <{
+{ context@ @atend @ 2 { @atend ! context! @normal? } does @atend ! } : @pushatend
+{ @pushatend Asm <b } : <{
 { @atend @ execute } : @endblk
 { false @was-split ! `normal @endblk } : }>
 { }> b> } : }>c
@@ -1219,7 +1221,10 @@ variable asm-mode  1 asm-mode !
 { 1 'nop does swap 0 (create) } : @declglobvar
 { @proccnt @ 1+ dup @proccnt ! 1 @declproc } : @newproc
 { @gvarcnt @ 1+ dup @gvarcnt ! @declglobvar } : @newglobvar
-{ 0 =: main  @proclist null!  @proccnt 0!  @gvarcnt 0!
+variable @oldcurrent  variable @oldctx
+Fift-wordlist dup @oldcurrent ! @oldctx !
+{ current@ @oldcurrent !  context@ @oldctx !  Asm definitions
+  0 =: main  @proclist null!  @proccnt 0!  @gvarcnt 0!
   { bl word @newproc } : NEWPROC
   { bl word dup (def?) ' drop ' @newproc cond } : DECLPROC
   { bl word dup find
@@ -1293,6 +1298,7 @@ variable asm-mode  1 asm-mode !
   } while
   drop @proclist null! @procinfo null! @proccnt 0!
   @procdict dup @ swap null!
+  @oldctx @ context!  @oldcurrent @ current!
 } : }END
 forget @proclist  forget @proccnt
 { }END <{ SETCP0 swap @procdictkeylen DICTPUSHCONST DICTIGETJMPZ 11 THROWARG }> } : }END>
@@ -1319,3 +1325,8 @@ forget @proclist  forget @proccnt
 { <b 2 8 u, swap 256 u, b>spec } : hash>libref
 // ( c -- c' )
 { hash hash>libref } : >libref
+
+Fift definitions Asm
+' <{ : <{
+' PROGRAM{ : PROGRAM{
+Fift

crypto/fift/lib/Disasm.fif

@@ -0,0 +1,141 @@
+library TVM_Disasm
+// simple TVM Disassembler
+"Lists.fif" include
+
+variable 'disasm
+{ 'disasm @ execute } : disasm  // disassemble a slice
+// usage: x{74B0} disasm
+
+variable @dismode  @dismode 0!
+{ rot over @ and rot xor swap ! } : andxor!
+{ -2 0 @dismode andxor! } : stack-disasm  // output 's1 s4 XCHG'
+{ -2 1 @dismode andxor! } : std-disasm    // output 'XCHG s1, s4'
+{ -3 2 @dismode andxor! } : show-vm-code
+{ -3 0 @dismode andxor! } : hide-vm-code
+{ @dismode @ 1 and 0= } : stack-disasm?
+
+variable @indent  @indent 0!
+{ ' space @indent @ 2* times } : .indent
+{ @indent 1+! } : +indent
+{ @indent 1-! } : -indent
+
+{ " " $pos } : spc-pos
+{ dup " " $pos swap "," $pos dup 0< { drop } {
+  over 0< { nip } { min } cond } cond
+} : spc-comma-pos
+{ { dup spc-pos 0= } { 1 $| nip } while } : -leading
+{ -leading -trailing dup spc-pos dup 0< {
+  drop dup $len { atom single } { drop nil } cond } {
+    $| swap atom swap -leading 2 { over spc-comma-pos dup 0>= } {
+      swap 1+ -rot $| 1 $| nip -leading rot
+    } while drop tuple
+  } cond
+} : parse-op
+{ dup "s-1" $= { drop "s(-1)" true } {
+  dup "s-2" $= { drop "s(-2)" true } {
+  dup 1 $| swap "x" $= { nip "x{" swap $+ +"}" true } {
+  2drop false } cond } cond } cond
+} : adj-op-arg
+{ over count over <= { drop } { 2dup [] adj-op-arg { swap []= } { drop } cond } cond } : adj-arg[]
+{ 1 adj-arg[] 2 adj-arg[] 3 adj-arg[]
+  dup first
+  dup `XCHG eq? {
+    drop dup count 2 = { tpop swap "s0" , swap , } if } {
+  dup `LSHIFT eq? {
+    drop dup count 2 = stack-disasm? and { second `LSHIFT# swap pair } if } {
+  dup `RSHIFT eq? {
+    drop dup count 2 = stack-disasm? and { second `RSHIFT# swap pair } if } {
+  drop 
+  } cond } cond } cond
+} : adjust-op
+
+variable @cp  @cp 0!
+variable @curop
+variable @contX  variable @contY  variable @cdict
+
+{ atom>$ type } : .atom
+{ dup first .atom dup count 1 > { space 0 over count 2- { 1+ 2dup [] type .", " } swap times 1+ [] type } { drop } cond } : std-show-op
+{ 0 over count 1- { 1+ 2dup [] type space } swap times drop first .atom } : stk-show-op
+{ @dismode @ 2 and { .indent ."// " @curop @ csr. } if } : .curop?
+{ .curop? .indent @dismode @ 1 and ' std-show-op ' stk-show-op cond cr
+} : show-simple-op
+{ dup 4 u@ 9 = { 8 u@+ swap 15 and 3 << s@ } {
+  dup 7 u@ 0x47 = { 7 u@+ nip 2 u@+ 7 u@+ -rot 3 << swap sr@ } {
+  dup 8 u@ 0x8A = { ref@ <s } {
+  abort"invalid PUSHCONT"
+  } cond } cond } cond
+} : get-cont-body
+{ 14 u@+ nip 10 u@+ ref@ dup rot pair swap <s empty? { drop null } if } : get-const-dict
+{ @contX @ @contY @ @contX ! @contY ! } : scont-swap
+{ .indent swap type type cr @contY @ @contY null! @contX @ @contX null!
+  +indent disasm -indent @contY !
+} : show-cont-bodyx
+{ ":<{" show-cont-bodyx .indent ."}>" cr } : show-cont-op
+{ swap scont-swap ":<{" show-cont-bodyx scont-swap
+  "" show-cont-bodyx .indent ."}>" cr } : show-cont2-op
+
+{ @contX @ null? { "CONT" show-cont-op } ifnot
+} : flush-contX
+{ @contY @ null? { scont-swap "CONT" show-cont-op scont-swap } ifnot
+} : flush-contY
+{ flush-contY flush-contX } : flush-cont
+{ @contX @ null? not } : have-cont?
+{ @contY @ null? not } : have-cont2?
+{ flush-contY @contY ! scont-swap } : save-cont-body
+
+{ @cdict ! } : save-const-dict
+{ @cdict null! } : flush-dict
+{ @cdict @ null? not } : have-dict?
+
+{ flush-cont .indent type .":<{" cr
+  @curop @ ref@ <s +indent disasm -indent .indent ."}>" cr
+} : show-ref-op
+{ flush-contY .indent rot type .":<{" cr
+  @curop @ ref@ <s @contX @ @contX null! rot ' swap if
+  +indent disasm -indent .indent swap type cr
+  +indent disasm -indent .indent ."}>" cr
+} : show-cont-ref-op
+{ flush-cont .indent swap type .":<{" cr
+  @curop @ ref@+ <s +indent disasm -indent .indent swap type cr
+  ref@ <s +indent disasm -indent .indent ."}>" cr
+} : show-ref2-op
+
+{ flush-cont first atom>$ dup 5 $| drop "DICTI" $= swap
+  .indent type ." {" cr +indent @cdict @ @cdict null! unpair
+  rot {
+    swap .indent . ."=> <{" cr +indent disasm -indent .indent ."}>" cr true
+  } swap ' idictforeach ' dictforeach cond drop 
+  -indent .indent ."}" cr
+} : show-const-dict-op
+
+( `PUSHCONT `PUSHREFCONT ) constant @PushContL
+( `REPEAT `UNTIL `IF `IFNOT `IFJMP `IFNOTJMP ) constant @CmdC1
+( `IFREF `IFNOTREF `IFJMPREF `IFNOTJMPREF `CALLREF `JMPREF ) constant @CmdR1
+( `DICTIGETJMP `DICTIGETJMPZ `DICTUGETJMP `DICTUGETJMPZ `DICTIGETEXEC `DICTUGETEXEC ) constant @JmpDictL
+{ dup first `DICTPUSHCONST eq? {
+    flush-cont @curop @ get-const-dict save-const-dict show-simple-op } {
+  dup first @JmpDictL list-member? have-dict? and {
+    flush-cont show-const-dict-op } {
+  flush-dict
+  dup first @PushContL list-member? {
+    drop @curop @ get-cont-body save-cont-body } {
+  dup first @CmdC1 list-member? have-cont? and {
+    flush-contY first atom>$ .curop? show-cont-op } {
+  dup first @CmdR1 list-member? {
+    flush-cont first atom>$ dup $len 3 - $| drop .curop? show-ref-op } {
+  dup first `WHILE eq? have-cont2? and {
+    drop "WHILE" "}>DO<{" .curop? show-cont2-op } {
+  dup first `IFELSE eq? have-cont2? and {
+    drop "IF" "}>ELSE<{" .curop? show-cont2-op } {
+  dup first dup `IFREFELSE eq? swap `IFELSEREF eq? or have-cont? and {
+    first `IFREFELSE eq? "IF" "}>ELSE<{" rot .curop? show-cont-ref-op } {
+  dup first `IFREFELSEREF eq? {
+    drop "IF" "}>ELSE<{" .curop? show-ref2-op } {
+    flush-cont show-simple-op
+  } cond } cond } cond } cond } cond } cond } cond } cond } cond
+} : show-op
+{ dup @cp @ (vmoplen) dup 0> { 65536 /mod swap sr@+ swap dup @cp @ (vmopdump) parse-op swap s> true } { drop false } cond } : fetch-one-op
+{ { fetch-one-op } { swap @curop ! adjust-op show-op } while } : disasm-slice
+{ { disasm-slice dup sbitrefs 1- or 0= } { ref@ <s } while flush-dict flush-cont } : disasm-chain
+{ @curop @ swap disasm-chain dup sbitrefs or { .indent ."Cannot disassemble: " csr. } { drop } cond @curop ! }
+'disasm !

crypto/fift/lib/Fift.fif

@@ -76,6 +76,8 @@ variable base
 { def? ' skip-to-eof if } : skip-ifdef
 { bl word dup (def?) { drop skip-to-eof } { 'nop swap 0 (create) } cond } : library
 { bl word dup (def?) { 2drop skip-to-eof } { swap 1 'nop does swap 0 (create) } cond } : library-version
+{ hole dup 1 'nop does swap 1 { context! } does bl word tuck 0 (create) +"-wordlist" 0 (create) } : namespace
+{ context@ current! } : definitions
 { char ) word "$" swap $+ 1 { find 0= abort"undefined parameter" execute } } ::_ $(
 // b s -- ?
 { sbitrefs rot brembitrefs rot >= -rot <= and } : s-fits?

crypto/fift/lib/FiftExt.fif

@@ -0,0 +1,118 @@
+{ ?dup { 1+ { execute } { 0 swap } cond } 
+       { (number) ?dup 0= abort"-?" 'nop } cond
+} : (interpret-prepare)
+{ { include-depth 0= (seekeof?) not } { 
+    (word-prefix-find) (interpret-prepare) (execute)
+  } while
+} : interpret
+{ ({)
+  { 0 (seekeof?) abort"no }" (word-prefix-find) (interpret-prepare) (compile) over atom? not } until
+  (}) swap execute
+} : begin-block
+{ swap 0 'nop } : end-block
+{ { 1 'nop } `{ begin-block } 
+{ { swap `{ eq? not abort"} without {" swap execute } end-block }
+:: } :: {
+
+// if{ ... }then{ ... }elseif{ ... }then{ ... }else{ ... }
+{ eq? not abort"unexpected" } : ?pairs
+{ dup `if eq? swap `ifnot eq? over or not abort"without if{" } : if-ifnot?
+// cond then ? -- exec
+{ { ' if } { ' ifnot } cond rot ({) 0 rot (compile) -rot 1 swap (compile) (})  
+} : (make-if)
+// cond then else -- exec
+{ rot ({) 0 rot (compile) -rot 2 ' cond (compile) (})
+} : (make-cond)
+{ `noelse `if begin-block } :: if{
+{ `noelse `ifnot begin-block } :: ifnot{
+{ 1 ' end-block does } : end-block-does
+{ { over `else eq? } {
+    nip rot if-ifnot? ' swap ifnot (make-cond)
+  } while
+  swap `noelse ?pairs 0 swap 
+} : finish-else-chain
+{ swap dup if-ifnot? drop `then {
+    swap `then ?pairs
+    swap if-ifnot? (make-if) finish-else-chain
+  } `{ begin-block
+} end-block-does :: }then{
+{ swap `{ ?pairs nip
+  swap `then eq? not abort"without }then{" `else
+} : ?else-ok
+{ ?else-ok { finish-else-chain } `{ begin-block } end-block-does :: }else{
+{ ?else-ok `if begin-block } end-block-does :: }elseif{
+{ ?else-ok `ifnot begin-block } end-block-does :: }elseifnot{
+
+// while{ ... }do{ ... }
+{ 2 ' while does } : (make-while)
+{ `while begin-block } :: while{
+{ swap `while eq? not abort"without while{" `while-do {
+    swap `while-do ?pairs (make-while) 0 swap
+  } `{ begin-block
+} end-block-does :: }do{
+
+// repeat{ ... }until{ ... }
+{ swap ({) 0 rot (compile) 0 rot (compile) (}) 1 ' until does } : (make-until) 
+{ `repeat begin-block } :: repeat{
+{ swap `repeat eq? not abort"without repeat{" `until {
+    swap `until ?pairs (make-until) 0 swap
+  } `{ begin-block
+} end-block-does :: }until{
+
+// def <name> { ... } instead of { ... } : <name>
+{ bl word swap bl word "{" $cmp abort"{ expected" `def {
+    swap `def ?pairs -rot 3 ' (create) 
+  } `{ begin-block
+} : (def)
+{ 0 (def) } :: def
+{ 1 (def) } :: def::
+
+// defrec <name> { ... } instead of recursive <name> { ... } swap !
+{ recursive bl word "{" $cmp abort"{ expected" `defrec {
+    swap `defrec ?pairs swap ! 0 'nop
+  } `{ begin-block
+} :: defrec
+
+def .sgn {
+  if{ ?dup 0= }then{
+    ."zero"
+  }elseif{ 0> }then{
+    ."positive" 
+  }else{
+    ."negative" 
+  } 
+  cr
+}
+// equivalent to: { ?dup 0= { ."zero" } { 0> { ."positive" } { ."negative" } cond } cond cr } : .sgn
+
+defrec fact {
+  if{ dup }then{
+    dup 1- fact *
+  }else{
+    drop 1
+  }
+}
+// equivalent to: recursive fact { dup { dup 1- fact * } { drop 1 } cond } swap !
+
+// [[ ... ]] computes arbitrary constants inside definitions
+//   { [[ 5 dup * ]] + } : add25
+// is equivalent to
+//   { 25 + } : add25
+{ "without [[" abort } box constant ']]
+{ ']] @ execute } : ]]
+{ { ']] @ 2 { ']] ! call/cc } does ']] !
+    interpret 'nop ']] ! "]] not found" abort
+  } call/cc
+  drop 1 'nop
+} :: [[
+
+{ { over @ swap 2 { call/cc } does swap !
+    interpret "literal to eof" abort
+  } call/cc
+  drop execute 1 'nop
+} : interpret-literal-to
+// use next line only if Lists.fif is loaded (or move it to Lists.fif if FiftExt.fif becomes part of Fift.fif)
+//   { ( ') interpret-literal-to } :: '(
+// then you can use list literals '( a b c ... ) inside definitions:
+//   { '( 1 2 3 ) } : test
+//   { '( ( `a { ."A" } ) ( `b { ."B" } ) ) assoc { cadr execute } { ."???" } cond } : test2