Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: callback.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | id: @(#)callback.fth 1.7 02/01/15 | |
43 | purpose: Callbacks into client program, callback and sync commands | |
44 | copyright: Copyright 1990-2002 Sun Microsystems, Inc. All Rights Reserved | |
45 | ||
46 | headerless | |
47 | 0 value cb-array | |
48 | : free-cb-array ( size -- ) | |
49 | cb-array 0 to cb-array | |
50 | swap free-mem | |
51 | ; | |
52 | create callback-err ," callback failed" | |
53 | headers | |
54 | ||
55 | nuser vector 0 vector ! | |
56 | ||
57 | : $callback ( argn .. arg1 nargs adr len -- retn .. ret2 ret1 Nreturns ) | |
58 | vector @ 0= abort" No callback routine has been installed" | |
59 | ||
60 | 2 pick 9 + /n* dup >r alloc-mem is cb-array | |
61 | cb-array r@ erase | |
62 | ||
63 | \ Prepare argument array | |
64 | $cstr cb-array ! \ service name ( argn .. arg1 nargs ) | |
65 | dup cb-array na1+ ! \ N_args ( argn .. arg1 nargs ) | |
66 | 6 cb-array 2 na+ ! \ N_rets ( argn .. arg1 nargs ) | |
67 | 0 ?do cb-array i 3 + na+ ! loop ( ) \ arg1 .. argN | |
68 | ||
69 | cb-array vector @ callback-call if | |
70 | r> free-cb-array callback-err throw | |
71 | then | |
72 | ||
73 | \ Compute address of ret1 | |
74 | cb-array na1+ @ ( n_args ) 3 + cb-array swap na+ ( ret1-adr ) | |
75 | ||
76 | \ Push N return values | |
77 | cb-array 2 na+ @ /n* over + ( ret1-adr retN+1-adr ) | |
78 | begin 2dup u< while /n - dup @ -rot repeat ( rN .. ret1-adr retX-adr ) | |
79 | 2drop ( retN .. ret2 ret1 ) | |
80 | ||
81 | cb-array 2 na+ @ ( retN .. ret2 ret1 N ) | |
82 | r> free-cb-array ( retN .. ret2 ret1 N ) | |
83 | dup 0<= if callback-err throw then ( retN .. ret2 ret1 N ) | |
84 | 1- swap throw ( retN .. ret2 N-1 ) | |
85 | ; | |
86 | : sync ( -- ) 0 " sync" $callback drop ; | |
87 | : callback \ service-name rest of line ( -- ) | |
88 | parse-word -1 parse dup over + 0 swap c! ( adr len arg-adr ) | |
89 | -rot 1 -rot $callback | |
90 | ; | |
91 | ||
92 | cif: interpret ( arg-P .. arg1 cstr -- res-Q ... res-1 catch-result ) | |
93 | only forth also definitions | |
94 | cscount ['] interpret-string catch dup if | |
95 | nip nip | |
96 | then | |
97 | ; | |
98 | ||
99 | cif: set-callback ( newfunc -- oldfunc ) vector @ swap vector ! ; | |
100 |