feat(v4.0.0): number output in the capsule, and .S
- capsule/numout.v4: <# # #S HOLD SIGN #>, . .R U. U.R D. D.R, ?, SPACES, DECIMAL HEX OCTAL -- the definitions DECOMPOSITION.md 5.8 gives and the mesh-node tests execute, now words of the host node's vocabulary. - .S, which D-16 makes possible again: as v3, the depth, then every value from the deepest, then a new line. It needs six cells of the stack free. - tests/test_host_quit.c: printed from the prompt, with 14 more sessions that are transcripts of the v3 binary, and the ends of the number range at each cell width. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
co-authored by
Claude Opus 5.5
Claude Opus 5.5
parent
ebffa6082d
commit
644bfc0a25
@@ -0,0 +1,118 @@
|
||||
\ numout.v4 -- printing numbers: pictured output, the . words, and .S
|
||||
\
|
||||
\ DECOMPOSITION.md 5.8: <# # #S HOLD SIGN #> . .R U. U.R D. D.R ? SPACES
|
||||
\ DECIMAL HEX OCTAL, each the definition given there and executed on the mesh
|
||||
\ node by test_pictured.c, test_numout.c and test_printing.c; and .S, which
|
||||
\ D-16 makes possible again. Part of the compiler capsule. Rests on core.v4
|
||||
\ and forth.v4.
|
||||
\
|
||||
\ Constants the loader supplies:
|
||||
\ HEND byte address just past the hold buffer, which is 64 bytes
|
||||
\ -HFLOOR minus the lowest address HOLD may store at: -(HEND - 62)
|
||||
\ HLD word address of the variable: where the picture has got to
|
||||
\ (W) word address of three cells of scratch for this file:
|
||||
\ (W)+0 the width a number is to be printed in
|
||||
\ (W)+1 whether a blank follows it (W)+2 .S's count
|
||||
|
||||
macro (-ROT) SWAP push SWAP pop endmacro
|
||||
|
||||
\ ---- unsigned division (section 4) ----
|
||||
\ One step a bit, the divisor in A. Exact for uhi < ud.
|
||||
: UM/MOD ( ulo uhi ud -- urem uquot )
|
||||
a! N-1 FOR
|
||||
-if L0
|
||||
2* over -if L1 drop 1 + jump L2
|
||||
L1: drop L2: push 2* pop
|
||||
jump SUB
|
||||
L0:
|
||||
2* over -if L3 drop 1 + jump L4
|
||||
L3: drop L4: push 2* pop
|
||||
dup a xor -if L5
|
||||
drop -if NOSUB jump SUB
|
||||
L5: drop dup inv a + inv -if L6
|
||||
drop jump NOSUB
|
||||
L6: push drop pop jump SETBIT
|
||||
SUB: inv a + inv
|
||||
SETBIT: push 1 + pop
|
||||
NOSUB:
|
||||
NEXT
|
||||
over push push drop pop pop ;
|
||||
|
||||
\ ---- pictured output ----
|
||||
header <#
|
||||
: <# ( -- ) HEND HLD b! !b ;
|
||||
header HOLD
|
||||
: HOLD ( c -- )
|
||||
dup -256 and if OKC drop jump ERR
|
||||
OKC: drop HLD b! @b -HFLOOR + -if ROOM drop
|
||||
ERR: drop NODE-ERROR b! -1 !b ;
|
||||
ROOM: drop HLD b! @b -1 + dup !b jump C!
|
||||
header SIGN
|
||||
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
|
||||
header #
|
||||
: # ( ud1 -- ud2 )
|
||||
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
|
||||
(BASE) UM/MOD (-ROT) \ qlo qhi rem
|
||||
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
|
||||
header #S
|
||||
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
|
||||
header #>
|
||||
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
|
||||
|
||||
\ ---- spaces and the number base ----
|
||||
header SPACES
|
||||
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
|
||||
header DECIMAL
|
||||
: DECIMAL 10 BASE a! ! ;
|
||||
header HEX
|
||||
: HEX 16 BASE a! ! ;
|
||||
header OCTAL
|
||||
: OCTAL 8 BASE a! ! ;
|
||||
|
||||
\ ---- numbers ----
|
||||
\ One picture for signed singles, one for unsigned, one for doubles. Each
|
||||
\ plain word is its .R word with a width of 0 and the blank flag set, and all
|
||||
\ six share one tail, which prints the blank only when the flag is set.
|
||||
|
||||
\ ( baddr u -- ) right-justified in the width, then the blank if wanted
|
||||
: (.TAIL)
|
||||
(W) b! @b -if POS drop jump OUT \ width < 0
|
||||
POS: over - SPACES \ width - u spaces
|
||||
OUT: TYPE (W)+1 b! @b if DONE drop jump SPACE
|
||||
DONE: drop ;
|
||||
: (.BODY) ( n width -- )
|
||||
(W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> jump (.TAIL)
|
||||
: (U.BODY) ( u width -- )
|
||||
(W) b! !b 0 <# #S #> jump (.TAIL)
|
||||
: (D.BODY) ( d width -- )
|
||||
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
|
||||
|
||||
header .R
|
||||
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
|
||||
header .
|
||||
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
|
||||
header U.R
|
||||
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
|
||||
header U.
|
||||
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
|
||||
header D.R
|
||||
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
|
||||
header D.
|
||||
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
|
||||
|
||||
\ ( addr -- ) print what the cell holds
|
||||
header ?
|
||||
: QUESTION a! @ jump DOT
|
||||
|
||||
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
|
||||
\ the deepest first, each followed by a blank; then a new line. The stack is
|
||||
\ left as it was. It reads each value with PICK, so it needs a few cells of
|
||||
\ the stack free to work in.
|
||||
header .S
|
||||
: DOT-S
|
||||
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
|
||||
DEPTH (W)+2 b! !b
|
||||
L: (W)+2 b! @b if DONE
|
||||
PICK DOT
|
||||
(W)+2 b! @b -1 + !b jump L
|
||||
DONE: drop jump CR
|
||||
Reference in New Issue
Block a user