needs lib/type lib/struct lib/psrs mem/range \
      comp/tok comp/sig comp/sym comp/mem comp/c/ast
unit comp/c/type

:~ word newint repeatword addtype ;
' @, 1 4 ~ long
' @, 0 4 ~ flexuint
' @, 1 4 ~ flexint
char newpointer addtype ZString
0 const NULL

0 value curfunc   \ signature [lib/type] of the current function
\ forward declaration implemented in cexpr.fs
alias noop parseConstExpr ( -- n ) \ forward declaration

: ?newstructure ( name -- )
  ?dup if dup ?placeholder if drop else
    NEXTWORD ! 0 newstructure dup cur ! addtype then
    else 0 newstructure cur ! then ;
: ?tmppointer curfunc if tmppointer else newpointer then ;

alias abort parsetype ( -- ?type f ) \ forward declaration
alias abort decl ( type -- type name ) \ forward declaration
: parsetype# ( -- type ) parsetype not ?err"type expected" ;
: parsetypeorforward ( -- type )
  parsetype not if
    curtok isIdent? not ?err"invalid type name"
    cur @ curtok ?newstructure cur @! then ;

:~ ( e -- )
  dup @ ?dup if ~ then ( e )
  dup entryname[] []>str ( e name )
  dip e>xt bi fieldoff curoff @ + | fieldtype | newfield drop ;
: mergestruct ( type -- )
  dup struct? not ?err"unnamed struct members can only be structs"
  dup structfields @ ~ ( type )
  typesz curoff +! ;

: parsestruct ( union? -- type )
  cur @ >r 0 >r >r ( V1=oldstruct V2=unionsz V3=union? )
  readIdent? not if 0 then ( name-or-0 )
  '{' readChar ?newstructure begin ( )
    parsetypeorforward begin ( type )
      dup decl dup c@ if
        NEXTWORD ! addfield drop else drop mergestruct then ( type )
      V3 if 0 curoff @! doto V2 max | then
      ',' readChar? not until ( type )
    drop read; '}' readChar? until ( )
  2r> not if drop curoff @ then ( curoff )
  align4 curoff ! r> cur @! ;

stringlist baseints long int short char
create unsigned uint , uint , ushort , uchar ,
create signed int , int , short , char ,
: baseint< ( -- idx ) tok< baseints sfind not ?err"base int expected" ;

stringlist structkws struct union
:realias parsetype ( -- type? f )
  tok< case ( )
    "unsigned" s= of baseint< 4* unsigned + @ 1 endof
    "signed" s= of baseint< 4* signed + @ 1 endof
    findtype ?dup of 1 endof
    structkws sfind of ( idx ) parsestruct 1 endof
    drop 0 endcase ;

: _funcargs ( type name addsym? -- type name ) \ opening '(' is read
  >r >r >r 0 begin ( ... n V1=addsym? V2=name V3=sig )
    tok< "..." s= not while tokstepback
    ')' readChar? not while
    parsetypeorforward decl
    V1 if dipdup addargument then drop ( ... n type )
    swap 1+ ( ... n ... n )
    ',' readChar? while repeat
    read) else then 0 else read) 1 then ( ... n vararg? )
  over 1 = if oover void = if nip nip 0 swap then then
  >r r! ps[] swap[] r> r> \ reverse arg order
  r> dup void? if drop 0 swap else 1 rot then ( ... n ... n varargs? )
  256* newsignature r> rdrop ;

: inserttype ( basetype bottomtype toptype -- toptype )
  begin oover over reftype <> while reftype repeat tuck reftype! nip ;
: ?parse[] ( -- ?n f )
  '[' readChar? dup if parseConstExpr ']' readChar swap then ;
:realias decl ( type -- type name )
  begin '*' readChar? while ?tmppointer repeat
  '(' readChar? if
    r! decl read) ( type name V1=oldtype )
    ?parse[] if ( toptype name n )
      V1 newarray ( top name bottom )
      rot V1 rot> inserttype swap then ( type name )
    '(' readChar? if nip V1 swap 0 _funcargs then ( type name )
    rdrop exit then
  readIdent? not if NULLSTR then ( type name )
  ?parse[] if rot newarray swap then ( type name )
  '(' readChar? if symbols$ 1 _funcargs then ( type name ) ;

: int# ( type -- ) int? not ?err"integer type expected" ;
: int4? ( type -- f ) bi int? | typesz 4 = and ;
: intandsigned? dup int? if intsigned? else drop 0 then ;
: ref? ( type -- f ) bi pointer? | array? or ;
: ref# ( type -- ) ref? not ?err"pointer type expected" ;
: reforstruct? ( type -- f ) bi ref? | struct? or ;
: ?unwrapptr ( type -- type f ) dup ref? if reftype 1 else 0 then ;
: ?unwrapnip ( type -- ?type f ) ?unwrapptr dup not if nip then  ;
: unwrapptr# ( type -- type )
  ?unwrapptr not if .type nl> err"is not a pointer" then ;
: voidptr? ?unwrapptr if void? else drop 0 then ;
: signaturertype ( type -- type )
  dup sigcounts nip 1 = if sigoutputs @ else drop void then ;

create flexints map< , flexuint flexint
: flexint? flexints 2 idx ?nip ;
:~ over flexint? if nip dup then
   over voidptr? over reforstruct? and if nip dup then ;
: ?flex ( t1 t2 -- t1 t2 ) ~ swap ~ swap ;

: bothint? ( type type -- f ) int? swap int? and ;
: bothint# ( type type -- ) bothint? not ?err"int types required" ;
: ?promoteint ( type type -- type type 0 OR mergetype 1 )
  ?flex 2dup bothint? not if 0 exit then
  over intsigned? over intsigned? <> if 0 exit then
  over typesz over typesz < if nip else drop then 1 ;

alias abort type=
: ?merge ?promoteint ?dup not if tuck type= then ;
: typesfit? ( other type -- f ) ?promoteint ?dup if nip else type= then ;
: args= ( othera typea u -- f )
  0 do @+ rot @+ rot swap typesfit?
       not if 2drop 0 unloop exit then loop 2drop 1 ;
: sig= ( other type -- f )
  over signature? not if 2drop 0 exit then
  dup sigvarinput? if
    over sigcounts oover sigcounts rot = rot> >= and
    else over sigcounts oover sigcounts rot = rot> = and then
  not if 2drop 0 exit then
  dup sigcounts + rot sigoutputs rot sigoutputs ( u othera typea )
  rot args= ;

:realias type= ( other type -- f )
  2dup = if 2drop 1 exit then
  ?flex over voidptr? over voidptr? and if 2drop 1 exit then
  case ( other )
    int? over int? and of
      bi intsigned? r@ intsigned? = | typesz r@ typesz = and endof
    ref? over ref? and of reftype r@ reftype type= endof
    signature? of r@ sig= endof
    = endcase ;
: typeerr ( other type -- )
  ."want: " dup .x spc> .type nl>
  ."have: " dup .x spc> .type nl>
  err"unexpected type" ;
: type=# ( other type -- ) 2dup type= if 2drop else typeerr then ;
: merge# ( right left -- type ) dipdup ?merge if nip else typeerr then ;
: binopmerge# 2dup bothint# merge# ;
: ?bothint# ( left right -- type 1 OR left right 0 )
  2dup bothint? if merge# 1 else 0 then ;

: getfield ( name type -- fieldtype offset )
  unwrapptr# dup struct? not ?err"structure expected"
  findfield not ?err"field not found" ;

: nosym tokdbg (wnf) ;
: getsymtype ( name -- type )
  dup findsymbol ?dup if nip type else
    sysdict findentry ?dup not if nosym then ( e )
    dup entrytag bi n"CNST" = | n"VALU" = or if drop flexuint else ( e )
      e>xtsel n"SIGT" findtag not if nosym then then then ;

: getsym ( name -- halop )
  dup findsymbol ?dup if nip symbol) else
    sysdict findentry ?dup not if nosym then ( e )
    dup entrytag case ( e )
      n"CNST" = of e>xtsel execute i) endof
      n"VALU" = of scryentry# m) endof
      drop e>xtsel dup n"SIGT" findtag if drop else nosym then i) endcase then ;

: typecast# ( cdr -- type subast )
  carcdr carcdr ( name lvl ast )
  rot findtype dup not ?err"bad typecast" ( lvl ast type )
  rot 0 do tmppointer loop swap ;

: ptr+int# ( lefttype righttype -- ptrtype right? )
  dup ref? if swap int# 1 else int# dup ref# 0 then ;

alias abort asttype ( ast -- type )
: _biasttype ( binopcdr -- ltype rtype ) bi car asttype | cdr asttype ;
: biasttype cdr _biasttype ;
: +merge# ( lefttype righttype -- type )
  ?bothint# not if ptr+int# drop then ;
: -merge# ( lefttype righttype -- type )
  2dup type= over ref? and if 2drop flexint else +merge# then ;
: +-=merge# ( lefttype righttype -- type )
  int# dup ref? not if dup int# then ;
: nullarray? ( type -- f )
  dup array? if bi reftype int? | arraycount 1 = and else drop 0 then ;
: =merge# ( lefttype righttype -- type )
  over struct? over nullarray? and if drop else merge# then ;
: >flex ( type -- type ) intandsigned? if flexint else flexuint then ;

:realias asttype ( ast -- type )
  cdrcar case ( cdr )
    op"<" op"!=" within? of _biasttype merge# >flex endof
    op"&&" op"||" within? of _biasttype 2drop flexuint endof
    op"+" = of _biasttype +merge# endof
    op"-" = of _biasttype -merge# endof
    op"+=" op"-=" within? of _biasttype +-=merge# endof
    op"=" = of _biasttype =merge# endof
    binop? of _biasttype binopmerge# endof
    op"," = of cdr asttype endof
    op"!" <= of asttype endof
    op"ref" = of asttype tmppointer endof
    op"deref" = of asttype unwrapptr# endof
    op"sizeof" = of drop flexuint endof
    op"funcall" = of car asttype signaturertype endof
    op"array" = of length flexuint tarena1r newarray endof
    op"typecast" = of typecast# drop endof
    op"postdec" <= of asttype endof
    op"->" = of carcdr asttype getfield drop endof
    op"?:" = of cdr _biasttype merge# endof
    op"lit" = of drop flexuint endof
    op"str" = of drop String endof
    op"zstr" = of drop ZString endof
    op"sym" = of getsymtype endof
    err"asttype error"
  endcase ;
: asttype# ( ast -- ast ) dup asttype drop ;