needs hal/muldiv lib/str lib/psrs lib/bit lib/type lib/wordtbl mem/kv \
      mem/cons comp/reg comp/sig comp/mem \
      comp/oberon/type comp/oberon/cexpr comp/oberon/ast comp/oberon/module
unit comp/oberon/expr

\ binop table. Each row is 4 word references:
\ +00 Integer compile
\ +04 Set compile
\ Binary operators below refer to those rows by index.
: err err"invalid binop for SET" ;
: s/, ?pushS, signed) divorshift, ?popS, ;
: smod, ?pushS, signed) modorand, ?popS, ;
: s>>, signed) >>, ;
: invand, ?pushS, S>) @, -1 i) S>) ^, S) &) &, ?popS, ;
:~ over signed) swap if, swap @, [compile] then ;
: min, >) ~ ; : max, <) ~ ;
10 2* wordrefs binoptbl
  mulorshift, &,
  s/, ^,
  smod, err
  <<, err
  >>, err
  s>>, err
  +, |,
  -, invand,
  min, err
  max, err

void value exprtype
alias abort expr, ( ast -- halop ) \ forward decl
: exprtype=# ( expected -- ) exprtype swap expecttype# ;

: straightW ( Wop -- ) dup W) &) <> if @, else drop then ;
: toW ( halop -- ) dup (W? if straightW else @, then ;
: exprW, ( ast -- ) expr, toW ;
: expr&, expr, exprtype pointer? not if &) then toW ;
: &# ( halop -- halop ) dup (&? ?err"can't reference halop" &) ;
: bank>r ( halop -- halop ) dup, compile (bank [compile] >r ; immediate
: r>bank ( halop -- halop ) [compile] r> compile bank) ; immediate

:~ if toW doto exprtype reftype | W) exprtype type) then ;
: ?ptrderef, ( halop -- halop ) exprtype pointer? ~ ;
: ?gcderef, ( halop -- halop ) exprtype gcptr? ~ ;

: binop ( cdr idx -- halop )
  2* over car asttype SET = + ( cdr idx )
  swap carcdr ( idx leftast rightast )
  ?noopexprk if bank>r swap exprW, r>bank else
    exprW, newreg reg&) !, ( idx leftast )
    exprW, reg&) freereg then ( idx rightop )
  binoptbl rot wexec W) &) ;

\ Provided that type is an array or open array, yield a halop that corresponds
\ to the length of that array
: arraylenop ( halop -- halop )
  exprtype ?unwrapptr drop case ( halop )
    openarray? of 4 +) endof
    array? of drop r@ arraycount i) endof
    err"array expected" endcase ;

: rorn, ( n -- )
  ?pushS, $1f and S) &) !,
  dup i) >>, 32 swap- i) S>) <<, S) &) |, ?popS, ;
: ror, ( halop -- )
  dup (W? ?err"ROR 2nd argument can't be an expression"
  ?pushS, ?pushA,
  dup A>) @, 32 i) A>) swap-, S) &) !, \ A=32-n
  ( halop ) >>, A) &) S>) <<, S) &) |,
  ?popA, ?popS, ;

: strcmp, ( cond leftast rightast -- halop )
  ?noopexprtk if bank>r rot expr&, r>bank else
    expr&, exprtype newreg reg&) !, ( cond leftast type )
    swap expr&, reg&) freereg then ( cond type halop )
  ?pushA, ?pushS,
  swap pointer? not if &) then ( cond halop )
  A>) @, 1 i) A>) -, here
    1 i) A>) +, W) 8b) S>) @+,
    0 i) S>) <>) if,
    swap A) 8b) S>) =) ?br,
  [compile] then ( cond ) A) 8b) S>) swap bool,
  ?popS, ?popA, W) &) ;

: condop ( cdr cond -- halop )
  swap carcdr ( cond leftast rightast )
  over asttype ?unwrapptr drop string? if strcmp, exit then
  ?noopexprk if bank>r swap exprW, r>bank else
    exprW, newreg reg&) !, ( cond leftast )
    exprW, reg&) freereg then ( cond leftop )
  signed) swap bool, W) &) ;

: oob abort"out of bounds indexing" ;

\ if expected is a pointer to type and halop can get a "&)", do it.
: checktype ( expectedtype halop -- halop )
  over OPAQUE <> exprtype OPAQUE <> and if
    over pointer? exprtype pointer? not and if
      over reftype exprtype
      swap type= if &) doto exprtype tmppointer | then then
  then swap exprtype=# ;

: ?pusharraylen ( expectedtype halop -- expectedtype halop )
  over pointer? if over reftype openarray? if
    dup arraylenop S>) @,
    exprtype pointer? if @, W) &) then
    PSP) S>) -!, PS+ then then ;

\ If halop is PSP), it means that our type lives in PSP+4. Otherwise, our type
\ is exactly the same as "type".
: recordtypeop ( halop -- halop )
  dup (R REGPSP = if 4 +) else drop exprtype i) then ;
: ?pushrecordtype ( expectedtype halop -- expectedtype halop )
  exprtype OPAQUE = if exit then
  over structptr? if
    dup recordtypeop S>) @,
    exprtype pointer? if @, W) &) then
    PSP) S>) -!, PS+ then ;

\ we need to push arguments in the opposite order.
: unwrapargs ( args -- ... n )
  0 swap begin ?dup while ( ... n args )
    cdrcar rot 1+ rot repeat ;
: arg, ( arg 'sigarg -- 'sigarg+4 )
  4- dup @ rot expr, ( 'sigarg expectedtype halop )
  ?pusharraylen ?pushrecordtype checktype toW ;
: _brr, dup (bank pushregs, bank) brr, popregs, ;
: proccall ( args -- funcsig )
  PSdisp >r cdrcar >r \ V1=PSdisp V2=funcast
  unwrapargs ( ... n )
  dup V2 asttype ( ... n n sig )
  tuck sigcounts drop <> ?err"wrong argument count" ( ... n sig )
  siginputs over 4* + ( ... n 'sigargs )
  over if swap 1- rot> arg, then ( ... n 'sigarg )
  swap 0 do dup, PS+ arg, loop ( 'sigarg ) drop
  r@ ( ast ) ?noopexprk not if ( ast )
    newreg reg&) !, exprW, reg&) @!, reg&) freereg then ( halop )
  _brr, r> asttype signature# r> to PSdisp ;
: funcall ( args -- halop )
  proccall sigcounts 1 <> ?err"not a function" ( numinput )
  not if nip, then W) &) ;

\ Most of the time, set literals are entirely constant. When that happens, we
\ don't want to generate super inefficient code, we want to yield a constant
\ at compile time. However, we also need to support the cases where {} contains
\ non-constant identifiers. That case is less common and yes, we generate code
\ that could be tighter, but it's not worth bothering.
: ?shiftW, ( -- ) exprtype SET <> if S) &) !, 1 i) @, S) &) <<, then ;
: mkset, ( args -- halop )
  dup setlit not ?err"non-const set literal expected" ( args constres )
  i) @, dup, PS+ begin ?dup while ( args )
    cdrcar dup ?cexpr if 2drop else ( args ast )
      exprW, ?shiftW, PSP) dir) |, then repeat ( )
  drop, PS- W) &) ;

: mkrange1, ( lowop highop -- halop )
  ?pushS, ?pushA,
  A>) @, toW \ W=lo A=hi
  W) &) A>) -, \ A=bitcnt-1
  1 i) S>) @, \ S=bit
  W) &) S>) <<,
  0 i) @,
  32 i) A>) <) if,
  S) &) @, 1 i) A>) +, \ W=res A=bitcnt
  [compile] begin
    1 i) A>) -, ifnz,
    1 i) S>) <<, S) &) |,
    swap [compile] again [compile] then
  [compile] then
  ?popA, ?popS, W) &) ;

: mkrange2, ( other halop -- halop )
  toW dup, PS+ expr, PSP) mkrange1, nip, PS- ;

: mkrange,
  carcdr expr, dup (i? not if mkrange2, exit then ( other halop hi )
  nip swap expr, ( hi lowop )
  dup (i? ?err"non-constant range AST expected"
  swap i) mkrange1, ;

\ compile code that makes W point to the type of the expression
: gettype, ( halop -- )
   exprtype gcptr? if toW W) -4 +) @, else recordtypeop @, then ;

: nilerr abort"Trying to access a NIL pointer!\n" ;

: do[] ( cdr -- halop )
  cdrcar ?noopexprtk if rot exprW, else ( idxast arrayast )
    exprW, exprtype newreg reg&) !, ( idxast type )
    swap exprW, reg&) freereg then ( type halop )
  swap arraykind# if ( halop reftype count ptr? )
      ['] oob rot i) >=) ?br, ( halop reftype ptr? )
      not if dip &) | then
    else ( halop reftype ) \ open array
      ['] oob oover 4 +) >=) ?br, then ( halop reftype )
  dup typesz i) mulorshift, swap +, W) swap type) ;

kvtbl[ ( cdr -- halop )
\ "ident" ASTs only end up here when they are VAR args, halop is an address
op"ident" :> findident# @, W) swap unwrapptr# type) ;
op"neg" :> exprW, 0 i) swap-, W) &) ;
op"~" :> exprW, 0 i) =) bool, W) &) ;
op"^" :> exprW, exprtype anyptr# gcptr? if W) @, then W) ;
op"[]" ' do[]
op"." :>
  carcdr expr, ?ptrderef, ?gcderef, ( name halop )
  dup (i? if drop else dup testz, ['] nilerr ?brz, then
  swap exprtype getfield ( halop type off )
  dipswap +) swap type) ;
op"funcall" ' funcall
op"typeguard" :> car expr, ;
op"{}" ' mkset,
op".." ' mkrange,
op"IS" :>
  carcdr carcdr expr, gettype, ( modname-or-0 typename )
  findtypeinmodule# ( tgttype )
  ?pushA,
  gcptrorstruct# i) A>) @, [compile] begin \ W=structtype A=tgttype
    A) &) <>) if, W) REFTYPEOFF +) @, swap 0 i) <>) ?br,
  [compile] then 0 i) <>) bool, ?popA, W) &) ;
op"*" :> 0 binop ;
op"/" :> 1 binop ;
op"DIV" over
op"MOD" :> 2 binop ;
op"LSL" :> 3 binop ;
op"LSR" :> 4 binop ;
op"ASR" :> 5 binop ;
op"MIN" :> 8 binop ;
op"MAX" :> 9 binop ;

:~ ( ast cond -- type halop )
  swap cdrcar expr, ?ptrderef, BOOLEAN exprtype=# ( cond rightast op )
  toW 0 i) rot if, ( rightast jmp )
  swap expr, ?ptrderef, BOOLEAN exprtype=# ( jmp op )
  toW [compile] then W) &) ;
op"&" :> <>) ~ ;
op"OR" :> =) ~ ;
op"+" :> 6 binop ;
op"-" :> 7 binop ;
op"=" :> =) condop ;
op"#" :> <>) condop ;
op"<" :> <) condop ;
op"<=" :> <=) condop ;
op">" :> >) condop ;
op">=" :> >=) condop ;
op"IN" :> carcdr exprW, noopexpr# >>, 1 i) &, W) &) ;
op"LEN" :> expr, arraylenop ;
op"VAL" :> cdr expr, ;
op"ORD" :> expr, ;
op"CHR" :> expr, ;
op"ADR" :> expr, &) ;

:~ ( cdr -- ) exprW, INTEGER exprtype=# ;
op"ODD" :> ~ 1 i) &, W) &) ;
op"ABS" :> ~ 0 i) signed) <) if, 0 i) swap-, [compile] then W) &) ;
op"ROR" :>
  carcdr expr, dup (W? ?err"TODO: ROR with W"
  swap exprW, ( halop )
  dup (i? if nip rorn, else ror, then
  W) &) ;
]kvtbl tbl

:realias expr,
  dup asttype >r ?noopexprk not if
    carcdr tbl rot ?kvexec not ?err"invalid opid" then
  r> to exprtype ;

: constexpr< ( -- n ) ast< dup asttype to exprtype cexpr# ;