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 / cmpauxmd / c.c < prev    next >
Encoding:
C/C++ Source or Header  |  1999-01-02  |  18.4 KB  |  683 lines
  1. /* -*-C-*-
  2.  
  3. $Id: c.c,v 1.12 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1992-1999 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. #include "liarc.h"
  23. #include "prims.h"
  24. #include "bignum.h"
  25. #include "bitstr.h"
  26. #include "avltree.h"
  27.  
  28. #ifdef BUG_GCC_LONG_CALLS
  29.  
  30. extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
  31. extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
  32. extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
  33. extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
  34. extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
  35. extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
  36. extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
  37. extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
  38. extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
  39.  
  40. SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()) =
  41. {
  42.   ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_string),
  43.   ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_symbol),
  44.   ((SCHEME_OBJECT EXFUN ((*), ())) make_vector),
  45.   ((SCHEME_OBJECT EXFUN ((*), ())) cons),
  46.   ((SCHEME_OBJECT EXFUN ((*), ())) rconsm),
  47.   ((SCHEME_OBJECT EXFUN ((*), ())) double_to_flonum),
  48.   ((SCHEME_OBJECT EXFUN ((*), ())) long_to_integer),
  49.   ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_integer),
  50.   ((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_bit_string),
  51.   ((SCHEME_OBJECT EXFUN ((*), ())) make_primitive)
  52. };
  53.  
  54. #endif /* BUG_GCC_LONG_CALLS */
  55.  
  56. extern char * interface_to_C_hook;
  57. extern long C_return_value, MAX_TRAMPOLINE;
  58. extern void EXFUN (C_to_interface, (PTR));
  59. extern void EXFUN (interface_initialize, (void));
  60. extern SCHEME_OBJECT * EXFUN (initialize_C_compiled_block, (int, char *));
  61. extern int EXFUN (initialize_compiled_code_blocks, (void));
  62. extern void * scheme_hooks_low, * scheme_hooks_high;
  63.  
  64. #define TRAMPOLINE_FUDGE 20
  65.  
  66. typedef SCHEME_OBJECT * EXFUN ((* code_block),
  67.                    (SCHEME_OBJECT *, unsigned long));
  68.  
  69. typedef SCHEME_OBJECT * EXFUN ((* data_block), (unsigned long));
  70.  
  71. struct compiled_entry_s
  72. {
  73.   code_block code;
  74.   unsigned long dispatch;
  75. };
  76.  
  77. struct compiled_block_s
  78. {
  79.   char * name;
  80.   unsigned long nentries;
  81.   unsigned long dispatch;
  82.   data_block constructor;
  83. };
  84.  
  85. int pc_zero_bits;
  86. static SCHEME_OBJECT
  87.   dummy_entry = ((SCHEME_OBJECT) -1L);
  88. char *
  89.   interface_to_C_hook = ((char *) & dummy_entry);
  90. void
  91.   * scheme_hooks_low = NULL,
  92.   * scheme_hooks_high = NULL;
  93.  
  94. #define PSEUDO_STATIC
  95.  
  96. PSEUDO_STATIC long
  97.   initial_entry_number = -1;
  98. PSEUDO_STATIC unsigned long
  99.   max_compiled_entries = 0,
  100.   compiled_entries_size = 0;
  101. PSEUDO_STATIC struct compiled_entry_s *
  102.   compiled_entries = ((struct compiled_entry_s *) NULL);
  103.  
  104. PSEUDO_STATIC unsigned long
  105.   max_compiled_blocks = 0,
  106.   compiled_blocks_table_size = 0;
  107. PSEUDO_STATIC struct compiled_block_s *
  108.   compiled_blocks_table = ((struct compiled_block_s *) NULL);
  109. PSEUDO_STATIC tree_node
  110.   compiled_blocks_tree = ((tree_node) NULL);
  111.  
  112. SCHEME_OBJECT *
  113. DEFUN (trampoline_procedure, (trampoline, dispatch),
  114.        SCHEME_OBJECT * trampoline AND unsigned long dispatch)
  115. {
  116.   return (invoke_utility (((int) (* ((unsigned long *) trampoline))),
  117.               ((long) (TRAMPOLINE_STORAGE (trampoline))),
  118.               0, 0, 0));
  119. }
  120.  
  121. int
  122. DEFUN_VOID (NO_SUBBLOCKS)
  123. {
  124.   return (0);
  125. }
  126.  
  127. SCHEME_OBJECT *
  128. DEFUN (no_data, (base_dispatch), unsigned long base_dispatch)
  129. {
  130.   return ((SCHEME_OBJECT *) NULL);
  131. }
  132.  
  133. SCHEME_OBJECT *
  134. DEFUN (uninitialized_data, (base_dispatch), unsigned long base_dispatch)
  135. {
  136.   /* Not yet assigned.  Cannot construct data. */
  137.   error_external_return ();
  138. }
  139.  
  140. SCHEME_OBJECT *
  141. DEFUN (unspecified_code, (entry, dispatch),
  142.        SCHEME_OBJECT * entry AND unsigned long dispatch)
  143. {
  144.   Store_Expression ((SCHEME_OBJECT) entry);
  145.   C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR);
  146.   return (&dummy_entry);
  147. }
  148.  
  149. extern PTR EXFUN (malloc, (unsigned long));
  150. extern PTR EXFUN (realloc, (PTR, unsigned long));
  151.  
  152. PTR
  153. DEFUN (lrealloc, (ptr, size), PTR ptr AND unsigned long size)
  154. {
  155.   if (ptr == ((PTR) NULL))
  156.     return (malloc (size));
  157.   else
  158.     return (realloc (ptr, size));
  159. }
  160.  
  161. int
  162. DEFUN (declare_trampoline_block, (nentries), unsigned long nentries)
  163. {
  164.   int result;
  165.  
  166.   result = (declare_compiled_code ("#trampoline_code_block",
  167.                    nentries,
  168.                    NO_SUBBLOCKS,
  169.                    trampoline_procedure));
  170. #if 0
  171.   /* trampoline block is special. */
  172.  
  173.   if (result != 0)
  174.     return (result);
  175.  
  176.   result = (declare_compiled_data ("#trampoline_code_block",
  177.                    NO_SUBBLOCKS,
  178.                    no_data));
  179. #endif
  180.   return (result);
  181. }
  182.  
  183. void
  184. DEFUN_VOID (interface_initialize)
  185. {
  186.   int i, pow, del;
  187.   
  188.   for (i = 0, pow = 1, del = ((sizeof (SCHEME_OBJECT)) / (sizeof (char)));
  189.        pow < del; i+= 1)
  190.     pow = (pow << 1);
  191.   
  192.   if (pow != del)
  193.   {
  194.     /* Not a power of two -- ill-defined pc_zero_bits. */
  195.     outf_fatal ("interface_initialize: bad (sizeof (SCHEME_OBJECT)).\n");
  196.     Microcode_Termination (TERM_EXIT);
  197.   }
  198.   pc_zero_bits = i;  
  199.  
  200.   if (initial_entry_number == -1)
  201.     initial_entry_number = (MAX_TRAMPOLINE + TRAMPOLINE_FUDGE);
  202.  
  203.   if (((declare_trampoline_block (initial_entry_number)) != 0)
  204.       || (initialize_compiled_code_blocks ()) != 0)
  205.   {
  206.     if (Registers[REGBLOCK_PRIMITIVE] != SHARP_F)
  207.       signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
  208.     else
  209.     {
  210.       outf_fatal ("interface_initialize: error initializing compiled code.\n");
  211.       Microcode_Termination (TERM_EXIT);
  212.     }
  213.   }
  214.   return;
  215. }
  216.  
  217. unsigned long
  218. DEFUN (find_compiled_block, (name), char * name)
  219. {
  220.   tree_node node = (tree_lookup (compiled_blocks_tree, name));
  221.  
  222.   if (node == ((tree_node) NULL))
  223.     return (max_compiled_blocks);
  224.   else
  225.     return (node->value);
  226. }
  227.  
  228. int
  229. DEFUN (declare_compiled_data,
  230.        (name, decl_data, data_proc),
  231.        char * name
  232.        AND int EXFUN ((* decl_data), (void))
  233.        AND SCHEME_OBJECT * EXFUN ((* data_proc), (unsigned long)))
  234. {
  235.   unsigned long slot = (find_compiled_block (name));
  236.  
  237.   if (slot == max_compiled_blocks)
  238.     return (-1);
  239.   
  240.   if ((compiled_blocks_table[slot].constructor != uninitialized_data)
  241.       && (compiled_blocks_table[slot].constructor != data_proc))
  242.     return (-1);
  243.  
  244.   compiled_blocks_table[slot].constructor = data_proc;
  245.   return (* decl_data) ();  
  246. }
  247.  
  248. SCHEME_OBJECT
  249. DEFUN (initialize_subblock, (name), char * name)
  250. {
  251.   SCHEME_OBJECT * ep, * block;
  252.   unsigned long slot = (find_compiled_block (name));
  253.  
  254.   if (slot == max_compiled_blocks)
  255.     error_external_return ();
  256.  
  257.   ep = ((* compiled_blocks_table[slot].constructor)
  258.     (compiled_blocks_table[slot].dispatch));
  259.   Get_Compiled_Block (block, ep);
  260.   return (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
  261. }
  262.  
  263. SCHEME_OBJECT *
  264. DEFUN (initialize_C_compiled_block, (argno, name),
  265.        int argno AND char * name)
  266. {
  267.   unsigned long slot;
  268.  
  269.   slot = (find_compiled_block (name));
  270.   if (slot == max_compiled_blocks)
  271.     return ((SCHEME_OBJECT *) NULL);
  272.  
  273.   return ((* compiled_blocks_table[slot].constructor)
  274.       (compiled_blocks_table[slot].dispatch));
  275. }
  276.  
  277. int
  278. DEFUN (declare_compiled_code,
  279.        (name, nentries, decl_code, code_proc),
  280.        char * name
  281.        AND unsigned long nentries
  282.        AND int EXFUN ((* decl_code), (void))
  283.        AND code_block code_proc)
  284. {
  285.   unsigned long slot = (find_compiled_block (name));
  286.  
  287.   if (slot != max_compiled_blocks)
  288.   {
  289.     code_block old_code;
  290.  
  291.     old_code = (compiled_entries[compiled_blocks_table[slot].dispatch].code);
  292.     if (((old_code != unspecified_code)
  293.      && (old_code != code_proc)
  294.      && (code_proc != unspecified_code))
  295.     || (compiled_blocks_table[slot].nentries != nentries))
  296.       return (-1);
  297.     if (old_code == unspecified_code)
  298.     {
  299.       unsigned long counter, limit;
  300.  
  301.       counter = compiled_blocks_table[slot].dispatch;
  302.       limit = (counter + nentries);
  303.       while (counter < limit)
  304.     compiled_entries[counter++].code = code_proc;
  305.     }
  306.   }
  307.   else
  308.   {
  309.     unsigned long dispatch = max_compiled_entries;
  310.     unsigned long n_dispatch = (dispatch + nentries);
  311.     unsigned long block_index = max_compiled_blocks;
  312.  
  313.     if (n_dispatch < dispatch)
  314.       /* Wrap around */
  315.       return (-1);
  316.     
  317.     if (n_dispatch >= compiled_entries_size)
  318.     {
  319.       struct compiled_entry_s * new_entries;
  320.       unsigned long new_entries_size = ((compiled_entries_size == 0)
  321.                     ? 100
  322.                     : ((compiled_entries_size * 3) / 2));
  323.       if (new_entries_size <= n_dispatch)
  324.     new_entries_size = (n_dispatch + 1);
  325.  
  326.       new_entries = ((struct compiled_entry_s *)
  327.              (lrealloc (compiled_entries,
  328.                 (new_entries_size
  329.                  * (sizeof (struct compiled_entry_s))))));
  330.       if (new_entries == ((struct compiled_entry_s *) NULL))
  331.     return (-1);
  332.       compiled_entries_size = new_entries_size;
  333.       compiled_entries = new_entries;
  334.     }
  335.  
  336.     if (block_index >= compiled_blocks_table_size)
  337.     {
  338.       struct compiled_block_s * new_blocks;
  339.       unsigned long new_blocks_size
  340.     = ((compiled_blocks_table_size == 0)
  341.        ? 10
  342.        : ((compiled_blocks_table_size * 3) / 2));
  343.       new_blocks = ((struct compiled_block_s *)
  344.             (lrealloc (compiled_blocks_table,
  345.                    (new_blocks_size
  346.                 * (sizeof (struct compiled_block_s))))));
  347.       if (new_blocks == ((struct compiled_block_s *) NULL))
  348.     return (-1);
  349.       compiled_blocks_table_size = new_blocks_size;
  350.       compiled_blocks_table = new_blocks;
  351.     }
  352.  
  353.     {
  354.       tree_node new_tree;
  355.  
  356.       tree_error_message = ((char *) NULL);
  357.       new_tree = (tree_insert (compiled_blocks_tree, name, block_index));
  358.       if (tree_error_message != ((char *) NULL))
  359.     return (-1);
  360.       compiled_blocks_tree = new_tree;
  361.     }
  362.  
  363.     max_compiled_entries = n_dispatch;
  364.     max_compiled_blocks = (block_index + 1);
  365.   
  366.     compiled_blocks_table[block_index].name = name;
  367.     compiled_blocks_table[block_index].nentries = nentries;
  368.     compiled_blocks_table[block_index].dispatch = dispatch;
  369.     compiled_blocks_table[block_index].constructor = uninitialized_data;
  370.  
  371.     for (block_index = dispatch; block_index < n_dispatch; block_index++)
  372.     {
  373.       compiled_entries[block_index].code = code_proc;
  374.       compiled_entries[block_index].dispatch = dispatch;
  375.     }
  376.   }
  377.   return (* decl_code) ();
  378. }
  379.  
  380. /* For now */
  381.  
  382. extern SCHEME_OBJECT
  383.   * EXFUN (cons_c_code_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *));
  384.  
  385. extern Boolean
  386.   EXFUN (install_c_code_table, (SCHEME_OBJECT *, long));
  387.  
  388. static SCHEME_OBJECT *
  389. DEFUN (copy_c_code_block_information, (index, start, limit),
  390.        long index AND SCHEME_OBJECT * start AND SCHEME_OBJECT * limit)
  391. {
  392.   long char_count;
  393.   char * src, * dest;
  394.  
  395.   if (start < limit)
  396.     *start++
  397.       = (LONG_TO_UNSIGNED_FIXNUM (compiled_blocks_table[index].nentries));
  398.   
  399.   src = compiled_blocks_table[index].name;
  400.   dest = ((char *) start);
  401.  
  402.   while ((dest < ((char *) limit)) && ((*dest++ = *src++) != '\0'))
  403.     ;
  404.   if (dest >= ((char *) limit))
  405.     while (*src++ != '\0')
  406.       dest += 1;
  407.   
  408.   char_count = (dest - ((char *) start));
  409.   return (start + (BYTES_TO_WORDS (dest - ((char *) start))));
  410. }
  411.  
  412. SCHEME_OBJECT *
  413. DEFUN (cons_c_code_table, (start, limit, length),
  414.        SCHEME_OBJECT * start AND SCHEME_OBJECT * limit AND long * length)
  415. {
  416.   long count;
  417.  
  418.   * length = max_compiled_blocks;
  419.  
  420.   if (start < limit)
  421.     *start++ = (LONG_TO_FIXNUM (initial_entry_number));
  422.  
  423.   for (count = 0; ((count < max_compiled_blocks) && (start < limit)); count++)
  424.     start = (copy_c_code_block_information (count, start, limit));
  425.  
  426.   return (start);
  427. }
  428.  
  429. Boolean
  430. DEFUN (install_c_code_table, (table, length),
  431.        SCHEME_OBJECT * table AND long length)
  432. {
  433.   SCHEME_OBJECT the_fixnum;
  434.   long count, dumped_initial_entry_number;
  435.  
  436.   the_fixnum = *table++;
  437.   dumped_initial_entry_number = (FIXNUM_TO_LONG (the_fixnum));
  438.   if (dumped_initial_entry_number < MAX_TRAMPOLINE)
  439.     return (false);
  440.   initial_entry_number = dumped_initial_entry_number;
  441.  
  442.   if (compiled_entries != ((struct compiled_entry_s *) NULL))
  443.     free (compiled_entries);
  444.   if (compiled_blocks_table != ((struct compiled_block_s *) NULL))
  445.     free (compiled_blocks_table);
  446.   if (compiled_blocks_tree != ((tree_node) NULL))
  447.     tree_free (compiled_blocks_tree);
  448.   
  449.   max_compiled_entries = 0;
  450.   compiled_entries_size = 0;
  451.   compiled_entries = ((struct compiled_entry_s *) NULL);
  452.   max_compiled_blocks = 0;
  453.   compiled_blocks_table_size = 0;
  454.   compiled_blocks_table = ((struct compiled_block_s *) NULL);
  455.   compiled_blocks_tree = ((tree_node) NULL);
  456.   
  457.   if ((declare_trampoline_block (initial_entry_number)) != 0)
  458.     return (false);
  459.  
  460.   for (count = 0; count < length; count++)
  461.   {
  462.     long nentries = (UNSIGNED_FIXNUM_TO_LONG (* table++));
  463.     int nlen = (strlen ((char *) table));
  464.     char * ncopy = ((char *) (malloc (nlen + 1)));
  465.  
  466.     if (ncopy == ((char *) NULL))
  467.       return (false);
  468.     strcpy (ncopy, ((char *) table));
  469.     if ((declare_compiled_code (ncopy,
  470.                 nentries,
  471.                 NO_SUBBLOCKS,
  472.                 unspecified_code))
  473.     != 0)
  474.       return (false);
  475.     table += (BYTES_TO_WORDS (nlen + 1));
  476.   }
  477.  
  478.   return (true);
  479. }
  480.  
  481. #define C_COUNT_TRANSFERS
  482. unsigned long c_to_interface_transfers = 0;
  483.  
  484. void
  485. DEFUN (C_to_interface, (in_entry), PTR in_entry)
  486. {
  487.   SCHEME_OBJECT * entry = ((SCHEME_OBJECT *) in_entry);
  488.  
  489.   while (1)
  490.   {
  491.     unsigned long entry_index = (* ((unsigned long *) entry));
  492.  
  493. #ifdef C_COUNT_TRANSFERS
  494.     c_to_interface_transfers += 1;
  495. #endif /* C_COUNT_TRANSFERS */
  496.  
  497.     if (entry_index < ((unsigned long) max_compiled_entries))
  498.       entry = ((* (compiled_entries[entry_index].code))
  499.            (entry, compiled_entries[entry_index].dispatch));
  500.     else
  501.     {
  502.       if (entry != &dummy_entry)
  503.       {
  504.     Store_Expression ((SCHEME_OBJECT) entry);
  505.     C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR);
  506.       }
  507.       return;
  508.     }
  509.   }
  510. }
  511.  
  512. DEFINE_PRIMITIVE ("SWAP-C-COUNTER!", Prim_swap_c_counter, 1, 1,
  513.           "(new-value)\n\
  514. Set the C transfer counter to new-value.  Return the old value.")
  515. {
  516.   unsigned long new_counter, old_counter;
  517.   PRIMITIVE_HEADER (1);
  518.  
  519.   new_counter = (arg_integer (1));
  520.   old_counter = c_to_interface_transfers;
  521.   c_to_interface_transfers = new_counter;
  522.   PRIMITIVE_RETURN (ulong_to_integer (old_counter));
  523. }
  524.  
  525. typedef SCHEME_OBJECT * EXFUN
  526.   ((* utility_table_entry), (long, long, long, long));
  527.  
  528. extern utility_table_entry utility_table[];
  529.  
  530. SCHEME_OBJECT *
  531. DEFUN (invoke_utility, (code, arg1, arg2, arg3, arg4),
  532.        int code AND long arg1 AND long arg2 AND long arg3 AND long arg4)
  533. {
  534.   return ((* utility_table[code]) (arg1, arg2, arg3, arg4));
  535. }
  536.  
  537. int
  538. DEFUN (multiply_with_overflow, (x, y, res), long x AND long y AND long * res)
  539. {
  540.   extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
  541.   SCHEME_OBJECT ans;
  542.   
  543.   ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y))));
  544.   if (ans == SHARP_F)
  545.   {
  546.     /* Bogus... */
  547.     (* res) = (x * y);
  548.     return (1);
  549.   }
  550.   else
  551.   {
  552.     (* res) = (FIXNUM_TO_LONG (ans));
  553.     return (0);
  554.   }
  555. }
  556.  
  557. static unsigned int
  558. DEFUN (hex_digit_to_int, (h_digit), char h_digit)
  559. {
  560.   unsigned int digit = ((unsigned int) h_digit);
  561.  
  562.   return (((digit >= '0') && (digit <= '9'))
  563.       ? (digit - '0')
  564.       : (((digit >= 'A') && (digit <= 'F'))
  565.          ? ((digit - 'A') + 10)
  566.          : ((digit - 'a') + 10)));
  567. }
  568.  
  569. SCHEME_OBJECT
  570. DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits),
  571.        long n_bits AND long n_digits AND char * digits)
  572. {
  573.   extern void EXFUN (clear_bit_string, (SCHEME_OBJECT));
  574.   extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long));
  575.   extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int));
  576.   SCHEME_OBJECT result = (allocate_bit_string (n_bits));
  577.   unsigned int digit, mask;
  578.   long i, posn;
  579.   int j;
  580.  
  581.   posn = 0;
  582.   clear_bit_string (result);
  583.  
  584.   for (i = 0; i < n_digits; i++)
  585.   {
  586.     digit = (hex_digit_to_int (*digits++));
  587.     for (j = 0, mask = 1;
  588.      j < 4;
  589.      j++, mask = (mask << 1), posn++)
  590.       if ((digit & mask) != 0)
  591.     bit_string_set (result, posn, 1);
  592.   }
  593.   return (result);
  594. }
  595.  
  596. /* This avoids consing the string and symbol if it already exists. */
  597.  
  598. SCHEME_OBJECT
  599. DEFUN (memory_to_symbol, (length, string),
  600.        long length AND unsigned char * string)
  601. {
  602.   extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *));
  603.   extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT));
  604.   SCHEME_OBJECT symbol;
  605.  
  606.   symbol = (find_symbol (length, string));
  607.   if (symbol != SHARP_F)
  608.     return (symbol);
  609.   return (string_to_symbol (memory_to_string (length, string)));
  610. }
  611.  
  612. static unsigned int
  613. DEFUN (digit_string_producer, (digit_ptr), char ** digit_ptr)
  614. {
  615.   char digit = ** digit_ptr;
  616.   * digit_ptr = ((* digit_ptr) + 1);
  617.   return (hex_digit_to_int (digit));
  618. }
  619.  
  620. SCHEME_OBJECT
  621. DEFUN (digit_string_to_integer, (negative_p, n_digits, digits),
  622.        Boolean negative_p AND long n_digits AND char * digits)
  623. {
  624.   char * digit = digits;
  625.  
  626.   return (digit_stream_to_bignum (((int) n_digits),
  627.                   digit_string_producer,
  628.                   ((PTR) & digit),
  629.                   16,
  630.                   ((int) negative_p)));
  631. }
  632.  
  633. #ifdef USE_STDARG
  634.  
  635. SCHEME_OBJECT
  636. DEFUN (rconsm, (nargs, tail DOTS),
  637.        int nargs AND SCHEME_OBJECT tail DOTS)
  638. {
  639.   va_list arg_ptr;
  640.   va_start (arg_ptr, tail);
  641.  
  642.   {
  643.     int i;
  644.     SCHEME_OBJECT result = tail;
  645.  
  646.     for (i = 1; i < nargs; i++)
  647.       result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
  648.               result));
  649.  
  650.     va_end (arg_ptr);
  651.     return (result);
  652.   }
  653. }
  654.  
  655. #else /* not USE_STDARG */
  656.  
  657. SCHEME_OBJECT
  658. rconsm (va_alist)
  659. va_dcl
  660. {
  661.   va_list arg_ptr;
  662.   int nargs;
  663.   SCHEME_OBJECT tail;
  664.  
  665.   va_start (arg_ptr);
  666.   nargs = (va_arg (arg_ptr, int));
  667.   tail = (va_arg (arg_ptr, SCHEME_OBJECT));
  668.   
  669.   {
  670.     int i;
  671.     SCHEME_OBJECT result = tail;
  672.  
  673.     for (i = 1; i < nargs; i++)
  674.       result = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
  675.               result));
  676.  
  677.     va_end (arg_ptr);
  678.     return (result);
  679.   }
  680. }
  681.  
  682. #endif /* USE_STDARG */
  683.