\ OS Library load                                      14dec08py
Variable libs  NIL libs A!      \ links between library threads
H 0 cells Constant :getlib      1 cells Constant :procaddr T

Code getlib ( addr len -- lib/0 )  DX pop  [IFDEF] :win32
     SI push  DI push  BP push  SP BP mov
     sys-sp A#) SP mov  [ELSE]
     SP -4 SI D) mov  -$10 # SP and   DX push  DX push  [THEN]
     DX push  AX push  ' ftab 5 + A#) AX mov  :getlib AX D) call
     [IFDEF] :win32  BP SP mov  BP pop  DI pop  SI pop
     [ELSE]  -4 SI D) SP mov  [THEN]  Next end-code

\ OS Library load                                      14dec08py

Code procaddr ( addr len lib -- addr/0 )  DX pop  CX pop
     [IFDEF] :win32  SI push  DI push  BP push  SP BP mov
     sys-sp A#) SP mov  [ELSE]
     SP -4 SI D) mov  -$10 # SP and  CX push  [THEN]
     CX push  DX push  AX push
     ' ftab 5 + A#) AX mov   :procaddr AX D) call
     [IFDEF] :win32  BP SP mov  BP pop  DI pop  SI pop
     [ELSE]  -4 SI D) SP mov  [THEN]  Next end-code

\ OS Library load                                      12jan07py
: @lib ( lib -- )  cell+ dup 3 cells + count getlib
  dup 0= IF  over 3 cells + count type
             true abort" Library not found!"  THEN  swap ! ;
: @proc ( lib addr -- )  over cell+ @ 0= IF  over @lib  THEN
  tuck cell+ cell+ count rot cell+ @ procaddr dup 0=
  IF  drop ." in library: " dup cell+ @ $10 + count type
      ."  procedure: " 2 cells + count type cr
      true abort" procedure not found!"  THEN swap 10 - call! ;
| : resolve-syms ( -- )
    [IFDEF] :win32  sys-sp @ r>  rp@ $40 - sys-sp !
            dup 5 - >r   swap >r 10 + @ @syms r> sys-sp !
    [ELSE]  r> dup 5 - >r 10 + @ @syms  [THEN] ;
: @libs  libs LIST> dup cell+ off  2 cells +
  LIST> 10 - ['] resolve-syms swap call! ;
| Code .call  R: AX call  next end-code macro :r :r T&P

\ push macros                                          23aug03py
| Code .swap ( n1 n2 -- n2 n1 )  AX pop DX pop AX push DX push
       Next end-code macro
| Code .int ( n -- )    0 BP D) pop        Next  end-code macro
| Code .sfloat ( sf -- ) .fs 0 BP D) fstp  Next end-code macro
| Code .dfloat ( df -- ) .fl 0 BP D) fstp  Next end-code macro
| Code .save ( -- )  AX push  BP -4 SI D) mov   -4 SI D) SI lea
       sys-sp A#) BP mov  Next end-code macro
| Code .correct ( -- )  0 BP D) BP lea   Next end-code macro
| Code .sys-stack ( -- )  BP SI xchg  Next end-code macro
| Code .voidr ( -- )  R: BP SP mov  BP pop  lods  nop
       Next end-code macro :r :r T&P
| Code .intr  ( -- )  R: BP SP mov  BP pop  nop   nop
       Next end-code macro :r :r T&P
| Code .llr ( -- )  R: BP SP mov  BP pop  S: AX push
       DX AX mov  Next end-code :r :r T&P

\ fp save and restore                                  05oct05py
Code fpush ( f.. -- )
     fxam  ( fwait )  AX fstsw  $FD # AH and  $41 # AH cmp
     0= IF  0 # -4 BP D) mov  -4 # BP add  Next  THEN
     $B # AX shr  7 # AX and  7 # AX xor   1 AX D) CX lea
     BEGIN  .fx -$C BP D) fstp  $C # BP sub  AX dec  0< UNTIL
     CX -4 BP D) mov  -4 # BP add  Next  end-code
Code fppll ( -- f.. )  R: BP SP mov  S: AX push DX AX mov  R:
     AHEAD  end-code
Code fppi ( -- f.. )  R:  BP SP mov  AHEAD  end-code
Code fppv ( -- f.. )  R:  BP SP mov  lods  THEN  THEN
     CX pop  ?DO  .fx SP ) fld  $C # SP add
                  CX dec  0= UNTIL THEN  BP pop  Next end-code
Code fppf ( -- f.. )  R:  BP SP mov  lods
     CX pop  ?DO  .fx SP ) fld  $C # SP add   1 ST fxch
                  CX dec  0= UNTIL THEN  BP pop  Next end-code

\ syscall compile primitives                           14dec08py
Variable s-offset               Variable direction
| Variable lastcorrect          | Variable thelib
Variable legacy                 Variable ind-call
| : !offset ( n -- )  direction @ 0= IF
         negate cells s-offset +!  THEN  s-offset @ here 3 - c!
    direction @    IF  cells s-offset +!  THEN ;
| : res,  ind-call @ IF  compile .call
    ELSE  compile resolve-syms  THEN ;
| : (proc)  ( xt -- ) correct   compile .sys-stack res,
    compile, compile ;  ind-call @ ?EXIT proc, ;
| : (fproc)  ( xt -- ) correct  compile .sys-stack compile fpush
    res, compile, compile ; ind-call @ ?EXIT proc, ;

\ syscall compile primitives                           23aug03py
: int ( -- )   compile .int     1 !offset ;  immediate restrict
' int Alias ptr                              immediate restrict
: llong ( -- )  direction @ IF  compile .swap  THEN
  compile int compile int ;                  immediate restrict
: ints ( -- )  0 ?DO  ['] int execute LOOP ; immediate restrict
: sf ( -- )    compile .sfloat  1 !offset ;  immediate restrict
: df ( -- )    compile .dfloat  2 !offset ;  immediate restrict
: (void) ( -- ) ['] .voidr (proc) ;          immediate restrict
: (int)  ( -- ) ['] .intr  (proc) ;          immediate restrict
: (llong) ( -- ) ['] .llr  (proc) ;          immediate restrict
' (int) Alias (ptr)                          immediate restrict
: (fp)   ( -- ) ['] fppf  (fproc) ;          immediate restrict
: (int/fp)      ['] fppi  (fproc) ;          immediate restrict
: (void/fp)     ['] fppv  (fproc) ;          immediate restrict
: (llong/fp) ( -- ) ['] fppll (fproc) ;      immediate restrict

\ OS Library load                                      22dec08py
: <rev> ( -- )  compile .correct  here 3 - lastcorrect !
  direction on ;                             immediate restrict
[IFDEF] :osx  | Variable aligncorrect  [THEN]
| : correct ( -- )  direction @ 0=
    IF   compile .correct  0 !offset
    ELSE s-offset @ negate lastcorrect @ c! THEN
[ [IFDEF] :osx ]
    s-offset @ abs cell+ negate $F and negate aligncorrect @ c!
[ [THEN] ] s-offset off ;
: proc:  ind-call off s-offset off direction off
  : compile .save
  [ [IFDEF] :osx ]
    compile .correct  here 3 - aligncorrect ! [ [THEN] ]
    legacy @ IF  legacy @ 0< IF  compile <rev>  THEN
                 swap compile ints compile (int/fp)  THEN ;

\ OS Library load                                      14dec08py

| : proc, ( -- ) here dup >r thelib @ 2 cells + dup @ A, !
    thelib @ dup A, bl word c@ 1+ allot cell+ @ warning @ or
    IF  thelib @ r@ @proc  THEN  rdrop ;
: library   ( -- ) Create  here libs @ A, dup libs ! 0 ,
  0 A, 0 A, bl word  c@ 1+ allot drop  DOES>  thelib !  proc: ;
: depends  libs @ 3 cells + dup @ here rot ! A, ' >body A, ;
| : @depend  ( addr -- ) dup 3 cells + LIST>  cell+ @ @syms ;
: @syms ( lib -- )  dup cell+ @ IF  drop  EXIT  THEN
  dup 3 cells + @  IF  @depend  THEN
  dup @lib dup thelib ! 2 cells + LIST> thelib @ swap @proc ;

