needs lib/psrs lib/type lib/bit mem/kv comp/oberon/type comp/oberon/ast
unit comp/oberon/cexpr

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

: signaturertype ( type -- type )
  signature# dup sigcounts nip 1 = if sigoutputs @ else drop void then ;

alias abort asttype ( ast -- type )

\ TODO generate dynamic typeguard check
: ?tgerr ?err"invalid typeguard" ;
: typeguard ( cdr -- type )
  carcdr typeast# swap asttype ( tgttype type )
  over gcptr? if
    dup gcptr? not ?tgerr
    reftype over reftype swap ( type tgtstruct struct )
  else
    over struct? not over structptr? not or ?tgerr
    over tmppointer ( tgtstruct structptr type )
    rot> reftype ( type tgtstruct struct ) then
  containsstruct? not ?tgerr ( tgtstruct ) ;

kvtbl[ ( cdr -- type )
op"lit" :> drop INTEGER ;
op"char" :> drop CHAR ;
op"str" :> zstrlen 1+ CHAR parena1r newarray parena1r newpointer ;
op"ident" :> findident# drop ?autoderef drop ;
op"ident." :> cdrcar modules find# findinmodule# drop ;
op"`" :> sysmodule findinmodule# drop ;
op"neg" ' asttype
op"~" :> drop BOOLEAN ;
op"ODD" over
op"&" over op"OR" over op"IS" over op"IN" over
op"=" over op"#" over op"<" over op"<=" over op">" over op">=" over
op"^" :> asttype anyptr# ?unwrapgcptr drop ;
op"[]" :> car asttype ?unwrapptr drop arraykind# if 2drop then ;
op"." :>
  carcdr asttype ?unwrapptr drop ?unwrapgcptr drop ( name structtype )
  getfield drop ;
op"funcall" :> car asttype signaturertype ;
op"typeguard" ' typeguard
op"{}" :> drop SET ;
op".." over
op"VAL" :> car typeast# ;
op"LEN" :> drop INTEGER ;
op"ADR" over op"ROR" over op"ABS" over
op"CHR" :> drop CHAR ;
op"ORD" :> drop BYTE ;
]kvtbl tbl
:realias asttype
  dup cdrcar tbl swap ?kvexec if nip exit then ( ast cdr )
  swap car case
    unary? of asttype ?autoderef drop endof
    binary? of car asttype ?autoderef drop endof
    err"can't determine type" endcase ;

alias abort ?cexpr ( ast -- ?n f )
: cexpr# ?cexpr not ?err"constant expression expected" ;

: unary ( cdr xt -- ?halop f )
  swap ?cexpr if swap execute i) 1 else drop 0 then ;
: unary> ' ['] unary bind> ;

: err err"invalid binop for SET" ;
: binary ( cdr setxt xt -- ?halop f )
  oover car asttype SET = if nip else drop then ( cdr xt )
  swap cdrcar ?cexpr if swap ?cexpr if ( xt ln rn )
    rot execute i) 1 else 2drop 0 then else 2drop 0 then ;
: binary> ' ' ['] binary bind> bind> ;

: setlit ( cdr -- constres f )
  0 >r 0 swap begin ?dup while ( res args V1=f )
    cdrcar dup ?cexpr if ( res args ast n )
      swap asttype SET = if rot or else dipswap bit1! then swap
      else drop 1 to V1 then ( res args )
    repeat ( res ) r> ;
: mkset ( cdr -- ?halop f ) setlit if drop 0 else i) 1 then ;

: mkrange
  cdrcar ?cexpr not if drop 0 exit then ( other lo )
  swap ?cexpr not if drop 0 exit then ( lo hi )
  1+ swap 0 rot> do i bit1! loop i) 1 ;

code asr ( n n -- n ) PSP) signed) dir) >>, drop, exit,
: in ( n n -- f ) 1 rot lshift and bool ;

alias abort ?noopexpr ( ast -- ?halop f )
kvtbl[ ( cdr -- ?halop f )
op"lit" :> i) 1 ;
op"char" over
op"str" over
op"ident" :> findident# swap varptr? if drop 0 else 1 then ;
op"ident." :> cdrcar modules find# findinmodule# nip 1 ;
op"`" :> sysmodule findinmodule# nip 1 ;
op"neg" unary> neg
op"~" unary> not
op"{}" ' mkset
op".." ' mkrange
op"+" binary> + or
op"-" binary> - invand
op"*" binary> * and
op"/" binary> / xor
op"DIV" over
op"MOD" binary> mod err
op"LSL" binary> lshift err
op"LSR" binary> rshift err
op"ASR" binary> asr err
op"MIN" binary> min err
op"MAX" binary> max err
\ TODO: These comparisons are unsigned.
op"<" binary> < err
op"<=" binary> <= err
op">" binary> > err
op">=" binary> >= err
op"=" binary> = err
op"#" binary> <> err
op"IN" binary> in err
op"VAL" :> cdr ?noopexpr ;
op"typeguard" :> car ?noopexpr ;
]kvtbl tbl
:realias ?noopexpr ( ast -- ?halop f )
  cdrcar tbl swap ?kvexec not if drop 0 then ;

: noopexpr# ?noopexpr not ?err"noopexpr expected" ;
: ?noopexprk ( ast -- ast 0 OR halop 1 ) dup ?noopexpr if nip 1 else 0 then ;
: ?noopexprt ( ast -- ?type ?halop f )
  dup ?noopexpr if dip asttype | 1 else drop 0 then ;
: ?noopexprtk ( ast -- ast 0 OR type halop 1 )
  dup ?noopexprt if dipnip 1 else 0 then ;
: noopexprt# ?noopexprt not ?err"noopexpr expected" ;

:realias ?cexpr ( ast -- ?n f ) ?noopexpr if (i? else 0 then ;