callback.fs 1.89 KB
Newer Older
bp's avatar
bp committed
1 2 3 4 5 6 7 8 9 10 11
\ callbacks for bigFORTH                             11jan2007py

Vocabulary callbacks

Code (callback
    R:  AX pop  SI push  UP push  OP push  sys-sp A#) push
    -$2000 SP D) SI lea
    [IFDEF] win32
	3 [FOR] -$1000 SP D) SP lea  SP ) CX mov  [NEXT]
	$2000 SI D) SP lea  [THEN]
    ;c: 'up @ up!  rp@ $3F00 - sys-sp !
bp's avatar
bp committed
12 13
    s0 @ >r sp@ 1 cells + s0 !  rp@ 6 cells + swap  catch
    ?dup IF  r> s0 ! r> sys-sp !  throw  THEN
bp's avatar
bp committed
14 15 16 17 18 19 20 21 22 23 24 25 26
    r> s0 !  >c: R:  sys-sp A#) pop  OP pop  UP pop  SI pop
    ret  end-code

: calldoes, ( -- )
  DOES>  Create postpone (callback
    @ compile, compile, 0 postpone ; ;
: callback  Create  here 0 , calldoes,
    also callbacks :noname ;

also callbacks definitions

Code (int)   AX DX mov  AX pop
    Next end-code macro 0 :ax T&P
bp's avatar
bp committed
27 28
' (int) alias (float)
' (int) alias (void)
bp's avatar
bp committed
29 30
Code int   AX push  DX ) AX mov  cell # DX add
    Next end-code macro :ax 0 T&P
bp's avatar
bp committed
31 32 33 34
Code df  .fl DX ) fld  8 # DX add
    Next end-code macro
Code sf  .fs DX ) fld  4 # DX add
    Next end-code macro
bp's avatar
bp committed
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53

previous definitions

: callback;  postpone ; swap ! previous ; immediate

\ pointer calls                                      11jan2007py

| Code .save2   BP -4 SI D) mov  -4 SI D) SI lea
    sys-sp A#) BP mov  Next end-code macro

also dos

: fptr  ind-call on  s-offset off  direction off
    : compile .save2
    legacy @ IF  legacy @ 0< IF  compile <rev>  THEN
	swap compile ints compile (int)  THEN ;

previous

bp's avatar
bp committed
54 55 56
: func@ ( xt -- cfptr ) dup 2- wx@ abs + &11 - cfa@ ;
: func' ' func@ ;
: [func'] postpone ['] postpone func@ ; immediate restrict
57 58
\ converts a C binding to its function pointer

bp's avatar
bp committed
59
\ example
bp's avatar
bp committed
60
false [IF]
bp's avatar
bp committed
61 62
callback 2:1 (int) int int callback;
: cb-test  ." Testing callbacks:" .s ." gives " + .s cr ;
bp's avatar
bp committed
63
: cb-test2  ." Testing callbacks:" .s ." gives " + .s cr abort" failed" ;
bp's avatar
bp committed
64
' cb-test 2:1 c_plus
bp's avatar
bp committed
65
' cb-test2 2:1 c_plus2
bp's avatar
bp committed
66 67
dos legacy off fptr 2:1call int int (int) forth
1 2 c_plus 2:1call .
bp's avatar
bp committed
68
1 2 c_plus2 2:1call .
bp's avatar
bp committed
69
[THEN]