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>
84 lines
3.9 KiB
Plaintext
84 lines
3.9 KiB
Plaintext
\ acl.v4 -- word-level access control: the fields of an entry.
|
|
\
|
|
\ DECOMPOSITION.md 5.20, as v3: ACL-MODE@ ACL-MODE! ACL-TTL@ ACL-TTL! ACL-ALLOW@
|
|
\ ACL-ALLOW! ACL-PINNED? ACL-PIN ACL-INHERIT ACL-INIT-PRIMITIVES ACL-HEAT@
|
|
\ ACL-WORD-ID. These are all the capsule does itself; the policy -- what is
|
|
\ strict, how long a TTL is, what is pinned -- is FORTH source, ACL.fth, as
|
|
\ it is ACL.4th in v3. The fields and the check are described in
|
|
\ compile.v4. Rests on compile.v4, quit.v4 and system.v4.
|
|
\
|
|
\ An xt of 0 is an error (code 16, "Not a word"). A pinned word's fields are
|
|
\ not changed by the ! words: they do nothing, as in v3.
|
|
\
|
|
\ Constants the loader supplies:
|
|
\ (ACL-HOOK) word address of the variable: the xt of the recheck word, or 0
|
|
|
|
\ ( xt -- xt ) refuse 0
|
|
: (ACL-XT) if NULL ; NULL: drop NODE-ERROR b! 16 !b 0 ;
|
|
\ ( xt -- flag ) non-zero if it is pinned. A holds the flags' address.
|
|
: (PINNED) -3 + a! @ 64 and ;
|
|
|
|
set HDR-NFA here ", ACL-HOOK #, 8 #, HDR-NFA #, HDR-LINK set HDR-LINK here : ACL-HOOK' (ACL-HOOK) ;
|
|
|
|
set HDR-NFA here ", ACL-MODE@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-MODE@ ( xt -- mode ) (ACL-XT) -3 + a! @ 8/ 255 and ;
|
|
set HDR-NFA here ", ACL-TTL@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-TTL@ ( xt -- n ) (ACL-XT) -3 + a! @ 8/ 8/ 65535 and ;
|
|
set HDR-NFA here ", ACL-ALLOW@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-ALLOW@ ( xt -- flag ) (ACL-XT) -3 + a! @ 32 and if YES drop 0 ; YES: drop -1 ;
|
|
set HDR-NFA here ", ACL-PINNED? #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-PINNED? ( xt -- flag ) (ACL-XT) (PINNED) if NO drop -1 ; NO: ;
|
|
set HDR-NFA here ", ACL-PIN #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-PIN ( xt -- ) (ACL-XT) -3 + a! @ 64 OR ! ;
|
|
|
|
set HDR-NFA here ", ACL-MODE! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-MODE! ( mode xt -- )
|
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
|
FREE: drop 255 and 8* @ -65281 and + ! ;
|
|
\ as v3: below 0 is 0. The TTL is sixteen bits here: above 65535 is 65535.
|
|
set HDR-NFA here ", ACL-TTL! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-TTL! ( n xt -- )
|
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
|
FREE: drop
|
|
-if POS drop 0 jump SET
|
|
POS: dup -65536 and if SMALL drop drop 65535 jump SET
|
|
SMALL: drop
|
|
SET: 8* 8* @ 65535 and + ! ;
|
|
set HDR-NFA here ", ACL-ALLOW! #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-ALLOW! ( flag xt -- )
|
|
(ACL-XT) (PINNED) if FREE drop drop ;
|
|
FREE: drop if DENY drop @ -33 and ! ;
|
|
DENY: drop @ 32 OR ! ;
|
|
|
|
\ ( src dst -- ) as v3: dst takes src's mode; it is not pinned, its TTL
|
|
\ is 0 and it is allowed. This is the one word that unpins.
|
|
set HDR-NFA here ", ACL-INHERIT #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-INHERIT
|
|
(ACL-XT) SWAP (ACL-XT) \ dst src
|
|
-3 + a! @ $FF00 and \ dst mode
|
|
SWAP -3 + a! @ 255 and -97 and + ! ; \ the five flags, nothing else
|
|
|
|
\ ( xt -- ) every entry from xt back that is not pinned: TTL mode, TTL 0,
|
|
\ allowed
|
|
: (ACL-INIT)
|
|
L: if DONE
|
|
dup (PINNED) if FREE drop jump NXT
|
|
FREE: drop @ 31 and !
|
|
NXT: -1 + a! @ jump L
|
|
DONE: drop ;
|
|
\ ( -- ) as v3: do that to every word in the dictionary, in every vocabulary
|
|
set HDR-NFA here ", ACL-INIT-PRIMITIVES #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-INIT-PRIMITIVES
|
|
(LATEST) a! @ (ACL-INIT)
|
|
VOC-LINK a! @
|
|
V: if DONE dup a! @ (ACL-INIT) 1 + a! @ jump V
|
|
DONE: drop ;
|
|
|
|
\ ( xt -- heat ) how often the word has been used. The node's heat
|
|
\ counters are not readable from a programme yet (D-6): 0.
|
|
set HDR-NFA here ", ACL-HEAT@ #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-HEAT@ (ACL-XT) drop 0 ;
|
|
\ ( xt -- n ) a number for the word that never changes: its address
|
|
set HDR-NFA here ", ACL-WORD-ID #, 0 #, HDR-NFA #, HDR-LINK set HDR-LINK here
|
|
: ACL-WORD-ID (ACL-XT) ;
|