dynamo.c 4.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188
  1. /* No Copyright. */
  2. /*
  3. * Lookup external names in the running scheme virtual machine and, on
  4. * machines which support it, do dynamic loading.
  5. */
  6. #include <stdlib.h>
  7. #include <unistd.h>
  8. #include "sysdep.h"
  9. #include "scheme48.h"
  10. #include "c-mods.h"
  11. #if defined(HAVE_DLOPEN)
  12. #include <dlfcn.h>
  13. #else
  14. #include "fake/dlfcn.h"
  15. #endif
  16. #if defined(RTLD_NOW)
  17. #define DLOPEN_MODE RTLD_NOW
  18. #elif defined(RTLD_LAZY)
  19. #define DLOPEN_MODE (RTLD_LAZY)
  20. #else
  21. #define DLOPEN_MODE (1)
  22. #endif
  23. /*
  24. * Linked list of dynamically loaded libraries.
  25. */
  26. static struct dlob {
  27. struct dlob *next;
  28. char *name;
  29. void *handle;
  30. } *dlobs;
  31. static s48_value s48_external_lookup(s48_value svname, s48_value svlocp),
  32. s48_old_external_call(s48_value svproc, s48_value svargv),
  33. s48_dynamic_load(s48_value filename);
  34. static long lookup_external_name(char *name, long *locp);
  35. static psbool dynamic_load(char *name);
  36. /*
  37. * Install all exported functions in Scheme48.
  38. */
  39. void
  40. s48_init_external_lookup(void)
  41. {
  42. S48_EXPORT_FUNCTION(s48_external_lookup);
  43. S48_EXPORT_FUNCTION(s48_old_external_call);
  44. S48_EXPORT_FUNCTION(s48_dynamic_load);
  45. }
  46. /*
  47. * Glue between Scheme48 types and C types for external name lookup.
  48. * Look up svname (either in a dynamically loaded library, or in the
  49. * running executable).
  50. * On success we return PSTRUE, having set *(long *)svlocp to the location.
  51. * On failure, we return PSFALSE.
  52. */
  53. static s48_value
  54. s48_external_lookup(s48_value svname, s48_value svlocp)
  55. {
  56. char *name;
  57. long *locp,
  58. res;
  59. name = s48_extract_string(svname);
  60. locp = S48_EXTRACT_VALUE_POINTER(svlocp, long);
  61. res = lookup_external_name(name, locp);
  62. return (S48_ENTER_BOOLEAN(res));
  63. }
  64. /*
  65. * Glue between Scheme48 types and C types for external call.
  66. * svproc is a byte vector containing the procedure and svargs is a
  67. * vector of arguments.
  68. */
  69. static s48_value
  70. s48_old_external_call(s48_value svproc, s48_value svargv)
  71. {
  72. s48_value (*func)(long, long*);
  73. long *argv,
  74. argc;
  75. func = (s48_value (*)(long, long*))*S48_EXTRACT_VALUE_POINTER(svproc, long);
  76. argc = S48_VECTOR_LENGTH(svargv);
  77. argv = S48_ADDRESS_AFTER_HEADER(svargv, long);
  78. return (func(argc, argv));
  79. }
  80. /*
  81. * Lookup an external name (either in a dynamically loaded library, or
  82. * in the running executable).
  83. * On success we return PSTRUE, having set *(long *)locp to the location.
  84. * On failure, we return PSFALSE.
  85. */
  86. static long
  87. lookup_external_name(char *name, long *locp)
  88. {
  89. struct dlob *dp;
  90. void *res;
  91. static void *self;
  92. for (dp = dlobs; dp != NULL; dp = dp->next) {
  93. res = dlsym(dp->handle, name);
  94. if (dlerror() == NULL) {
  95. *locp = (long)res;
  96. return (PSTRUE);
  97. }
  98. }
  99. if (self == NULL) {
  100. self = dlopen((char *)NULL, DLOPEN_MODE);
  101. if (dlerror() != NULL)
  102. return (PSFALSE);
  103. }
  104. res = dlsym(self, name);
  105. if (dlerror() == NULL) {
  106. *locp = (long)res;
  107. return (PSTRUE);
  108. }
  109. return (PSFALSE);
  110. }
  111. /*
  112. * External to load a library.
  113. * Raises an exception if the file cannot be loaded, or loaded properly.
  114. * Note, if you load the same file a second time, afterwards you must
  115. * evaluate (lookup-all-externals) in package externals to update any
  116. * externals the pointed to the old version of the library.
  117. */
  118. s48_value
  119. s48_dynamic_load(s48_value filename)
  120. {
  121. S48_CHECK_STRING(filename);
  122. if (! dynamic_load(S48_UNSAFE_EXTRACT_STRING(filename)))
  123. /* the cast below is to remove the const part of the type */
  124. s48_raise_string_os_error((char *)dlerror());
  125. return S48_UNSPECIFIC;
  126. }
  127. static psbool
  128. dynamic_load(char *name)
  129. {
  130. struct dlob **dpp,
  131. *dp;
  132. void *handle;
  133. for (dpp = &dlobs;; dpp = &dp->next) {
  134. dp = *dpp;
  135. if (dp == NULL) {
  136. handle = dlopen(name, DLOPEN_MODE);
  137. if (handle == NULL)
  138. return (PSFALSE);
  139. dp = (struct dlob *)malloc(sizeof(*dp) + strlen(name) + 1);
  140. if (dp == NULL) {
  141. dlclose(handle);
  142. return (PSFALSE);
  143. }
  144. dp->next = dlobs;
  145. dlobs = dp;
  146. dp->name = (char *)(dp + 1);
  147. strcpy(dp->name, name);
  148. dp->handle = handle;
  149. return (PSTRUE);
  150. } else if (strcmp(name, dp->name) == 0) {
  151. dlclose(dp->handle);
  152. dp->handle = dlopen(name, DLOPEN_MODE);
  153. if (dp->handle == NULL) {
  154. *dpp = dp->next;
  155. free((void *)dp);
  156. return (PSFALSE);
  157. }
  158. return (PSTRUE);
  159. }
  160. }
  161. }