rajamesandClaude Opus 5.5
1bf19d6224
capsules/v4/sys: the nucleus's fourteen sources as .f18 blobs (made once by v4/tools/v4tof18.py: header becomes the ROM's directives, every other token and line kept), the memory map as map-<width>.f18 (mkmap sys, from one table in host_map.h that host_load reads too), and end.f18, the switch-on state mkimage.c set in C, the image record, and start (IDLE). test_host_rom_nucleus.c: the ROM, fed those blobs through the console, builds RAM identical word for word to mkimage.c's, outside its own state and the image record, and starts at (IDLE), at both widths. The cost: 60.7 million instructions, 1.5 s on the C model. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
154 lines
6.8 KiB
Plaintext
154 lines
6.8 KiB
Plaintext
\ 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 ----
|
|
set HDR-NFA here ", <# #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: <# ( -- ) HEND HLD b! !b ;
|
|
set HDR-NFA here ", HOLD #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: HOLD ( c -- )
|
|
dup -256 and if OKC drop drop NODE-ERROR b! 4 !b ; \ not a character
|
|
OKC: drop HLD b! @b -HFLOOR + -if ROOM
|
|
drop drop NODE-ERROR b! 3 !b ; \ the buffer is full
|
|
ROOM: drop HLD b! @b -1 + dup !b jump C!
|
|
set HDR-NFA here ", SIGN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
|
|
set HDR-NFA here ", # #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: # ( 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
|
|
set HDR-NFA here ", #S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
|
|
set HDR-NFA here ", #> #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
|
|
|
|
\ ---- spaces and the number base ----
|
|
set HDR-NFA here ", SPACES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
|
|
set HDR-NFA here ", DECIMAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: DECIMAL 10 BASE a! ! ;
|
|
set HDR-NFA here ", HEX #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: HEX 16 BASE a! ! ;
|
|
set HDR-NFA here ", OCTAL #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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)
|
|
|
|
set HDR-NFA here ", .R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
|
|
set HDR-NFA here ", . #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
|
|
set HDR-NFA here ", U.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
|
|
set HDR-NFA here ", U. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
|
|
set HDR-NFA here ", D.R #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
|
|
set HDR-NFA here ", D. #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
|
|
|
|
\ ( addr -- ) print what the cell holds
|
|
set HDR-NFA here ", ? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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.
|
|
set HDR-NFA here ", .S #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: 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
|
|
|
|
\ ---- DUMP ----
|
|
\ ( baddr u -- ) u bytes from the byte address baddr, sixteen to a line: the
|
|
\ address, the bytes in hex, and the bytes as characters between bars.
|
|
\ Everything it keeps between words is in (DP): the saved BASE, the address,
|
|
\ the count and the column. ADDR-DIGITS is two for each byte of a cell.
|
|
: (DB) ( -- c ) (DP)+1 b! @b (DP)+3 b! @b + jump C@
|
|
set HDR-NFA here ", DUMP #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: DUMP
|
|
-if OK drop drop NODE-ERROR b! 1 !b ;
|
|
OK: (DP)+2 b! !b (DP)+1 b! !b
|
|
BASE b! @b (DP) b! !b 16 BASE b! !b
|
|
LINE: (DP)+2 b! @b if DONE drop
|
|
(DP)+1 b! @b 0 <# ADDR-DIGITS (DP)+3 b! !b
|
|
AD: # (DP)+3 b! @b -1 + dup !b if ADX drop jump AD
|
|
ADX: drop #> TYPE 58 EMIT SPACE
|
|
0 (DP)+3 b! !b
|
|
HX: (DP)+2 b! @b (DP)+3 b! @b inv + -if HAVE
|
|
drop SPACE SPACE SPACE jump HN
|
|
HAVE: drop (DB) 0 <# # # #> TYPE SPACE
|
|
HN: (DP)+3 b! @b 1 + dup !b -16 + -if HXX drop jump HX
|
|
HXX: drop SPACE 124 EMIT
|
|
0 (DP)+3 b! !b
|
|
CH: (DP)+2 b! @b (DP)+3 b! @b inv + -if HAVC jump CHX
|
|
HAVC: drop (DB)
|
|
dup -32 + -if GE drop drop 46 jump EM
|
|
GE: drop dup -127 + -if BIG drop jump EM
|
|
BIG: drop drop 46
|
|
EM: EMIT
|
|
(DP)+3 b! @b 1 + dup !b -16 + -if CHX drop jump CH
|
|
CHX: drop 124 EMIT CR
|
|
(DP)+1 b! @b 16 + !b
|
|
(DP)+2 b! @b -16 + -if MORE jump DONE
|
|
MORE: !b jump LINE
|
|
DONE: drop (DP) b! @b BASE b! !b ;
|