Nock extended tests: nock-2,6,7,8,9 + fix nock-9

Makefile

@@ -0,0 +1,10 @@
+.PHONY: test test-long
+
+# Fast unit tests: Nock primitives + noun literal syntax (~5 min total)
+test:
+	bash tests/test-nock.sh
+
+# Long-running benchmark tests (urbit/benchmark reference cases).
+# Each test spawns a full urbit eval + nock.fs load; expect O(minutes) per test.
+test-long:
+	bash tests/test-nock-long.sh

desk/lib/north.hoon

@@ -57,6 +57,7 @@
       [%str-lit text=tape]   ::  S" text" — store in mem, push c-addr and count
       [%dot-str text=tape]   ::  ." text" — append directly to output buffer
       [%of-branch offset=@s] ::  OF: pop val, compare with NOS selector; equal→drop+go, else→jump
+      [%defer name=cord]     ::  DEFER: allocate xt cell, define indirect word
   ==
 +$  prog  (list token)
 :: Tier 0: Stack Manipulation
@@ -551,6 +552,11 @@
     =/  len  (fetch addr mem.st)
     ?>  ?=(@ len)
     st(d-stack (push (push ds (inc:ua addr)) ^-(@ len)))
+  ::  Tier 21: NOOP, -ROT, CHARS, CELL
+  ?:  =(w 'NOOP')    st
+  ?:  =(w '-ROT')    st(d-stack (rot (rot ds)))
+  ?:  =(w 'CHARS')   st   ::  cell size = 1, identity like CELLS
+  ?:  =(w 'CELL')    st(d-stack (push ds 1))
   ::  Tier 20: IMMEDIATE — mark last-defined word as immediate
   ?:  =(w 'IMMEDIATE')
     =/  lname  last-def.settings.st
@@ -641,6 +647,23 @@
         ?>  ?=([%word *] nxt)
         =/  addr  here.settings.st
         $(ip (add:ua ip 2), st st(dict (dict-add w.nxt ~[[%num n=addr]] dict.st), settings settings.st(last-create w.nxt)))
+      ::  Tier 21: EXIT — return from current word immediately
+      ?:  =(w.tok 'EXIT')  st
+      ::  Tier 21: IS — store xt in deferred word's data cell
+      ::  ( xt -- )  reads next token as deferred word name
+      ?:  =(w.tok 'IS')
+        ?>  (lth:ua +(ip) n)
+        =/  nxt  (snag-prog +(ip) p)
+        ?>  ?=([%word *] nxt)
+        =/  target  (crip (cuss (trip w.nxt)))
+        =/  body   (find-word-body target dict.st)
+        ?~  body  !!
+        ?>  ?=(^ u.body)
+        ?>  ?=([%num *] i.u.body)
+        =/  addr  n.i.u.body
+        =/  ds    d-stack.st
+        =^  xt=@  ds  (pop ds)
+        $(ip (add:ua ip 2), st st(d-stack ds, mem (store mem.st addr xt)))
       ::  User-defined defining word (has %does-gt in body): consume next token as name-to-create
       ?:  (is-defining-word w.tok dict.st)
         ?:  (gte:ua (inc:ua ip) n)
@@ -717,6 +740,13 @@
       =/  ds  d-stack.st
       =^  val=@  ds  (pop ds)
       $(ip +(ip), st st(d-stack ds, dict (dict-add name.tok ~[[%num n=val]] dict.st)))
+    %defer
+      ::  Allocate one cell at HERE; store default xt 'NOOP'; define indirect word
+      ::  The defined word's body: [push data-addr] [@ ] [EXECUTE]
+      =/  addr  here.settings.st
+      =/  st1   (comma 'NOOP' st)
+      =/  body  ~[[%num n=addr] [%word w='@'] [%word w='EXECUTE']]
+      $(ip +(ip), st st1(dict (dict-add name.tok body dict.st1)))
     %does-gt
       ::  Append tokens after DOES> to the last-created word's body.
       ::  Jumps to end of the current program (exits the defining word's eval).
@@ -1144,6 +1174,64 @@
   =/  b  (parse-bin t)
   ?^  b  b
   (parse-dec t)
+:: PARSE-NOUN-TOK - parse one Nock noun from a word list
+::   Atom:  N      → [%num N] [%word MAKE-ATOM]
+::   Cell:  [ ...] → (parse-cell-items ...)
+::   Returns [emitted-tokens remaining-words]
+++  parse-noun-tok
+  |=  words=(list tape)
+  ^-  [prog (list tape)]
+  ?~  words  [~ ~]
+  =/  wu  (crip (cuss i.words))
+  ?:  =(wu '[')
+    (parse-cell-items t.words)
+  ?:  =(wu ']')
+    [~ words]
+  =/  n  (parse-num (trip wu))
+  ?~  n  [~ words]
+  [~[[%num n=u.n] [%word w='MAKE-ATOM']] t.words]
+:: PARSE-CELL-ITEMS - collect noun items until ], fold right-associatively
+::   Reads items by calling parse-noun-tok until ] or unknown token.
+::   Returns [noun-tokens remaining-words-after-]]
+++  parse-cell-items
+  |=  words=(list tape)
+  ^-  [prog (list tape)]
+  =|  items=(list prog)
+  =|  cnt=@ud
+  |-
+  ?~  words
+    [(build-noun-toks (flop items) cnt) ~]
+  =/  wu  (crip (cuss i.words))
+  ?:  =(wu ']')
+    [(build-noun-toks (flop items) cnt) t.words]
+  =/  res   (parse-noun-tok words)
+  =/  item=prog            -.res
+  =/  words-next=(list tape)  +.res
+  ?~  item
+    [(build-noun-toks (flop items) cnt) words-next]
+  $(words words-next, items [item items], cnt +(cnt))
+:: BUILD-NOUN-TOKS - fold n item-token-lists into right-associative noun tokens
+::   For n items pushed left-to-right, (n-1) MAKE-CELL calls right-folds them:
+::   [a b c] → a b c make-cell make-cell = [a [b c]]
+++  build-noun-toks
+  |=  [items=(list (list token)) n=@ud]
+  ^-  (list token)
+  ?:  =(0 n)  ~
+  ?:  =(1 n)
+    ?~  items  ~
+    i.items
+  ::  flatten all item token lists into one sequence
+  =/  flat=prog
+    =|  acc=prog
+    |-
+    ?~  items  acc
+    $(items t.items, acc (welp acc i.items))
+  ::  append (n-1) MAKE-CELL tokens
+  =|  cells=prog
+  =/  i  (dec n)
+  |-
+  ?:  =(0 i)  (welp flat cells)
+  $(i (dec i), cells [[%word w='MAKE-CELL'] cells])
 :: PARSE - compile Forth source tape to prog
 ::  Handles: numbers (dec/hex/bin), words, : ; ' ( comments
 ::  Control flow: IF ELSE THEN, BEGIN AGAIN UNTIL, BEGIN WHILE REPEAT
@@ -1190,6 +1278,15 @@
   ?:  =(wu 'CONSTANT')
     ?~  rest  out
     $(words t.rest, out (weld out ~[[%constant name=(crip (cuss i.rest))]]))
+  ::  DEFER: next token is name; allocates xt cell, defines indirect word
+  ?:  =(wu 'DEFER')
+    ?~  rest  out
+    $(words t.rest, out (weld out ~[[%defer name=(crip (cuss i.rest))]]))
+  ::  [CHAR]: next token is a word; push ASCII value of its first character
+  ?:  =(wu '[CHAR]')
+    ?~  rest  out
+    ?>  ?=(^ i.rest)
+    $(words t.rest, out (weld out ~[[%num n=^-(@ i.i.rest)]]))
   ::  Tick: push xt without executing
   ?:  =(wu '\'')
     ?~  rest  out

tests/nock.fs

@@ -0,0 +1,248 @@
+\ Nock interpreter in North Forth
+\ Ported from https://github.com/mopfel-winrux/forth-nock/blob/main/nock.fs
+\ Bigint library removed — Hoon atoms are already arbitrary precision,
+\ so all values are plain Forth integers.
+
+\ ── Memory layout for nouns ──────────────────────────────────────────────
+\ Atoms:  [tag=0, value]          (2 cells)
+\ Cells:  [tag=1, head-addr, tail-addr]  (3 cells)
+
+: field+  ( addr -- addr' )  CELL+ ;   \ advance by one cell (cell size = 1)
+
+: make-cell  ( head tail -- addr )
+    SWAP
+    HERE >R
+    1 ,
+    , ,
+    R> ;
+
+: make-atom  ( n -- addr )
+    HERE >R
+    0 ,
+    ,
+    R> ;
+
+: is-cell?  ( addr -- flag )  @ 1 = IF 1 ELSE 0 THEN ;
+: get-value  ( addr -- n )    field+ @ ;
+: get-head   ( addr -- addr ) field+ @ ;
+: get-tail   ( addr -- addr ) field+ field+ @ ;
+
+DEFER .NOUN
+
+: print-noun  ( addr -- )
+    dup is-cell?
+    IF
+        [CHAR] [ EMIT
+        dup get-head RECURSE
+        BL EMIT
+        get-tail RECURSE
+        [CHAR] ] EMIT  BL EMIT
+    ELSE
+        get-value .
+    THEN ;
+
+: .noun-dup  ( addr -- addr )  dup print-noun ;
+' .noun-dup IS .NOUN
+
+\ ── Nock operators ───────────────────────────────────────────────────────
+
+\ wut ?  — 0 if cell, 1 if atom
+: wut  ( addr -- n )
+    is-cell? IF 0 ELSE 1 THEN ;
+
+\ lus +  — increment atom
+: lus  ( addr -- addr )
+    dup is-cell? IF
+        CR .NOUN DROP 99 THROW
+    ELSE
+        get-value 1+ make-atom
+    THEN ;
+
+\ tis =  — equality (0=equal, 1=not-equal); result is an atom-noun addr
+DEFER tis
+
+: do-tis  ( addr1 addr2 -- addr )
+    over is-cell? over is-cell? <> IF
+        2drop 1 make-atom EXIT
+    THEN
+    over is-cell? IF
+        2dup
+        2dup get-head SWAP get-head tis
+        get-value 0 = IF
+            2drop get-tail SWAP get-tail tis
+        ELSE
+            2drop 2drop 1 make-atom
+        THEN
+    ELSE
+        get-value SWAP get-value = IF 0 ELSE 1 THEN make-atom
+    THEN ;
+
+' do-tis IS tis
+
+\ slot /  — tree addressing
+DEFER slot
+
+: do-slot  ( n-addr addr -- addr )
+    SWAP get-value
+    dup 1 = IF
+        drop
+    ELSE dup 2 = IF
+        drop get-head
+    ELSE dup 3 = IF
+        drop get-tail
+    ELSE
+        dup 2 MOD 0 = IF
+            2 / make-atom SWAP slot
+            2 make-atom SWAP slot
+        ELSE
+            1- 2 / make-atom SWAP slot
+            3 make-atom SWAP slot
+        THEN
+    THEN THEN THEN ;
+
+' do-slot IS slot
+
+\ hax #  — replace at axis
+DEFER hax
+
+: do-hax  ( n-addr new-val target -- addr )
+    -ROT SWAP
+    dup get-value 1 = IF
+        drop nip
+    ELSE
+        get-value
+        dup 2 MOD 0 = IF
+            2 / >R
+            SWAP dup
+            R@ 2 * 1+ make-atom SWAP slot
+            ROT SWAP make-cell
+            SWAP R>
+            make-atom -ROT
+            hax
+        ELSE
+            1- 2 / >R
+            SWAP dup
+            R@ 2 * make-atom SWAP slot
+            ROT make-cell
+            SWAP R>
+            make-atom -ROT
+            hax
+        THEN
+    THEN ;
+
+' do-hax IS hax
+
+\ tar *  — main Nock reduction
+DEFER tar
+
+: autocons  ( subject [b c] -- [*[a b] *[a c]] )
+    dup -ROT
+    dup get-head SWAP get-tail get-head make-cell tar
+    SWAP
+    dup get-head SWAP get-tail get-tail make-cell tar
+    make-cell ;
+
+: nock-0  ( subject formula -- result )   \ [a 0 b] -> /[b a]
+    get-tail get-tail SWAP slot ;
+
+: nock-1  ( subject formula -- result )   \ [a 1 b] -> b
+    SWAP DROP get-tail get-tail ;
+
+: nock-2  ( subject formula -- result )   \ [a 2 b c] -> *[*[a b] *[a c]]
+    dup get-tail get-tail get-head
+    >R SWAP R> make-cell tar SWAP
+    dup get-head SWAP
+    get-tail get-tail get-tail make-cell tar
+    make-cell tar ;
+
+: nock-3  ( subject formula -- result )   \ [a 3 b] -> ?*[a b]
+    get-tail get-tail make-cell tar wut make-atom ;
+
+: nock-4  ( subject formula -- result )   \ [a 4 b] -> +*[a b]
+    get-tail get-tail make-cell tar lus ;
+
+: nock-5  ( subject formula -- result )   \ [a 5 b c] -> =*[a b] =*[a c]
+    get-tail get-tail make-cell tar
+    dup get-head SWAP get-tail
+    tis ;
+
+: nock-6  ( subject formula -- result )   \ [a 6 b c d] -> if *[a b] then *[a c] else *[a d]
+    over over get-tail get-tail get-head make-cell tar
+    get-value 0 = IF
+        get-tail get-tail get-tail get-head make-cell tar
+    ELSE
+        get-tail get-tail get-tail get-tail make-cell tar
+    THEN ;
+
+: nock-7  ( subject formula -- result )   \ [a 7 b c] -> *[*[a b] c]
+    dup -ROT
+    get-tail get-tail get-head make-cell tar
+    SWAP get-tail get-tail get-tail make-cell tar ;
+
+: nock-8  ( subject formula -- result )   \ [a 8 b c] -> *[[*[a b] a] c]
+    dup -ROT
+    get-tail get-tail get-head make-cell tar
+    over get-head make-cell
+    SWAP get-tail get-tail get-tail
+    make-cell tar ;
+
+: nock-9  ( subject formula -- result )   \ [a 9 b c] -> *[*[a c] 2 [0 1] 0 b]
+    dup -ROT
+    get-tail get-tail get-tail make-cell tar
+    SWAP get-tail get-tail get-head >R
+    2 make-atom
+    0 make-atom 1 make-atom make-cell
+    0 make-atom R> make-cell
+    make-cell make-cell make-cell
+    tar ;
+
+: nock-10  ( subject formula -- result )  \ [a 10 [b c] d] -> #[b *[a c] *[a d]]
+    over
+    over get-tail get-tail get-head
+    dup get-head >R
+    get-tail make-cell tar
+    >R
+    get-tail get-tail get-tail make-cell tar
+    R> R> -ROT SWAP
+    hax ;
+
+: nock-11  ( subject formula -- result )  \ hint
+    dup get-tail get-tail get-head
+    is-cell? IF
+        2dup
+        get-tail get-tail get-head get-tail make-cell tar
+        -ROT
+        get-tail get-tail get-tail make-cell tar
+        make-cell 0 make-atom 3 make-atom make-cell make-cell tar
+    ELSE
+        get-tail get-tail get-tail make-cell tar
+    THEN ;
+
+: do-tar  ( addr -- addr )
+    dup get-tail get-head
+    dup is-cell? IF
+        drop autocons
+    ELSE
+        get-value
+        SWAP dup get-head SWAP ROT
+        dup 0 = IF  drop nock-0
+        ELSE dup 1 = IF  drop nock-1
+        ELSE dup 2 = IF  drop nock-2
+        ELSE dup 3 = IF  drop nock-3
+        ELSE dup 4 = IF  drop nock-4
+        ELSE dup 5 = IF  drop nock-5
+        ELSE dup 6 = IF  drop nock-6
+        ELSE dup 7 = IF  drop nock-7
+        ELSE dup 8 = IF  drop nock-8
+        ELSE dup 9 = IF  drop nock-9
+        ELSE dup 10 = IF  drop nock-10
+        ELSE dup 11 = IF  drop nock-11
+        ELSE
+            drop 2drop 98 THROW
+        THEN THEN THEN THEN THEN THEN
+        THEN THEN THEN THEN THEN THEN
+    THEN ;
+
+' do-tar IS tar
+
+: nock  ( addr -- addr )  tar ;