Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | \ lib.fs shared library support package 11may97py |
| 2 : | |||
| 3 : | \ Copyright (C) 1995,1996,1997,1998,2000 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 : | : @lib ( lib -- ) | ||
| 34 : | \G obtains library handle | ||
| 35 : | cell+ dup 2 cells + count open-lib | ||
| 36 : | dup 0= abort" Library not found" swap ! ; | ||
| 37 : | |||
| 38 : | : @proc ( lib addr -- ) | ||
| 39 : | \G obtains symbol address | ||
| 40 : | cell+ tuck 2 cells + count rot cell+ @ | ||
| 41 : | lib-sym dup 0= abort" Proc not found!" swap cell+ ! ; | ||
| 42 : | |||
| 43 : | : proc, ( pars type lib addr -- ) | ||
| 44 : | \G allocates and initializes proc stub | ||
| 45 : | \G stub format: | ||
| 46 : | \G linked list in library | ||
| 47 : | \G address of proc | ||
| 48 : | \G offset in lcall1-table to call proc | ||
| 49 : | \G OS name of symbol as counted string | ||
| 50 : | here 2dup swap 2 cells + dup @ A, ! | ||
| 51 : | 2swap 1 and IF fcall-table ELSE icall-table THEN swap | ||
| 52 : | cells 2* + , 0 , bl sword string, @proc ; | ||
| 53 : | |||
| 54 : | -1 Constant (addr) | ||
| 55 : | 0 Constant (int) | ||
| 56 : | 1 Constant (float) | ||
| 57 : | 2 Constant (void) | ||
| 58 : | 4 Constant (int...) | ||
| 59 : | 5 Constant (float...) | ||
| 60 : | 6 Constant (void...) | ||
| 61 : | |||
| 62 : | : proc: ( pars type lib "name" "string" -- ) | ||
| 63 : | \G Creates a named proc stub | ||
| 64 : | Create proc, | ||
| 65 : | DOES> ( x1 .. xn -- r ) | ||
| 66 : | cell+ 2@ >r ; | ||
| 67 : | |||
| 68 : | : vaproc: ( pars type lib "name" "string" -- ) | ||
| 69 : | \G Creates a named proc stub with variable arguments | ||
| 70 : | Create proc, | ||
| 71 : | DOES> ( x1 .. xn n -- r ) | ||
| 72 : | cell+ 2@ rot 2* cells + >r ; | ||
| 73 : | |||
| 74 : | : (>void) >r ; | ||
| 75 : | |||
| 76 : | : vproc: ( pars type lib "name" "string" -- ) | ||
| 77 : | \G Creates a named proc stub for void functions | ||
| 78 : | Create proc, | ||
| 79 : | DOES> ( x1 .. xn -- ) | ||
| 80 : | cell+ 2@ (>void) drop ; | ||
| 81 : | |||
| 82 : | : vvaproc: ( pars type lib "name" "string" -- ) | ||
| 83 : | \G Creates a named proc stub with variable arguments, void return | ||
| 84 : | Create proc, | ||
| 85 : | DOES> ( x1 .. xn n -- ) | ||
| 86 : | cell+ 2@ rot 2* cells + (>void) drop ; | ||
| 87 : | |||
| 88 : | : label: ( type lib "name" "string" -- ) | ||
| 89 : | \G Creates a named label stub | ||
| 90 : | -1 -rot Create proc, | ||
| 91 : | DOES> ( -- addr ) | ||
| 92 : | [ 2 cells ] Literal + @ ; | ||
| 93 : | |||
| 94 : | : library ( "name" "file" -- ) | ||
| 95 : | \G loads library "file" and creates a proc defining word "name" | ||
| 96 : | \G library format: | ||
| 97 : | \G linked list of libraries | ||
| 98 : | \G library handle | ||
| 99 : | \G linked list of library's procs | ||
| 100 : | \G OS name of library as counted string | ||
| 101 : | Create here libs @ A, dup libs ! | ||
| 102 : | 0 , 0 A, bl sword string, @lib | ||
| 103 : | DOES> ( pars/ type -- ) | ||
| 104 : | over -1 = IF label: | ||
| 105 : | ELSE | ||
| 106 : | over 4 and IF | ||
| 107 : | over 2 and IF vvaproc: ELSE vaproc: THEN | ||
| 108 : | ELSE | ||
| 109 : | over 2 and IF vproc: ELSE proc: THEN | ||
| 110 : | THEN | ||
| 111 : | THEN ; | ||
| 112 : | |||
| 113 : | : init-shared-libs ( -- ) | ||
| 114 : | defers 'cold libs | ||
| 115 : | 0 libs BEGIN @ dup WHILE dup REPEAT drop | ||
| 116 : | BEGIN dup WHILE >r | ||
| 117 : | r@ @lib | ||
| 118 : | r@ 2 cells + BEGIN @ dup WHILE r@ over @proc REPEAT | ||
| 119 : | drop rdrop | ||
| 120 : | REPEAT drop ; | ||
| 121 : | |||
| 122 : | ' init-shared-libs IS 'cold |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |