File:  [gforth] / gforth / fflib.fs
Revision 1.1: download - view: text, annotated - select for diffs
Fri Aug 15 21:45:46 2003 UTC (17 years, 8 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added high level part of ffcall interface

    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: Variable libs 0 libs !
   22: Variable thisproc
   23: Variable thislib
   24: \G links between libraries
   25: 
   26: : @lib ( lib -- )
   27:     \G obtains library handle
   28:     cell+ dup 2 cells + count open-lib
   29:     dup 0= abort" Library not found" swap ! ;
   30: 
   31: : @proc ( lib addr -- )
   32:     \G obtains symbol address
   33:     cell+ tuck cell+ @ count rot cell+ @
   34:     lib-sym  dup 0= abort" Proc not found!" swap ! ;
   35: 
   36: : proc, ( lib -- )
   37: \G allocates and initializes proc stub
   38: \G stub format:
   39: \G    linked list in library
   40: \G    address of proc
   41: \G    ptr to OS name of symbol as counted string
   42: \G    threaded code for invocation
   43:     here dup thisproc !
   44:     swap 2 cells + dup @ A, !
   45:     0 , 0 A, ;
   46: 
   47: : proc:  ( lib "name" -- )
   48:     \G Creates a named proc stub
   49:     Create proc, 0
   50: DOES> ( x1 .. xn -- r )
   51:     dup cell+ @ swap 3 cells + >r ;
   52: 
   53: : library ( "name" "file" -- )
   54:     \G loads library "file" and creates a proc defining word "name"
   55:     \G library format:
   56:     \G    linked list of libraries
   57:     \G    library handle
   58:     \G    linked list of library's procs
   59:     \G    OS name of library as counted string
   60:     Create  here libs @ A, dup libs !
   61:     0 , 0 A, bl sword string, @lib
   62: DOES> ( -- )  dup thislib ! proc: ;
   63: 
   64: : init-shared-libs ( -- )
   65:     defers 'cold  libs
   66:     0  libs  BEGIN  @ dup  WHILE  dup  REPEAT  drop
   67:     BEGIN  dup  WHILE  >r
   68: 	r@ @lib
   69: 	r@ 2 cells +  BEGIN  @ dup  WHILE  r@ over @proc  REPEAT
   70: 	drop rdrop
   71:     REPEAT  drop ;
   72: 
   73: ' init-shared-libs IS 'cold
   74: 
   75: ' av-int AConstant int
   76: ' av-float AConstant sf
   77: ' av-double AConstant df
   78: ' av-longlong AConstant llong
   79: ' av-ptr AConstant ptr
   80: 
   81: Variable revdec  revdec off
   82: \ turn revdec on to compile bigFORTH libraries
   83: 
   84: : rettype ( endxt startxt "name" -- )
   85:     create immediate 2,
   86:   DOES>
   87:     2@ compile, >r
   88:     revdec @ IF
   89: 	0 >r  BEGIN  dup  WHILE  >r  REPEAT  drop
   90: 	BEGIN  r> dup  WHILE  compile,  REPEAT  drop
   91:     ELSE
   92: 	BEGIN dup  WHILE  compile,  REPEAT  drop
   93:     THEN
   94:     r> compile,  postpone EXIT
   95:     here thisproc @ 2 cells + ! bl sword s,
   96:     thislib @ thisproc @ @proc ;
   97: 
   98: ' av-call-void ' av-start-void rettype (void)
   99: ' av-call-int ' av-start-int rettype (int)
  100: ' av-call-float ' av-start-float rettype (sf)
  101: ' av-call-double ' av-start-double rettype (fp)
  102: ' av-call-longlong ' av-start-longlong rettype (llong)
  103: ' av-call-ptr ' av-start-ptr rettype (ptr)
  104: 
  105: \ compatibility layer for old library -- use is deprecated
  106: 
  107: Variable legacy
  108: 
  109: \ turn legacy on for old library
  110: 
  111: warnings @ warnings off
  112: 
  113: : (int) ( n -- )
  114:     legacy @ IF
  115: 	>r ' execute r> 0 ?DO  int  LOOP
  116:     THEN  (int) ;
  117: : (void) ( n -- )
  118:     legacy @ IF
  119: 	>r ' execute r> 0 ?DO  int  LOOP
  120:     THEN  (void) ;
  121: : (float) ( n -- )
  122:     legacy @ IF
  123: 	>r ' execute r> 0 ?DO  df  LOOP
  124:     THEN  (df) ;
  125: 
  126: warnings on
  127: 
  128: [ifdef] testing
  129: 
  130: library libc /lib/libc.so.6
  131:                 
  132: libc sleep int (int) sleep
  133: libc open  int int ptr (int) open
  134: libc lseek int llong int (llong) lseek
  135: libc read  int ptr int (int) read
  136: libc close int (int) close
  137: 
  138: library libm /lib/libm.so.6
  139: 
  140: libm fmodf sf sf (sf) fmodf
  141: libm fmod  df df (fp) fmod
  142: 
  143: [then]    

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>