\ 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 ;

header ACL-HOOK inline   : ACL-HOOK'   (ACL-HOOK) ;

header ACL-MODE@
: ACL-MODE@   ( xt -- mode )   (ACL-XT)  -3 + a! @  8/  255 and ;
header ACL-TTL@
: ACL-TTL@    ( xt -- n )      (ACL-XT)  -3 + a! @  8/ 8/  65535 and ;
header ACL-ALLOW@
: ACL-ALLOW@  ( xt -- flag )   (ACL-XT)  -3 + a! @  32 and  if YES  drop 0 ;   YES: drop -1 ;
header ACL-PINNED?
: ACL-PINNED? ( xt -- flag )   (ACL-XT)  (PINNED)  if NO  drop -1 ;   NO: ;
header ACL-PIN
: ACL-PIN     ( xt -- )        (ACL-XT)  -3 + a! @  64 OR  ! ;

header ACL-MODE!
: 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.
header ACL-TTL!
: 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  + ! ;
header ACL-ALLOW!
: 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.
header ACL-INHERIT
: 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
header ACL-INIT-PRIMITIVES
: 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.
header ACL-HEAT@
: ACL-HEAT@     (ACL-XT)  drop 0 ;
\ ( xt -- n )   a number for the word that never changes: its address
header ACL-WORD-ID
: ACL-WORD-ID   (ACL-XT) ;