1: \ lib.fs shared library support package 11may97py
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005,2007 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation, either version 3
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program. If not, see http://www.gnu.org/licenses/.
19:
20: Create icall-table
21: ] icall0 ;s icall1 ;s icall2 ;s icall3 ;s icall4 ;s icall5 ;s icall6 ;s
22: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap
23: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap icall20 ;s [
24: Create fcall-table
25: ] fcall0 ;s fcall1 ;s fcall2 ;s fcall3 ;s fcall4 ;s fcall5 ;s fcall6 ;s
26: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap
27: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap fcall20 ;s [
28:
29: Variable libs 0 libs !
30: \G links between libraries
31:
32: Variable legacy legacy off
33:
34: : @lib ( lib -- )
35: \G obtains library handle
36: cell+ dup 2 cells + count open-lib
37: dup 0= abort" Library not found" swap ! ;
38:
39: : @proc ( lib addr -- )
40: \G obtains symbol address
41: cell+ tuck 2 cells + count rot cell+ @
42: lib-sym dup 0= abort" Proc not found!" swap cell+ ! ;
43:
44: -1 Constant <addr>
45: 0 Constant <int>
46: 1 Constant <float>
47: 2 Constant <void>
48: 4 Constant <int...>
49: 5 Constant <float...>
50: 6 Constant <void...>
51:
52: : proc, ( pars type lib addr -- )
53: \G allocates and initializes proc stub
54: \G stub format:
55: \G linked list in library
56: \G address of proc
57: \G offset in lcall1-table to call proc
58: \G OS name of symbol as counted string
59: legacy @ IF (int) -rot THEN
60: here 2dup swap 2 cells + dup @ A, !
61: 2swap 1 and IF fcall-table ELSE icall-table THEN swap
62: cells 2* + , 0 , bl sword string, @proc ;
63:
64: : proc: ( pars type lib "name" "string" -- )
65: \G Creates a named proc stub
66: Create proc,
67: DOES> ( x1 .. xn -- r )
68: cell+ 2@ >r ;
69:
70: : vaproc: ( pars type lib "name" "string" -- )
71: \G Creates a named proc stub with variable arguments
72: Create proc,
73: DOES> ( x1 .. xn n -- r )
74: cell+ 2@ rot 2* cells + >r ;
75:
76: : (>void) >r ;
77:
78: : vproc: ( pars type lib "name" "string" -- )
79: \G Creates a named proc stub for void functions
80: Create proc,
81: DOES> ( x1 .. xn -- )
82: cell+ 2@ (>void) drop ;
83:
84: : vvaproc: ( pars type lib "name" "string" -- )
85: \G Creates a named proc stub with variable arguments, void return
86: Create proc,
87: DOES> ( x1 .. xn n -- )
88: cell+ 2@ rot 2* cells + (>void) drop ;
89:
90: : label: ( type lib "name" "string" -- )
91: \G Creates a named label stub
92: -1 -rot Create proc,
93: DOES> ( -- addr )
94: [ 2 cells ] Literal + @ ;
95:
96: : library ( "name" "file" -- )
97: \G loads library "file" and creates a proc defining word "name"
98: \G library format:
99: \G linked list of libraries
100: \G library handle
101: \G linked list of library's procs
102: \G OS name of library as counted string
103: Create here libs @ A, dup libs !
104: 0 , 0 A, bl sword string, @lib
105: DOES> ( pars/ type -- )
106: over -1 = IF label:
107: ELSE
108: over 4 and IF
109: over 2 and IF vvaproc: ELSE vaproc: THEN
110: ELSE
111: over 2 and IF vproc: ELSE proc: THEN
112: THEN
113: THEN ;
114:
115: : init-shared-libs ( -- )
116: defers 'cold libs
117: 0 libs BEGIN @ dup WHILE dup REPEAT drop
118: BEGIN dup WHILE >r
119: r@ @lib
120: r@ 2 cells + BEGIN @ dup WHILE r@ over @proc REPEAT
121: drop rdrop
122: REPEAT drop ;
123:
124: ' init-shared-libs IS 'cold
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>