needs lib/psrs lib/type mem/kv comp/c/type comp/c/ast
unit comp/c/cexpr

alias abort ?cexpr ( ast -- ?n f )
: cexpr# ?cexpr not ?err"not a constexpr" ;
\ from comp/c/type
:realias parseConstExpr ( -- n ) ast< cexpr# ;

: ?binimm ( ast -- ?ln ?rn f )
  cdr cdrcar ?cexpr if ( r ln )
    swap ?cexpr if 1 else drop 0 then
    else drop 0 then ;
: binop ( ast xt -- ?n f )
  >r ?binimm if r> execute 1 else rdrop 0 then ;
: binop> ' ['] binop bind> ;
: boolop ( ast xt -- ?n f )
  >r dup ?binimm if ( ast ln rn )
    rot biasttype merge# intandsigned? if
      $80000000 + swap $80000000 + swap then
    r> execute 1 else drop rdrop 0 then ;
: boolop> ' ['] boolop bind> ;

: ari*? ( left right -- ?sz ?right? f )
  2dup bothint? if 2drop 0 else
    ptr+int# dip reftype typesz | over 1 > dup not if nip nip then then ;
: mkmul ( ast sz -- ast ) mklit cons op"*" swap cons ;
: ?ari* ( binopast -- ast )
  dup biasttype ( ast lt rt )
  ari*? if if ( ast sz )
    >r carcdr cdrcar ( op right left )
    r> mkmul swap cons cons
  else
    >r carcdr carcdr ( op left right )
    r> mkmul cons cons then then ;

: doimm+ ( ast ln rn -- ?n f )
  rot biasttype ari*? if if dipswap then * then + 1 ;
: do+ ?ari* ['] + binop ;

: do-
  dup biasttype ref? over ref? and if ( ast ptrtype )
    swap ['] - binop ( ptrtype ?n f )
    if swap reftype typesz / 1 else drop 0 then
  else drop ?ari* ['] - binop then ;

: unary ( ast xt -- ?n f )
  >r cdr ?cexpr if r> execute 1 else rdrop 0 then ;

\ Maximum size in bytes that a single list literal can have
$400 const MAXLITSZ
create _buf MAXLITSZ allot

: arraylit ( ast -- a u )
  cdr _buf begin ( elems dst )
    swap ?dup while ( dst elems )
    cdrcar cexpr# ( a elems n )
    rot !+ repeat ( a )
  _buf - _buf over ( u a u ) parena1@ cmoveallot ( u a ) swap ;

: dotypecast ( ast -- ?n f )
  cdr typecast# ( type ast )
  dup ?cexpr if ( newtype ast n )
    nip nip 1 else 2drop 0 then ;

kvtbl[ ( ast -- ?n f )
op"*" binop> *
op"/" binop> /
op"%" binop> mod
op"+" ' do+
op"-" ' do-
op"<<" binop> lshift
op">>" binop> rshift
op"&" binop> and
op"^" binop> xor
op"|" binop> or
op"<" boolop> <
op">" boolop> >
op"<=" boolop> <=
op">=" boolop> >=
op"==" boolop> =
op"!=" boolop> <>
op"~" :> ['] inv unary ;
op"!" :> ['] not unary ;
op"array" :> arraylit drop 1 ;
op"typecast" ' dotypecast
op"neg" :> ['] neg unary ;
op"lit" :> cdr 1 ;
op"str" :> cdr 1 ;
op"zstr" :> cdr 1 ;
op"sym" :> cdr getsym (i? ;
]kvtbl tbl
:realias ?cexpr tbl over car ?kvexec not if drop 0 then ;

\ Each character of the string below represent a cell in a table of 4 columns
\ and a row for each binary operator (from * to ||). The 4 colums are for the
\ behavior when left is 0, right is 0, left is 1, right is 1.
\ The possible cell values are:
\ n=noop l=keep left r=keep right 0=yield 0 -=unary negate e=error
:~ op"|" 1+ 4* 0 do toword# in< c, loop ;
create optimizations ~
  00rl 0enl 0el0 rlnn -lnn 0lnn 0lnn
  nnnn nnnn nnnn nnnn nnnn nnnn
  00nn rlnn rlnn

kvtbl[ ( ast -- ast )
'l' :> cdr car ;
'r' :> cdr cdr ;
'0' :> drop 0 mklit ;
'-' :> cdr cdr op"neg" swap cons ;
'e' :> err"divide by zero" ;
'n' ' noop
]kvtbl actiontbl
: doaction ( ast 0-1-2-3 -- ast )
  over car 4* + optimizations + c@
  actiontbl swap ?kvexec not ?err"corrupt optimization table" ;

: constoptimize ( ast -- ast )
  dup car op"|" > if exit then
  dup cdr car ?cexpr if ( ast n )
    ?dup if 1 = if 2 doaction then else 0 doaction then
  else dup cdr cdr ?cexpr if ( ast n )
    ?dup if 1 = if 3 doaction then else 1 doaction then then then ;

alias abort noopexpr?
kvtbl[ ( ast -- f )
op"sym" :> drop 1 ;
op"ref" over
op"sizeof" over
op"deref" :> dup asttype struct? if cdr noopexpr? else cdr ?cexpr ?nip then ;
]kvtbl tbl
:realias noopexpr? ( ast -- f )
  dup ?cexpr if 2drop 1 else
    constoptimize tbl over car ?kvexec not if drop 0 then then ;