1: \ lib.fs shared library support package 11may97py
2:
3: \ Copyright (C) 1995,1996,1997,1998,2000,2003,2005 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 2
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, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: Create icall-table
22: ] icall0 ;s icall1 ;s icall2 ;s icall3 ;s icall4 ;s icall5 ;s icall6 ;s
23: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap
24: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap icall20 ;s [
25: Create fcall-table
26: ] fcall0 ;s fcall1 ;s fcall2 ;s fcall3 ;s fcall4 ;s fcall5 ;s fcall6 ;s
27: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap
28: NIL swap NIL swap NIL swap NIL swap NIL swap NIL swap fcall20 ;s [
29:
30: Variable libs 0 libs !
31: \G links between libraries
32:
33: Variable legacy legacy off
34:
35: : @lib ( lib -- )
36: \G obtains library handle
37: cell+ dup 2 cells + count open-lib
38: dup 0= abort" Library not found" swap ! ;
39:
40: : @proc ( lib addr -- )
41: \G obtains symbol address
42: cell+ tuck 2 cells + count rot cell+ @
43: lib-sym dup 0= abort" Proc not found!" swap cell+ ! ;
44:
45: -1 Constant <addr>
46: 0 Constant <int>
47: 1 Constant <float>
48: 2 Constant <void>
49: 4 Constant <int...>
50: 5 Constant <float...>
51: 6 Constant <void...>
52:
53: : proc, ( pars type lib addr -- )
54: \G allocates and initializes proc stub
55: \G stub format:
56: \G linked list in library
57: \G address of proc
58: \G offset in lcall1-table to call proc
59: \G OS name of symbol as counted string
60: legacy @ IF (int) -rot THEN
61: here 2dup swap 2 cells + dup @ A, !
62: 2swap 1 and IF fcall-table ELSE icall-table THEN swap
63: cells 2* + , 0 , bl sword string, @proc ;
64:
65: : proc: ( pars type lib "name" "string" -- )
66: \G Creates a named proc stub
67: Create proc,
68: DOES> ( x1 .. xn -- r )
69: cell+ 2@ >r ;
70:
71: : vaproc: ( pars type lib "name" "string" -- )
72: \G Creates a named proc stub with variable arguments
73: Create proc,
74: DOES> ( x1 .. xn n -- r )
75: cell+ 2@ rot 2* cells + >r ;
76:
77: : (>void) >r ;
78:
79: : vproc: ( pars type lib "name" "string" -- )
80: \G Creates a named proc stub for void functions
81: Create proc,
82: DOES> ( x1 .. xn -- )
83: cell+ 2@ (>void) drop ;
84:
85: : vvaproc: ( pars type lib "name" "string" -- )
86: \G Creates a named proc stub with variable arguments, void return
87: Create proc,
88: DOES> ( x1 .. xn n -- )
89: cell+ 2@ rot 2* cells + (>void) drop ;
90:
91: : label: ( type lib "name" "string" -- )
92: \G Creates a named label stub
93: -1 -rot Create proc,
94: DOES> ( -- addr )
95: [ 2 cells ] Literal + @ ;
96:
97: : library ( "name" "file" -- )
98: \G loads library "file" and creates a proc defining word "name"
99: \G library format:
100: \G linked list of libraries
101: \G library handle
102: \G linked list of library's procs
103: \G OS name of library as counted string
104: Create here libs @ A, dup libs !
105: 0 , 0 A, bl sword string, @lib
106: DOES> ( pars/ type -- )
107: over -1 = IF label:
108: ELSE
109: over 4 and IF
110: over 2 and IF vvaproc: ELSE vaproc: THEN
111: ELSE
112: over 2 and IF vproc: ELSE proc: THEN
113: THEN
114: THEN ;
115:
116: : init-shared-libs ( -- )
117: defers 'cold libs
118: 0 libs BEGIN @ dup WHILE dup REPEAT drop
119: BEGIN dup WHILE >r
120: r@ @lib
121: r@ 2 cells + BEGIN @ dup WHILE r@ over @proc REPEAT
122: drop rdrop
123: REPEAT drop ;
124:
125: ' init-shared-libs IS 'cold
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>