needs lib/str lib/psrs lib/match lib/diag mem/dict mem/kv mem/cons
unit emul/aml

stringlist types
  int string buffer ref package name mutex scope device thermz pwrres \
  oregion ofield method bfield

types slistlen const TYPESCNT
: gettypeid ( str -- opid ) types sfind not ?abort"type not found" ;
:~ [rcompile] " gettypeid ;
:> ~ litn ;
' ~ compiling t"
: typename types slistiter dup c@ not ?abort"wrong typeid" ;

0 value baseaddr

\ OperationRegion spaces
enum SystemMemory SystemIO PCIConfig EmbeddedControl SMBus SystemCMOS \
     PciBarTarget IPMI GPIO GenericSerialBus PPC PlatformRtMechanism
enumrev oregionspacerev

: newscope ( objs name-or-ref type -- ) rot> swap cons cons ;
: scopeobjs ( scope -- objs ) cdr cdr ; \ doesn't work on pwrres
: objname ( obj -- name ) cdr car ;

alias abort .obj ( obj -- )
0 value indent
: indent+ doto indent 2+ | ;
: indent- doto indent 2- | ;
: .objsnl ( objs -- )
  indent+ begin ?dup while indent nspcs cdrcar .obj nl> repeat indent- ;
: .objs ( objs -- ) begin cdrcar .obj ?dup while spc> repeat ;
variable _
: .name ( name -- ) _ be! _ 4 rtype ;
:~ cdrcar .name nl> .objsnl ;
: .device ( cdr -- ) ."DEVICE " ~ ;
: .thermz ( cdr -- ) ."THERMAL ZONE " ~ ;
: .scope ( cdr -- )
  dup car if ."SCOPE " cdrcar .obj nl> else ."ROOT\n" cdr cdr then .objsnl ;
: .pwrres ( cdr -- )
  ."PWRRES " cdrcar .name spc> carcdr carcdr . spc> . nl> .objsnl ;
: .oregion ( cdr -- )
  cdrcar .name spc>
  cdrcar oregionspacerev rtype cdrcar ( length offset )
  ."(" .obj spc> .obj .")" ;
: .ofield ( cdr -- )
  cdrcar .name ." FIELD[" cdrcar ( cdr oregion )
  .obj ."] " cdrcar .x1 spc> cdrcar ( bitoff bitcnt )
  .x spc> .x ;
: .method ( cdr -- ) cdrcar .name ." METHOD " car .x1 ;
: .bfield ( cdr -- )
   cdrcar .name ." BFIELD " cdrcar .obj spc> cdrcar . spc> ( cdr )
   cdrcar .obj spc> . ;

kvtbl[ ( cdr -- )
t"int" :> cdrcar .x ?dup if spc> .x then ;
t"string" :> '"' emit z[] rtype '"' emit ;
t"buffer" :> ."Buffer(" cdrcar .obj ."){" carcdr cspit[] ."}" ;
t"ref" :> ."ref(" carcdr rtype .")" ;
t"package" :> ."{" .objs ."}" ;
t"name" :> cdrcar .name spc> .obj ;
t"mutex" :> cdrcar .name spc> . ;
t"device" ' .device
t"scope" ' .scope
t"thermz" ' .thermz
t"pwrres" ' .pwrres
t"oregion" ' .oregion
t"ofield" ' .ofield
t"method" ' .method
t"bfield" ' .bfield
]kvtbl tbl
:realias .obj ( obj -- ) cdrcar tbl swap ?kvexec not ?abort"bad AML object" ;

: be@+ ( a -- a+ n ) bi 4+ | be@ ;
: rdpkglen ( a -- a+ len )
  c@+ dup 6 rshift ?dup if ( a nybble nbytes )
    dip $3f and | 0 do ( a res )
      swap c@+ i 8* 4+ lshift rot or loop then ;
: rdpkglenadj ( a -- a+ len ) \ remove its own length from the tally
  dup c@ 6 rshift 1+ swap rdpkglen rot - ;
: addobj ( ... n a obj -- ... obj n+1 a ) rot> dip 1+ | ;
: mkobjs ( ... n -- objs-or-0 )
  dup not if exit then
  dip 0 cons | begin ( ... objs n ) 1- ?dup while rot> cons swap repeat ;

: namechar? ( c -- f ) rmatch"09AZ__" ;
: name@+ ( a -- a+ name )
  be@+ dup 24 rshift namechar? not ?abort"name expected" ;
: ?rdnamepath ( a -- a u-or-0 )
  dup c@ namechar? if 4 exit then
  0 begin ( a u ) 2dup + c@ bi '^' = | '\' = or while 1+ repeat ( a u )
  0 >r begin 2dup + c@ '.' = while doto V1 1+ | 1+ repeat r> 4* + ( a u )
  ?dup if 4+ else dup dup c@ namechar? 4* then ;
: ?rdref ( a -- a+ ref-or-0 )
  ?rdnamepath dup if 2dup cons t"ref" swap cons dip + | then ;
: rdref# ?rdref dup not ?abort"namepath expected" ;

alias abort runaml1 ( a -- a obj-or-0 )
: runaml1# runaml1 ?dup not ?abort"runaml1 yielded 0" ;

: limit# ( a a -- a ) over <> ?abort"AML code length inconsistency" ;
: bufferop ( a -- a obj )
  rdpkglenadj over runaml1# ( orig-a pkglen new-a lenobj )
  >r r! rot - ( pkglen a-diff V1=lenobj V2=new-a )
  - V2 over cons V1 swap cons t"buffer" swap cons ( buflen bufobj )
  r> rot + rdrop swap ;
: packageop ( a -- a obj )
  rdpkglenadj over + swap c@+ ( limit a numelems )
  0 0 cons r! swap 0 do ( limit a tail V1=head )
    swap runaml1# dipswap append loop drop limit# ( a )
  t"package" r> cdr cons ;

: newint ( n -- obj ) 0 cons t"int" swap cons ;
0 newint leak const ZEROINT
1 newint leak const ONEINT
-1 newint leak const ONESINT

kvtbl[ ( a -- a obj )
$00 ' ZEROINT
$01 ' ONEINT
$0a :> ( BytePrefix ) c@+ newint ;
$0b :> ( WordPrefix ) dup wle@ newint dip 2+ | ;
$0c :> ( DWordPrefix ) dup le@ newint dip 4+ | ;
$0d :> ( StringPrefix ) t"string" over cons dip dup zstrlen + 1+ | ;
$11 ' bufferop
$12 ' packageop
$ff ' ONESINT
]kvtbl tbl
:realias runaml1 ( a -- a obj-or-0 )
  c@+ tbl swap ?kvexec not if 1- ?rdref then ;

alias abort runaml[] ( a u -- )
: mutexop ( a -- a ) name@+ swap c@+ dipswap cons t"mutex" swap cons addobj ;

: oregionop ( ... n a -- ... n a )
  name@+ swap c@+ swap ( name space a )
  runaml1# swap runaml1# ( name space offset a length )
  swap 5 roll> ( a name space offset length )
  cons cons cons t"oregion" swap cons leak addobj ;
: ofieldsop ( ... n a -- ... n a )
  rdpkglenadj over + >r ( ... n a V1=limit )
  rdref# >r c@+ >r 0 >r ( limit a V2=oregion V3=flags V4=off )
  begin V1 over > while ( ... n a )
    dup c@ case
      0 = of 1+ rdpkglen doto V4 + | endof
      1 = of abort"TODO AccessField" endof
      drop name@+ swap rdpkglen ( ... n name a bitcnt )
      doto V4 2dup + | ( ... n name a bitcnt bitoff )
      swap cons V3 swap cons V2 swap cons dipswap cons ( ... n a cdr )
      t"ofield" swap cons leak addobj endcase repeat
  2rdrop rdrop r> swap limit# ;

: rddevlike ( ... n a objtype -- ... n a )
  >r rdpkglenadj 4- swap name@+ >r ( len a V1=objtype V2=name )
  2dup + >r swap runaml[] ( ... n ... n V3=a+ )
  mkobjs V2 V1 newscope ( ... n obj )
  r> swap addobj ( ... n a+ ) 2rdrop ;

: scopeop ( ... n a -- ... n a )
  rdpkglenadj swap rdref# ( ... n pkglen a ref )
  r! cdr cdr rot swap- ( ... n a len V1=ref )
  2dup + >r runaml[] ( ... n ... n V2=a+ )
  mkobjs V1 t"scope" newscope ( ... n obj )
  r> swap addobj ( ... n a+ ) rdrop ;

: pwrresop ( a -- a )
  rdpkglenadj 7 - swap name@+ >r ( len a V1=name )
  c@+ over wle@ cons >r 2+ ( len a V2=tail )
  2dup + >r swap runaml[] ( ... n ... n V3=a+ )
  mkobjs V2 cons V1 swap cons t"pwrres" swap cons ( ... n pwrres )
  r> swap addobj ( ... n a+ ) 2rdrop ;

\ this is a temporary stub for ops I'll implement later. I'd like to get to
\ a namespace I can explore first.
: skiplen ( a -- a )
  rdpkglenadj ."Skipping " dup . ." bytes at " over baseaddr - .x + nl> ;

: nameop ( ... n a -- ... n a )
  name@+ swap runaml1# dipswap cons t"name" swap cons addobj ;

: methodop ( ... n a -- ... n a )
  rdpkglenadj 5 - swap name@+ swap c@+ ( amllen name a flags )
  >r oover over + >r ( amllen name a V1=flags V2=a+ )
  rot cons r> r> rot cons ( name a+ cdr )
  dipswap cons t"method" swap cons leak addobj ;

: createbytefield ( ... n a -- ... n a )
  rdref# swap runaml1# swap name@+ ( ref idxobj a name )
  swap 4 roll> ( a ref idxobj name )
  swap 1 cons 8 swap cons dipswap cons cons t"bfield" swap cons addobj ;

kvtbl[ ( ... n a -- ... n a )
$08 ' nameop
$10 ' scopeop
$14 ' methodop
$5b01 ' mutexop
$5b80 ' oregionop
$5b81 ' ofieldsop
$5b82 :> ( DeviceOp ) t"device" rddevlike ;
$5b83 ' skiplen \ ProcessorOp
$5b84 ' pwrresop
$5b85 :> ( ThermalZoneOp ) t"thermz" rddevlike ;
$5b86 ' skiplen \ IndexFieldOp
$8c ' createbytefield
$a0 ' skiplen \ IfOp
]kvtbl tbl
:realias runaml[] ( a u -- ... n )
  over + >r 0 swap begin ( ... n a )
    c@+ dup $5b = if drop c@+ $5b00 or then ( ... n a c )
    tbl swap ?kvexec
    not if ."Unsupported AML op at " 1- baseaddr - .x nl> abort then
  r@ over <= until
  r> swap limit# drop ;

: getamlns ( a u -- scope )
  over to baseaddr runaml[] mkobjs 0 t"scope" newscope ;