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 / foreign.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  15KB  |  531 lines
  1. /* -*-C-*-
  2.  
  3. $Id: foreign.c,v 1.3 2000/12/05 21:23:44 cph Exp $
  4.  
  5. Copyright (c) 1992, 1999, 2000 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 primitive support for the foreign function */
  23. /* interface. */
  24.  
  25. #include <stdio.h>
  26. #include <dl.h>
  27. #include "scheme.h"
  28. #include "prims.h"
  29. #include "ux.h"
  30. #include "osfs.h"
  31. #include "foreign.h"
  32.  
  33. static int initialization_done = 0;
  34.  
  35. #define INITIALIZE_ONCE()                        \
  36. {                                    \
  37.   if (!initialization_done)                        \
  38.     initialize_once ();                            \
  39. }
  40.  
  41. static void EXFUN (initialize_once, (void));
  42.  
  43. /* Allocation table stuff stolen from x11base.c */
  44.  
  45. PTR
  46. DEFUN (foreign_malloc, (size), unsigned int size)
  47. {
  48.   PTR result = (UX_malloc (size));
  49.   if (result == 0)
  50.     error_external_return ();
  51.   return (result);
  52. }
  53.  
  54. PTR
  55. DEFUN (foreign_realloc, (ptr, size), PTR ptr AND unsigned int size)
  56. {
  57.   PTR result = (UX_realloc (ptr, size));
  58.   if (result == 0)
  59.     error_external_return ();
  60.   return (result);
  61. }
  62.  
  63. struct allocation_table
  64. {
  65.   PTR * items;
  66.   int length;
  67. };
  68.  
  69. static struct allocation_table foreign_object_table;
  70. static struct allocation_table foreign_function_table;
  71.  
  72. static void
  73. DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
  74. {
  75.   (table -> length) = 0;
  76. }
  77.  
  78. static unsigned int
  79. DEFUN (allocate_table_index, (table, item),
  80.        struct allocation_table * table AND
  81.        PTR item)
  82. {
  83.   unsigned int length = (table -> length);
  84.   unsigned int new_length;
  85.   PTR * items = (table -> items);
  86.   PTR * new_items;
  87.   PTR * scan;
  88.   PTR * end;
  89.   if (length == 0)
  90.     {
  91.       new_length = 4;
  92.       new_items = (foreign_malloc ((sizeof (PTR)) * new_length));
  93.     }
  94.   else
  95.     {
  96.       scan = items;
  97.       end = (scan + length);
  98.       while (scan < end)
  99.     if ((*scan++) == 0)
  100.       {
  101.         (*--scan) = item;
  102.         return (scan - items);
  103.       }
  104.       new_length = (length * 2);
  105.       new_items = (foreign_realloc (items, ((sizeof (PTR)) * new_length)));
  106.     }
  107.   scan = (new_items + length);
  108.   end = (new_items + new_length);
  109.   (*scan++) = item;
  110.   while (scan < end)
  111.     (*scan++) = 0;
  112.   (table -> items) = new_items;
  113.   (table -> length) = new_length;
  114.   return (length);
  115. }
  116.  
  117. static PTR
  118. DEFUN (allocation_item_arg, (arg, table),
  119.        unsigned int arg AND
  120.        struct allocation_table * table)
  121. {
  122.   unsigned int index = (arg_index_integer (arg, (table -> length)));
  123.   PTR item = ((table -> items) [index]);
  124.   if (item == 0)
  125.     error_bad_range_arg (arg);
  126.   return (item);
  127. }
  128.  
  129. /* Helper functions */
  130. HANDLE
  131. DEFUN (arg_handle, (arg_number), unsigned int arg_number)
  132. {
  133.   SCHEME_OBJECT arg;
  134.  
  135.   return (index_to_handle (arg_index_integer (arg_number,
  136.                           foreign_object_table . length)));
  137. }
  138.  
  139. HANDLE
  140. DEFUN (foreign_pointer_to_handle, (ptr), PTR ptr)
  141. {
  142.   unsigned int index;
  143.   HANDLE handle;
  144.   FOREIGN_OBJECT *ptr_object;
  145.  
  146.   INITIALIZE_ONCE ();
  147.   ptr_object = (FOREIGN_OBJECT *) foreign_malloc (sizeof (FOREIGN_OBJECT));
  148.   ptr_object -> ptr = ptr;
  149.   ptr_object -> handle = handle;
  150.   index = allocate_table_index (&foreign_object_table, (PTR) ptr_object);
  151.   handle = index_to_handle (index);
  152.   ((FOREIGN_OBJECT *) ((foreign_object_table . items) [index])) -> handle =
  153.       handle;
  154.   return (handle_to_integer (handle));
  155. }
  156.  
  157. PTR
  158. DEFUN (handle_to_foreign_pointer, (handle), HANDLE handle)
  159. {
  160.   unsigned int index;
  161.  
  162.   index = handle_to_index (handle);
  163.   if (index >= foreign_object_table . length) {
  164.     error_external_return ();
  165.   }
  166.   return
  167.     (((FOREIGN_OBJECT *) ((foreign_object_table . items) [index])) -> ptr);
  168. }
  169.  
  170. int 
  171. DEFUN (find_foreign_function, (func_name), char *func_name)
  172. {
  173.   int i;
  174.   FOREIGN_FUNCTION *func_item;
  175.   
  176.   for (i=0; i < foreign_function_table . length; i++) {
  177.     func_item = (foreign_function_table . items) [i];
  178.     if (func_item == 0) continue;
  179.     if (! strcmp (func_item -> name, func_name)) {
  180.       return (i);
  181.     }
  182.   }
  183.   return (-1);
  184. }
  185.  
  186. unsigned int
  187. DEFUN (register_foreign_function, (name, applicable_function),
  188.                                   char * name AND
  189.                                   PTR applicable_function)
  190. {
  191.   FOREIGN_FUNCTION *func_item;
  192.   char * name_copy;
  193.  
  194.   INITIALIZE_ONCE ();
  195.   func_item = (FOREIGN_FUNCTION *) foreign_malloc (sizeof (FOREIGN_FUNCTION));
  196.   name_copy = (char *) foreign_malloc (1 + strlen (name));
  197.   strcpy (name_copy, name);
  198.   func_item -> name = name_copy;
  199.   func_item -> applicable_function = applicable_function;
  200.   return (allocate_table_index (&foreign_function_table, (PTR) func_item));
  201. }
  202.  
  203. unsigned int
  204. DEFUN (list_length, (list), SCHEME_OBJECT list)
  205. {
  206.   unsigned int i;
  207.  
  208.   i = 0;
  209.   TOUCH_IN_PRIMITIVE (list, list);
  210.   while (PAIR_P (list)) {
  211.     i += 1;
  212.     TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
  213.   }
  214.   return (i);
  215. }
  216.  
  217. PTR
  218. DEFUN (apply_foreign_function, (func, arg_list),
  219.                                PTR (*func)() AND
  220.                                SCHEME_OBJECT arg_list)
  221. {
  222.   unsigned int arg_list_length;
  223.   PTR * arg_vec;
  224.   PTR result;
  225.   unsigned int i;
  226.  
  227.   arg_list_length = list_length (arg_list);
  228.   arg_vec = (PTR *) foreign_malloc (arg_list_length);
  229.   for (i = 0; i < arg_list_length; i++, arg_list = PAIR_CDR (arg_list)) {
  230.     arg_vec [i] = handle_to_foreign_pointer (PAIR_CAR (arg_list));
  231.   }
  232.   result = (*func) (arg_vec);
  233.   free (arg_vec);
  234.   return (result);
  235. }
  236.  
  237. SCHEME_OBJECT
  238. DEFUN (foreign_pointer_to_scheme_object, (ptr, type_translator),
  239.                                          PTR ptr AND
  240.                                          SCHEME_OBJECT (*type_translator) ())
  241. {
  242.   return (type_translator (ptr));
  243. }
  244.  
  245. /* old version of foreign_pointer_to_scheme_object */
  246. #if 0 
  247. /* Note that foreign_pointer_to_scheme_object takes a pointer to pointer
  248.    (i.e. a call by reference to a pointer) so that it can increment the
  249.    pointer according to its type. This is used by the code which builds
  250.    the composite objects. */
  251.  
  252. SCHEME_OBJECT
  253. DEFUN (foreign_pointer_to_scheme_object, (ptr_to_ptr, type),
  254.                                          PTR ptr_to_ptr AND
  255.                                          SCHEME_OBJECT type)
  256. {
  257.   long type_enum;
  258.   
  259.   if (foreign_primtive_type_p (type)) {
  260.     long long_val;
  261.     double double_val;
  262.     PTR temp_ptr;
  263.     type_enum = integer_to_long (type);
  264.     switch (type_enum) {
  265.       case FOREIGN_INT:
  266.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_INT);
  267.         *ptr_to_ptr = (((int *) temp_ptr) + 1);
  268.         long_val = (long) ((int) *temp_ptr);
  269.       case FOREIGN_SHORT:
  270.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_SHORT);
  271.         *ptr_to_ptr = (((short *) temp_ptr) + 1);
  272.         long_val = (long) ((short) *temp_ptr);
  273.       case FOREIGN_LONG:
  274.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_INT);
  275.         *ptr_to_ptr = (((long *) temp_ptr) + 1);
  276.         long_val = (long) *temp_ptr;
  277.         return (long_to_integer (long_val));
  278.       case FOREIGN_CHAR:
  279.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_CHAR);
  280.         *ptr_to_ptr = (((char *) temp_ptr) + 1);
  281.     return (ASCII_TO_CHAR ((char) *temp_ptr));
  282.       case FOREIGN_FLOAT:
  283.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_FLOAT);
  284.         *ptr_to_ptr = (((float *) temp_ptr) + 1);
  285.         double_val = (double) ((float) *temp_ptr);
  286.       case FOREIGN_DOUBLE:
  287.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_DOUBLE);
  288.         *ptr_to_ptr = (((double *) temp_ptr) + 1);
  289.         double_val = (double) *temp_ptr;
  290.     return (double_to_flonum (double_val));
  291.       case FOREIGN_STRING:
  292.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_STRING);
  293.         *ptr_to_ptr = (((unsigned char *) temp_ptr) + 1);
  294.     return (char_pointer_to_string ((unsigned char *) temp_ptr;
  295.       case FOREIGN_PTR:
  296.     temp_ptr = ALIGN_FOREIGN_POINTER (*ptr_to_ptr, FOREIGN_PTR);
  297.         *ptr_to_ptr = (((PTR) temp_ptr) + 1);
  298.     return (long_to_integer ((long) *temp_ptr));
  299.       default:
  300.     error_external_return ();
  301.     }
  302.   } else if (foreign_composite_type_p (type)) {
  303.     /* We should probably tag the result vector. */
  304.     type_enum = integer_to_long (which_composite_type (type));
  305.     switch (type_enum) {
  306.       case FOREIGN_STRUCT:
  307.       case FOREIGN_UNION:
  308.       {
  309.     int num_fields;
  310.     SCHEME_OBJECT field_types;
  311.     SCHEME_OBJECT result_vector;
  312.     unsigned int i;
  313.  
  314.     field_types = composite_type_field_types (type);
  315.     num_fields = list_length (field_types);
  316.     result_vector = allocate_marked_vector (TC_VECTOR, num_fields, true);
  317.     for (i = 0; i < num_fields; ++i) {
  318.       if (!(PAIR_P (field_types))) {
  319.         error_external_return ();
  320.       }
  321.       FAST_VECTOR_SET (result_vector,
  322.                i,
  323.                foreign_pointer_to_scheme_object (
  324.                 ptr_to_ptr, PAIR_CAR (field_types)));
  325.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (field_types)), field_types);
  326.     }
  327.     return (result_vector);
  328.       }
  329.       default:
  330.         error_external_return ();
  331.     }
  332.   } else {
  333.     error_external_return ();
  334.   }
  335. }
  336. #endif  /* if 0 */
  337.  
  338. static void
  339. DEFUN_VOID (initialize_once)
  340. {
  341.   allocation_table_initialize (&foreign_object_table);
  342.   allocation_table_initialize (&foreign_function_table);
  343.   
  344.   initialization_done = 1;
  345. }
  346.  
  347. /* Functions to go in osxx.c */
  348.  
  349. #include <dl.h>
  350.  
  351. char *
  352. DEFUN_VOID (OS_create_temporary_file_name)
  353. {
  354.   char * name_string;
  355.  
  356.   name_string = (char *) foreign_malloc (1 + TEMP_FILE_NAME_MAX_LEN);
  357.   (void) UX_tmpnam (name_string);
  358.   return (name_string);
  359. }
  360.  
  361. #ifdef HAVE_DYNAMIC_LOADING
  362. #ifdef __HPUX__
  363. #include <dl.h>
  364.  
  365. LOAD_INFO *
  366. DEFUN (OS_load_object_file, (load_file_name), char * load_file_name)
  367. {
  368.   shl_t shl_handle;
  369.   int result;
  370.   struct shl_descriptor *shl_desc;
  371.   LOAD_INFO *info;
  372.  
  373.   shl_handle = shl_load (load_file_name, BIND_DEFERRED, 0L);
  374.   
  375.   if (shl_handle == NULL) {
  376.     error_external_return ();
  377.   }
  378.  
  379.   result = shl_gethandle (shl_handle, &shl_desc);
  380.  
  381.   if (result == -1) {
  382.     error_external_return ();
  383.   }
  384.  
  385.   info = foreign_malloc (sizeof (LOAD_INFO));
  386.   info -> load_module_descriptor = shl_handle;
  387.   info -> program_start = shl_desc -> tstart;
  388.   info -> program_end = shl_desc -> tend;
  389.   info -> data_start = shl_desc -> dstart;
  390.   info -> data_end = shl_desc -> dend;
  391.   return (info);
  392. }
  393.  
  394. PTR
  395. DEFUN (OS_find_function, (load_info, func_name),
  396.                        LOAD_INFO * load_info AND
  397.                        char * func_name)
  398. {
  399.   int return_code;
  400.   PTR (* test_proc)();
  401.   LOAD_DESCRIPTOR desc;
  402.  
  403.   desc = (load_info -> load_module_descriptor);
  404.   return_code = shl_findsym (&desc ,
  405.                  func_name,
  406.                  TYPE_PROCEDURE,
  407.                  (long *) &test_proc);
  408.  
  409.   return ((return_code == 0) ?
  410.       test_proc :
  411.       NULL);
  412. }
  413.  
  414. #endif /* __HPUX__ */
  415. #endif /* HAVE_DYNAMIC_LOADING */
  416.  
  417. /* Definitions of primitives */
  418.  
  419. DEFINE_PRIMITIVE ("CALL-FOREIGN-FUNCTION",
  420.           Prim_call_foreign_function, 2, 2,
  421. "Calls the foreign function referenced by HANDLE with the ARG-LIST \n\
  422. arguments. \n\
  423. Returns a handle to the return value; \n\
  424. The foreign function should have been created by  \n\
  425. CREATE_PRIMITIVE_FOREIGN_FUNCTION. \n\
  426. The elements of the ARG-LIST must be handles to foreign objects. \n\
  427. Type and arity checking on the arguments should already have been done.")
  428. {
  429.   PRIMITIVE_HEADER (2);
  430.   {
  431.     SCHEME_OBJECT arg_list;
  432.     PTR result;
  433.  
  434.     CHECK_ARG (2, APPARENT_LIST_P);
  435.     arg_list = ARG_REF (2);
  436.     result = apply_foreign_function (handle_to_foreign_pointer
  437.                      (arg_handle (1)), arg_list);
  438.     PRIMITIVE_RETURN (foreign_pointer_to_handle (result));
  439.   }
  440. }
  441.  
  442. DEFINE_PRIMITIVE ("&CALL-FOREIGN-FUNCTION-RETURNING-SCHEME-OBJECT",
  443.           Prim_call_foreign_function_returning_scheme_object, 2, 2,
  444. "Calls the foreign function referenced by HANDLE with the ARG-LIST \n\
  445. arguments. \n\
  446. Returns the result of the foreign function (which better be a scheme \n\
  447. object. \n\
  448. The foreign function should have been created by  \n\
  449. CREATE_PRIMITIVE_FOREIGN_FUNCTION. \n\
  450. The elements of the ARG-LIST must be handles to foreign objects. \n\
  451. Type and arity checking on the arguments should already have been done.")
  452. {
  453.   PRIMITIVE_HEADER (2);
  454.   {
  455.     SCHEME_OBJECT arg_list;
  456.     PTR result;
  457.  
  458.     CHECK_ARG (2, APPARENT_LIST_P);
  459.     arg_list = ARG_REF (2);
  460.     result = apply_foreign_function (handle_to_foreign_pointer
  461.                      (arg_handle (1)), arg_list);
  462.     PRIMITIVE_RETURN (result);
  463.   }
  464. }
  465.  
  466. DEFINE_PRIMITIVE ("FOREIGN-HANDLE-TO-SCHEME-OBJECT",
  467.           Prim_foreign_handle_to_scheme_object, 2, 2,
  468. "Returns the Scheme object corresponding to the foreign HANDLE \n\
  469. interpreted as the foreign type TYPE.   \n\
  470. A type is either an integer which enumerates the various foreign types \n\
  471. (i.e.  FOREIGN_INT, FOREIGN_CHAR, FOREIGN_SHORT, FOREIGN_LONG, \n\
  472. (FOREIGN_PTR, FOREIGN_DOUBLE, FOREIGN_STRING) or a list whose car is \n\
  473. an integer representing FOREIGN_STRUCT or FOREIGN_UNION and whose cdr \n\
  474. is a list of types.")
  475. {
  476.   PRIMITIVE_HEADER (2);
  477.   {
  478.     SCHEME_OBJECT arg2;
  479.     PTR arg1_ptr;
  480.  
  481.     arg1_ptr = handle_to_foreign_pointer (arg_handle (1));
  482.     arg2 = ARG_REF (2);
  483.     if (! (INTEGER_P (arg2) || PAIR_P (arg2))) {
  484.       error_wrong_type_arg (2);
  485.     }
  486.     PRIMITIVE_RETURN (foreign_pointer_to_scheme_object (&arg1_ptr, arg2));
  487.   }
  488. }
  489.  
  490. DEFINE_PRIMITIVE (LOAD-FOREIGN-FILE, Prim_load_foreign_file, 1, 1,
  491. "Load the foreign object file FILENAME. \n\
  492. Returns a handle to a LOAD_INFO data structure.")
  493. {
  494.   PRIMITIVE_HEADER (1);
  495.   PRIMITIVE_RETURN (foreign_pointer_to_handle
  496.              (OS_load_object_file (STRING_ARG (1))));
  497. }
  498.  
  499. DEFINE_PRIMITIVE (CREATE-TEMPORARY-FILE-NAME, Prim_get_temporary_file_name,
  500.           0, 0,
  501. "Return a temporary file name.")
  502. {
  503.   PRIMITIVE_HEADER (0);
  504.   PRIMITIVE_RETURN (char_pointer_to_string (OS_create_temporary_file_name ()));
  505. }
  506.  
  507. DEFINE_PRIMITIVE (FIND-FOREIGN-FUNCTION, Prim_find_foreign_function, 2, 2,
  508. "Returns a handle to a foreign function. \n\
  509. Takes the FUNCTION_NAME as a string and LOAD_INFO \n\
  510. which is a handle to a load_info structure returned by LOAD-FOREIGN-FILE. \n\
  511. If LOAD_INFO is not #F then we search for FUNCTION_NAME in the code which \n\
  512. was loaded to yield LOAD_INFO. \n\
  513. If LOAD_INFO is #F then we search over all the dynamically loaded files.")
  514. {
  515.   PRIMITIVE_HEADER (2);
  516.   {
  517.     PTR func_ptr;
  518.     LOAD_INFO * load_info;
  519.  
  520.     load_info = ((ARG_REF (2) == EMPTY_LIST) ?
  521.          ((LOAD_INFO *) NULL) :
  522.          ((LOAD_INFO *) handle_to_foreign_pointer (arg_handle (2))));
  523.           
  524.     func_ptr = OS_find_function (load_info, STRING_ARG (1));
  525.  
  526.     PRIMITIVE_RETURN ((func_ptr == NULL) ?
  527.               SHARP_F :
  528.               foreign_pointer_to_handle (func_ptr));
  529.   }
  530. }
  531.