home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / pruxdld.c < prev    next >
C/C++ Source or Header  |  2001-03-08  |  4KB  |  113 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pruxdld.c,v 1.14 2001/03/08 18:01:45 cph Exp $
  4.  
  5. Copyright (c) 1993-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* This file contains the interface to the unix dynamic loader.  */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "usrdef.h"
  27. #include "syscall.h"
  28. #include "os.h"
  29.  
  30. #ifdef __linux__
  31.  
  32. #include <dlfcn.h>
  33.  
  34. static unsigned long
  35. DEFUN (dld_load, (path), CONST char * path)
  36. {
  37.   void * handle = (dlopen (path, (RTLD_LAZY | RTLD_GLOBAL)));
  38.   if (handle == 0)
  39.     {
  40.       SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
  41.       VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
  42.       VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
  43.       VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
  44.       error_with_argument (v);
  45.     }
  46.   return ((unsigned long) handle);
  47. }
  48.  
  49. static unsigned long
  50. DEFUN (dld_lookup, (handle, symbol), unsigned long handle AND char * symbol)
  51. {
  52.   CONST char * old_error = (dlerror ());
  53.   void * address = (dlsym (((void *) handle), symbol));
  54.   CONST char * new_error = (dlerror ());
  55.   if ((address == 0) && (new_error != old_error))
  56.     {
  57.       SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
  58.       VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
  59.       VECTOR_SET (v, 1, (char_pointer_to_string ("dlsym")));
  60.       VECTOR_SET (v, 2, (char_pointer_to_string (new_error)));
  61.       error_with_argument (v);
  62.     }
  63.   return ((unsigned long) address);
  64. }
  65.  
  66. #endif /* __linux__ */
  67.  
  68. DEFINE_PRIMITIVE ("LOAD-OBJECT-FILE", Prim_load_object_file, 1, 1,
  69.           "(FILENAME)\n\
  70. Load the shared library FILENAME and return a handle for it.")
  71. {
  72.   PRIMITIVE_HEADER (1);
  73.   PRIMITIVE_RETURN (ulong_to_integer (dld_load (STRING_ARG (1))));
  74. }
  75.  
  76. DEFINE_PRIMITIVE ("OBJECT-LOOKUP-SYMBOL", Prim_object_lookup_symbol, 3, 3,
  77.           "(HANDLE SYMBOL TYPE)\n\
  78. Look up SYMBOL, a Scheme string, in the dynamically-loaded file\n\
  79. referenced by HANDLE.  TYPE is obsolete and must be specified as zero.
  80. Returns the symbol's address, or signals an error if no such symbol.")
  81. {
  82.   PRIMITIVE_HEADER (3);
  83.   if ((ARG_REF (3)) != FIXNUM_ZERO)
  84.     error_wrong_type_arg (3);
  85.   PRIMITIVE_RETURN
  86.     (ulong_to_integer
  87.      (dld_lookup ((arg_ulong_integer (1)), (STRING_ARG (2)))));
  88. }
  89.  
  90. DEFINE_PRIMITIVE ("INVOKE-C-THUNK", Prim_invoke_C_thunk, 1, 1,
  91.           "(ADDRESS)\n\
  92. Treat ADDRESS, a Scheme integer corresponding to a C unsigned long, as\n\
  93. the address of a C procedure of no arguments that returns an unsigned\n\
  94. long.  Invoke it, and return the corresponding Scheme integer.")
  95. {
  96.   PRIMITIVE_HEADER (1);
  97.   PRIMITIVE_RETURN
  98.     (ulong_to_integer
  99.      ((* ((unsigned long EXFUN ((*), (void))) (arg_ulong_integer (1))))
  100.       ()));
  101. }
  102.  
  103. DEFINE_PRIMITIVE ("ADDRESS-TO-STRING", Prim_address_to_string, 1, 1,
  104.           "(ADDRESS)\n\
  105. Treat ADDRESS, a Scheme integer corresponding to a C unsigned long, as\n\
  106. a C char * pointer.  Allocate and return a Scheme string with the same\n\
  107. contents.")
  108. {
  109.   PRIMITIVE_HEADER (1);
  110.   PRIMITIVE_RETURN
  111.     (char_pointer_to_string ((unsigned char *) (arg_ulong_integer (1))));
  112. }
  113.