File:  [gforth] / gforth / oldlib.fs
Revision 1.7: download - view: text, annotated - select for diffs
Mon Dec 31 18:40:24 2007 UTC (11 years, 9 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright notices for GPL v3

    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>