needs hal/opq hal/muldiv lib/psrs lib/type lib/wordtbl num/math \
      mem/kv mem/cons mem/range \
      comp/reg comp/mem comp/c/cexpr comp/c/ast comp/sym
unit comp/c/expr

: sz>idx ( 1-2-4 -- 0-1-2 ) log2 dup 2 > if abort"bad type size" then ;
: moveresize16 0 do over @ over w! 2+ swap 4+ swap loop 2drop ;
: moveresize8 0 do over @ over c! 1+ swap 4+ swap loop 2drop ;

3 wordrefs moveresizetbl moveresize8 moveresize16 move ( src dst u -- )

alias abort expr, ( ast -- halop ) \ forward reference
alias abort effect, ( ast -- ) \ forward reference

0 value exprtype \ type of the last expr, call
: ?signed ( op type -- op ) intandsigned? if signed) then ;

: straightW ( Wop -- ) dup W) &) <> if exprtype ?signed @, else drop then ;
: toW ( halop -- ) dup (W? if straightW else exprtype ?signed @, then ;
: W# ( halop -- halop ) dup (W? not ?err"W source expected" ;
: W># ( halop -- halop ) dup (R> REGW <> ?err"W dest expected" ;
: exprW, ( ast -- ) expr, toW ;

: _assignstruct ( xt leftop type -- )
  rot ['] @, <> ?err"bad struct assignment"
  ?pushS, ?pushA, swap A>) @,
  typesz dup dup 3 and if
    i) S>) @, cmove[], else 4/ i) S>) @, move[], then i) -,
  ?popA, ?popS, ;

: assignop ( ast xt -- halop )
  0 >r over asttype >r \ V1=savedS V2=type
  swap cdr cdrcar ( xt rightast leftast )
  dup noopexpr? if swap exprW, expr, else
    expr, W# dup (bank >r newreg reg&) !, swap exprW, r> bank) ( xt leftop )
    ?regid not if reg&) S>) dup to V1 @!, REGS then R)
    freereg then ( xt leftop )
  r> dup struct? if _assignstruct else ( xt leftop type )
    ?signed dir) swap execute then W) &)
  r> ?dup if @, then ;

: binop ( ast xt -- halop )
  over asttype >r
  swap cdr carcdr ( xt leftast rightast )
  dup noopexpr? if swap exprW, expr, else
    exprW, newreg reg&) !, ( xt leftast )
    exprW, reg&) freereg then ( xt rightop )
  r> ?signed swap execute W) &) ;

\ do pointer arithmetics if one side is a pointer and the other is a int
: do+, ( ast -- halop ) ?ari* ['] +, binop ;

: do+-=, ( ast xt -- halop )
  over cdr cdr asttype int#
  dip ?ari* | assignop ;

: do-, ( ast -- halop )
  dup biasttype ref? over ref? and if ( ast ptrtype )
    swap ['] -, binop swap reftype typesz i) divorshift,
  else drop ?ari* ['] -, binop then ;

: unary ( ast xt -- halop ) swap cdr exprW, execute W) &) ;

create _ map< , <) >) <=) >=) =) <>)
: idx>cond 4* _ + @ ;

: boolexpr, ( ast -- halop cond )
  dup asttype >r dup car op"<" - idx>cond swap ( cond ast )
  cdr carcdr ( cond leftast rightast )
  expr, dup (W? if
    newreg ?reg>) if @, else straightW reg&) !, then ( cond leftast )
    exprW, reg&) freereg
    else swap exprW, then ( cond rightop )
  r> ?signed swap ;
: ?boolexpr, ( ast -- halop cond 1 OR ast 0 )
  dup car op"<" op"!=" within? if boolexpr, 1 else 0 then ;
: exprif, ( ast -- jmp )
  ?boolexpr, if if, else
    dup ?cexpr if nip if 0 else [compile] ahead then
    else expr, testz, ifnz, then then ;
: expr?br, ( tgtaddr ast -- )
  ?boolexpr, if ?br, else
    dup ?cexpr if nip if [compile] again then
    else expr, testz, ?brnz, then then ;
: boolop ( ast -- halop ) boolexpr, bool, W) &) ;
: ?then, ( jmp -- ) ?dup if [compile] then then ;
: ?else, ( jmp -- jmp ) ?dup if [compile] else else [compile] ahead then ;

: ?commadrill ( ast -- ast )
  dup car op"," = if cdr cdrcar effect, then ;

: incop ( halop n -- halop )
  exprtype ?unwrapnip if typesz * then over +n, ;
: do++--, >r cdr expr, r> incop ;

: zerolit? ( ast -- f ) cdrcar op"lit" = swap 0 = and ;
: zeroarray? ( ast -- f )
  cdrcar op"array" = if ( list )
    cdrcar zerolit? swap 0 = and else drop 0 then ;
: zerofill ( ast -- halop )
  ?pushA, ?pushS,
  cdr car expr, ( halop )
  0 i) @, dup A>) @, exprtype typesz dup 3 and if
    i) S>) @, cfill[], else 4/ i) S>) @, fill[], then
  ?popS, ?popA, ;

: assignarray ( ast -- halop )
  dup cdr cdr zeroarray? if zerofill exit then
  cdr carcdr bi asttype | cexpr# litn arraycount ( leftast u )
  swap expr, dup, dup @, ( u halop )
  swap litn ( halop )
  exprtype unwrapptr# typesz sz>idx moveresizetbl swap wexec, ;

: checkargs ( args functype -- )
  >r dup length >r begin ?dup while cdrcar asttype swap repeat ( ... )
  r@ ps[] swap[] r> ( ... n )
  r@ dup sigcounts nip if sigoutputs @ 1 else drop 0 then ( ... n ... n )
  0 tarena1r newsignature r> type=# ;
: _brr, dup (bank pushregs, bank) brr, popregs, ;
: funcall ( ast -- halop )
  \ our args contain, first, the function to call, then arguments. We want to
  \ first resolve the function address, then resolve and push our arguments in
  \ *reverse* order.
  cdr carcdr swap expr, ( args op )
  over exprtype checkargs
  over length not if
    nip _brr, exprtype sigcounts nip if nip, then W) &) exit then ( args op )
  \ we have at least one arg
  dup (bank 2>r exprtype >r ( args V1=op V2=hbank V3=sig )
  V1 (W? if V1 straightW newreg reg&) !, then ( args )
  0 swap begin ?dup while carcdr repeat ( 0 ... )
  PSdisp >r begin ( 0 ... ) exprW, ?dup while dup, PS+ repeat r> to PSdisp ( )
  V1 (W? if reg&) freereg else V1 V2 bank) then _brr, ( callop )
  r> sigcounts nip not if dup, then
  W) &) 2rdrop ;

: unhandled err"this opid is not handled by cexpr.fs" ;
\ Wordtbl below is index by AST opid
wordtbl[ ( ast -- halop )
:> ['] mulorshift, binop ;
:~ (one? not if ?shiftable if >>, else ?pushS, /mod, ?popS, then then ;
:> ['] ~ binop ;
:~ W># ?modmask if &, else ?pushS, /mod, S) &) @, ?popS, then ;
:> ['] ~ binop ;
' do+,
' do-,
:> ['] <<, binop ;
:> ['] >>, binop ;

\ all boolops have the same handler
' boolop dup 2dup 2dup

:> ['] &, binop ;
:> ['] ^, binop ;
:> ['] |, binop ;

\ TODO: this can be optimized, but the constexpr part of it is tricky. later...
:~ ( ast cond -- halop )
  >r cdr cdrcar exprW, 0 i) r> if, ( ast a )
  swap exprW, 0 i) <>) bool, [compile] then W) &) ;
:> ( && ) <>) ~ ;
:> ( || ) =) ~ ;
' unhandled

:> ( = )
  dup cdr cdr car op"array" = if assignarray else ['] @, assignop then ;

:> ( += ) ['] +, do+-=, ;
:> ( -= ) ['] -, do+-=, ;
:> ( *= ) ['] mulorshift, assignop ;
:> ( /= ) ['] divorshift, assignop ;
:> ( %= ) ['] modorand, assignop ;
:> ( <<= ) ['] <<, assignop ;
:> ( >>= ) ['] >>, assignop ;
:> ( &= ) ['] &, assignop ;
:> ( ^= ) ['] ^, assignop ;
:> ( |= ) ['] |, assignop ;

:> ( , ) ?commadrill expr, ;

:> ( ++ ) 1 do++--, ;
:> ( -- ) -1 do++--, ;
:~ -1 i) ^, ;
:> ( ~ ) ['] ~ unary ;
:~ 0 i) =) bool, ;
:> ( ! ) ['] ~ unary ;
:~ 0 i) swap-, ;
:> ( neg ) ['] ~ unary ;

:> ( ref )
  cdr expr, exprtype struct? not if
    dup (&? ?err"can't reference this halop" &) then ;

:> ( deref )
  cdr expr,
  exprtype unwrapptr# tuck struct? if nip exit then
  dup (i? if nip m) else toW W) then ( type op ) swap type) ;

:> ( sizeof ) cdr asttype typesz i) ;

' funcall
' unhandled

:> ( typecast )
  cdr typecast# exprW, ( newtype )
  dup typesz exprtype typesz >= if drop else
    dup exprtype bothint? not if drop else ( newtype )
      dup typesz 8* 32 swap- i) dup <<, swap ?signed >>, then then
  W) &) ;

:~ ( ast n )
  >r cdr expr, dup (W? if
    ?pushS, S) &) !, dup toW REGS R) else dup toW then ( op )
  r> incop drop W) &) ;
:> ( postinc ) 1 ~ ;
:> ( postdec ) -1 ~ ;
:> ( -> )
  cdr carcdr exprW, ( fieldname )
  exprtype getfield ( type offset )
  W) swap +) over array? if nip &) else swap type) then ;

:> ( ?: )
  cdr carcdr carcdr ( cond true false )
  swap rot exprW, 0 i) <>) if, ( f t jmp )
  swap exprW, [compile] else ( f jmp )
  swap exprW, [compile] then W) &) ;

' unhandled
' unhandled
' unhandled
:> ( sym ) cdr getsym ;
]wordtbl tbl

:realias expr, ( ast -- halop )
  constoptimize dup asttype >r
  dup ?cexpr if nip i) else tbl over car wexec then
  r> to exprtype ;

kvtbl[ ( ast -- )
op"postinc" :> 1 do++--, drop ;
op"postdec" :> -1 do++--, drop ;
]kvtbl tbl
:realias effect, tbl over car ?kvexec not if expr, drop then PS0# ;