decimal
requires fcall.f

create cload.f ," %I% %E%"

lvariable cload-base

\ Move up to a longword boundary for the Sun loader, which
\ likes to align everything on a longword boundary
: lalign ( addr -- addr-aligned ) 3 + [ 3 not ] literal and ;

0 cload-base !

: struct 0 ;
: field ( offset size -- offset' )
  create over , +
  does> @ +
;
struct  ( "exec" structure - a.out header )
  /c field a_toolversion
  /c field a_machtype
  /w field a_magic
  /l field a_text
  /l field a_data
  /l field a_bss
  /l field a_syms
  /l field a_entry
  /l field a_trsize
  /l field a_drsize
constant /exec
create exec /exec allot

: /text  ( -- size-of-text-segment )   exec a_text @ ;
: /data  ( -- size-of-data-segment )   exec a_data @ ;
: /bss   ( -- size-of-bss-segment )    exec a_bss  @ ;
: /syms  ( -- size-of-symbol-table )   exec a_syms @ ;
: /reloc ( -- size-of-relocation )     exec a_trsize @  exec a_drsize @  + ;

: text0  ( -- file-address-of-text ) /exec ;
: data0  ( -- file-address-of-data ) text0 /text + ; 
: reloc0 ( -- file-address-of-relocation ) data0 /data + ; 
: syms0  ( -- file-address-of-symbols ) reloc0 /reloc + ; 
: string0 ( -- file-address-of-strings ) syms0 /syms + ; 

variable sym#
variable tf
: initsym 0 sym# ! ;
struct ( symbol table entry )
  /l field strx
  /c field sym_type
  /c field other
  /w field desc
  /l field value
constant /sym
: #syms  ( -- number-of-symbols )  /syms /sym / ;

create sym /sym allot
: getsym ( sym# -- )
  /sym *  syms0 + tf @ fseek  drop
  sym /sym tf @ fgets
  /sym <> if ." Couldn't get symbol" then
;
: moresyms?  sym# @ #syms < ;
: nextsym ( -- )
  sym# @  #syms >=  abort" No more symbols"
  sym# @ getsym
       1 sym# +!
;
: getsymname ( -- name )
  sym strx l@  ( index into string table )
  string0 +  tf @ fseek  drop
  pad  0  tf @  getcword
;

: .symname ( -- )
  getsymname count type
;
: .sym ( -- )
  .symname  getsymname count nip  ( name-length )  td 14 swap - spaces
  ." Type "  sym sym_type c@ u.
  ." Other " sym other    c@ u.
  ." Desc "  sym desc     w@ 5 u.r space
  ." Value " sym value    l@ 8 u.r
  cr
;
: ?magic  ( -- )
  exec a_magic w@  th 107 over <> swap 2 <> and
  abort" Magic number is not (octal) 407 or 2"
;
: opena.out ( name -- )
  read open
  ?dup 0= abort" Can't open file"
  tf !
  exec /exec tf @ fgets
  /exec <> abort" Can't read header"
  ?magic
  initsym
;
nuser (fret
nuser (ret  ( depends on these 2 being allocated consequetively )
code ret ( -- last-function-return-value )
  'user# (ret   up d)  sp -) lmove
c;

: text-sym: ( -- )
  getsymname "create   sym value l@  l,
 ;code
  \ Remember UP and RP in a global place in case the C routine calls forth
  th 4800 #  fregs l#) movem
  w ) a0 lmove   a0 ) jsr
  d1  'user# (fret  up d)  lmove
  d0  'user# (ret   up d)  lmove
c;
: data-bss-sym: ( -- )
  getsymname "create   sym value l@  l,  ( basically a constant )
  ;code  w ) sp -) lmove
c;

: process-symbol ( -- )
  sym value l@   cload-base l@  l>=
  if    sym sym_type c@   5 =
        if   text-sym:
\             .symname space
        else sym sym_type c@ dup 7 = swap 9 = or
             if   data-bss-sym:
             else cr .symname space ." is not a recognizable symbol" abort
             then
        then
  then
;
: textload ( addr -- )
                           ( text-start )
  text0  tf @ fseek drop
  \ FIXME Should sbrk here ( actually allot should do it )

  \ allocate the text segment and fill it from the file
       dup /text tf @  fgets
       /text <> abort" Can't load text segment"
    /text +                ( text-end )

  \ allocate the data segment and fill it from the file
  lalign                   ( data-start )
       dup /data  tf @ fgets
       /data <> abort" Can't load data segment"
    /data +                ( data-end )

  \ allocate the bss segment and fill it with zeroes.
  lalign                   ( bss-start )
       dup /bss erase
    /bss  +                ( bss-end )
  drop
;

: cload ( name -- )
  opena.out
  exec a_entry l@ ( load-address )  cload-base l@
  <> abort" Load address in object file disagrees with cload-base"
  cload-base l@ textload
\t32  cload-base l@  /text lalign l+  /data lalign l+  /bss lalign l+  dp !
  initsym
  begin moresyms?
  while nextsym  process-symbol
  repeat
\t16  /text lalign  /data lalign l+  /bss lalign l+  cload-base +!
  tf @ close
;
: .a.out ( name -- )
  opena.out
  initsym
  hex
  begin moresyms?
  while nextsym  .sym  
  repeat
  tf @ close
;
: :ccall ( addr name -- )
  "create   l,
  ;code  w ) a0 lmove   a0 ) jsr
  d1  'user# (fret  up d)  lmove
  d0  'user# (ret   up d)  lmove
c;