needs lib/type lib/str
unit lib/struct

create NULLPTR 0 ,

$14 adder szfield
$18 adder structfields
$1c adder bindptr
: fieldtype @ ;
: fieldoff 4+ @ ;
: fieldstruct 8+ @ ;
: structsz szfield @ ;
: struct? typeszxt ['] structsz = ;
:~ ( ll -- )
  dup @ ?dup if ~ .", " then
  dup entryname[] rtype spc> e>xt dup fieldoff ."+" . spc> fieldtype .type ;
variable lvl
: .struct
  lvl @ if drop ."{...}" exit then
  ."{" structfields @ ?dup if 1 lvl +! ~ -1 lvl +! then ."}" ;
: newstructure ( extends -- type )
  >r ['] @, ['] structsz ['] .struct 3 newtype ( type V1=extends )
  r> dup if dup , szfield 8 cmoveallot else , 0 , 0 , then 0 , ;

: _. drop ."METHOD" ;
: _sz drop 4 ;
: method? typeszxt ['] _sz = ;
: _@, dup (dir? if @, else dup (W? not if dup, dup 0 bank) &) @, then brr, then ;
' _@, ' _sz ' _. 2 newtype addtype method
: _@, dup (dir? if @, else dup (W? if S>) @, drop, S) &) then brr, then ;
' _@, ' _sz ' _. 2 newtype addtype smethod

variable cur
variable ext
variable forceunbound
NULLSTR value curstructname
: cur# cur @ ?dup not ?abort"no active struct" ;
: curoff cur# szfield ;
: extends run1 ext ! ;
: -> 1 forceunbound ! ; immediate
: containsstruct? ( s tgt -- f )
  swap begin ?dup while 2dup <> while reftype repeat drop 1 else 0 then nip ;
: findfield structfields find dup if @+ swap @ 1 then ;
: ?placeholder ( name -- f )
  findtype ?dup if dup cur ! bi struct? | typesz not and else 0 then ;
: _struct
  word dup to curstructname ?placeholder if exit then
  repeatword 0 ext @! newstructure dup cur ! addtype ;
: newfield ( off type name -- field )
  cur# structfields swap entry ( off type )
  cur# rot> 3 n,@ ;
: addfield
  curoff @ swap word newfield
  cur# structfields @ dup if e>xt bi fieldoff | fieldtype typesz + then ( n )
  curoff ! ;
: addalignedfield ( type -- field ) curoff @ over typealign curoff ! addfield ;
create _ leint , leshort , beint , beshort ,
: ?typeal# ( type -- type )
  curoff @ over case
    array? of r@ reftype typesz 1 max align# endof
    struct? of 4 align# endof
    _ 4 idx of 2drop endof
    typesz 1 max align# endcase ;
: genprefixedalias
  curstructname "." strcat CURWORD @ strcat NEXTWORD ! sysdict entryalias ;
: fieldsel, repeatword getset, genprefixedalias ;
: bindptr@ ( field -- a-or-0 )
  0 forceunbound @! if drop 0 else fieldstruct bindptr @ then ;
: ?bindptr@, ( field -- ?a ) bindptr@ ?dup if @ then ;
: addr, ( field -- halop )
  COMPILING @ if
    dup bindptr@ ?dup if m) S>) @, S) else
      W) doto@? @ if [compile] A! then
      doto!? @ if drop A) then then
    else dup litn ['] ?bindptr@, execute, W) then
  over fieldtype type) swap fieldoff +) ;
: do@, ( halop type -- ) over (W? not over method? not and if dup, then type@, ;
: do!, ( halop type -- ) over (W? if PSP) S>) @+, dip S>) | then type!, drop, ;
: fieldt ( type -- )
  ?typeal# dup addfield >r ( type V1=field )
  dup ['] do!, bind>
  swap ['] do@, bind>
  r@ ['] addr, bind>
  r> n"FILD" fieldsel, ;

: offsetof
  word sysdict findentry ?wnf
  dup entrytag n"FILD" <> ?abort"not a FILD"
  scryentry# fieldoff
  COMPILING @ if litn then ; immediate

: addrof
  word sysdict findentry ?wnf bi scryentry# | entrytag case
    n"FILD" = of
      COMPILING @ if addr, dup (W? not if dup, then &) @, else
        dup bindptr@ ?dup not ?abort"addrof on unbound struct field" @
        swap 4+ @ + then endof
    n"VALU" = of COMPILING @ if litn then endof
    n"LVAR" = of dup, [rcnt] @ - RSP) swap +) &) @, endof
    abort"wrong addrof target" endcase ; immediate

0 value baseoffset
: ?} ( -- f ) toword# in< dup '\' = if drop [compile] \ ?} else '}' = then ;
: ?+ ( -- ) in< '+' <> if stepback else n< baseoffset + curoff ! then ;
: parsefields ( -- )
  0 to baseoffset
  toword# in< dup '+' = if
    drop n< dup curoff ! to baseoffset toword# in< then ( c )
  '{' <> ?abort"{ expected"
  begin ?} not while stepback
    ?+ type< begin word ";" s= not while repeatword dup fieldt repeat
    drop repeat ;

: struct _struct parsefields 0 cur ! ;
: bindstruct bindptr ! ;
: unbindstruct 0 swap bindstruct ;