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 / primutl.c < prev    next >
C/C++ Source or Header  |  2001-03-08  |  17KB  |  597 lines
  1. /* -*-C-*-
  2.  
  3. $Id: primutl.c,v 9.74 2001/03/08 18:00:28 cph Exp $
  4.  
  5. Copyright (c) 1988-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. /* 
  23.  * This file contains the support routines for mapping primitive names
  24.  * to numbers within the microcode.  Primitives are written in C
  25.  * and available in Scheme, but not always present in all versions of
  26.  * the interpreter.  Thus, these objects are always referenced
  27.  * externally by name and converted to numeric references only for the
  28.  * duration of a single Scheme session.
  29.  */
  30.  
  31. #include "scheme.h"
  32. #include "prims.h"
  33. #include "os.h"
  34. #include "usrdef.h"
  35. #include "prename.h"
  36. #include "syscall.h"
  37. #include "avltree.h"
  38. #include "cmpgc.h"
  39. #include <ctype.h>
  40.  
  41. extern PTR EXFUN (malloc, (size_t));
  42. extern PTR EXFUN (realloc, (PTR, size_t));
  43.  
  44. #ifdef STDC_HEADERS
  45. #  include <string.h>
  46. #else
  47.    extern PTR EXFUN (memcpy, (PTR, CONST PTR, size_t));
  48.    extern char * EXFUN (strcpy, (char *, CONST char *));
  49. #endif
  50.  
  51. extern SCHEME_OBJECT * load_renumber_table;
  52.  
  53. #ifndef UPDATE_PRIMITIVE_TABLE_HOOK
  54. #  define UPDATE_PRIMITIVE_TABLE_HOOK(low, high) do { } while (0)
  55. #endif
  56.  
  57. #ifndef GROW_PRIMITIVE_TABLE_HOOK
  58. #  define GROW_PRIMITIVE_TABLE_HOOK(size) true
  59. #endif
  60.  
  61. /*
  62.   Exported variables:
  63.  */
  64.  
  65. long MAX_PRIMITIVE = 0;
  66.  
  67. primitive_procedure_t * Primitive_Procedure_Table = 0;
  68.  
  69. int * Primitive_Arity_Table = 0;
  70.  
  71. int * Primitive_Count_Table = 0;
  72.  
  73. CONST char ** Primitive_Name_Table = 0;
  74.  
  75. CONST char ** Primitive_Documentation_Table = 0;
  76.  
  77. SCHEME_OBJECT * load_renumber_table = 0;
  78.  
  79. /*
  80.   Exported utilities:
  81.  */
  82.  
  83. extern void
  84.   EXFUN (initialize_primitives, (void)),
  85.   EXFUN (install_primitive_table, (SCHEME_OBJECT *, long));
  86.  
  87. extern SCHEME_OBJECT
  88.   EXFUN (make_primitive, (char *, int)),
  89.   EXFUN (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int)),
  90.   EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)),
  91.   * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)),
  92.   * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
  93.   * EXFUN (cons_whole_primitive_table,
  94.        (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)),
  95.   EXFUN (Prim_unimplemented, (void));
  96.  
  97. extern int
  98.   EXFUN (strcmp_ci, (char *, char *));
  99.  
  100. /* Common utilities. */
  101.  
  102. #ifndef _toupper
  103. #  define _toupper toupper
  104. #endif
  105.  
  106. int
  107. DEFUN (strcmp_ci, (s1, s2), fast char * s1 AND fast char * s2)
  108. {
  109.   fast int diff;
  110.  
  111.   while ((*s1 != '\0') && (*s2 != '\0'))
  112.   {
  113.     fast int c1 = (*s1++);
  114.     fast int c2 = (*s2++);
  115.     if (islower (c1)) c1 = (_toupper (c1));
  116.     if (islower (c2)) c2 = (_toupper (c2));
  117.     diff = (c1 - c2);
  118.     if (diff != 0)
  119.       return ((diff > 0) ? 1 : -1);
  120.   }
  121.   diff = (*s1 - *s2);
  122.   return ((diff == 0) ? 0 : ((diff > 0) ? 1 : -1));
  123. }
  124.  
  125. SCHEME_OBJECT
  126. DEFUN_VOID (Prim_unimplemented)
  127. {
  128.   PRIMITIVE_HEADER (-1);
  129.  
  130.   signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
  131.   /*NOTREACHED*/
  132.   PRIMITIVE_RETURN (UNSPECIFIC);
  133. }
  134.  
  135. static void
  136. DEFUN (initialization_error, (reason, item), char * reason AND char * item)
  137. {
  138.   outf_fatal ("initialize_primitives: Error %s %s.\n", reason, item);
  139.   termination_init_error ();
  140. }
  141.  
  142. static long prim_table_size = 0;
  143.  
  144. static Boolean
  145. DEFUN (copy_table, (ltable, otable, item_size),
  146.        PTR * ltable AND PTR otable AND int item_size)
  147. {
  148.   long size = (((long) item_size) * prim_table_size);
  149.   PTR ntable;
  150.  
  151.   if (*ltable != ((PTR) NULL))
  152.     ntable = ((PTR) (realloc (*ltable, size)));
  153.   else
  154.   {
  155.     ntable = ((PTR) (malloc (size)));
  156.     if (ntable != ((PTR) NULL))
  157.       memcpy (ntable, otable, size);
  158.   }
  159.   if (ntable != ((PTR) NULL))
  160.     *ltable = ntable;
  161.   return (ntable != ((PTR) NULL));
  162. }
  163.  
  164. static Boolean
  165. DEFUN_VOID (grow_primitive_tables)
  166. {
  167.   Boolean result;
  168.  
  169.   prim_table_size = (MAX_PRIMITIVE + (MAX_PRIMITIVE / 10));
  170.  
  171.   result = (   (copy_table (((PTR *) &Primitive_Arity_Table),
  172.                 ((PTR) &Static_Primitive_Arity_Table[0]),
  173.                 (sizeof (int))))
  174.         && (copy_table (((PTR *) &Primitive_Count_Table),
  175.                 ((PTR) &Static_Primitive_Count_Table[0]),
  176.                 (sizeof (int))))
  177.         && (copy_table (((PTR *) &Primitive_Name_Table),
  178.                 ((PTR) &Static_Primitive_Name_Table[0]),
  179.                 (sizeof (char *))))
  180.         && (copy_table (((PTR *) &Primitive_Documentation_Table),
  181.                 ((PTR) &Static_Primitive_Documentation_Table[0]),
  182.                 (sizeof (char *))))
  183.         && (copy_table (((PTR *) &Primitive_Procedure_Table),
  184.                 ((PTR) &Static_Primitive_Procedure_Table[0]),
  185.                 (sizeof (primitive_procedure_t))))
  186.         && (GROW_PRIMITIVE_TABLE_HOOK (prim_table_size)));
  187.   if (result)
  188.     UPDATE_PRIMITIVE_TABLE_HOOK (0, MAX_PRIMITIVE);
  189.   else
  190.     prim_table_size = prim_table_size;
  191.   return (result);
  192. }
  193.  
  194. static tree_node prim_procedure_tree = ((tree_node) NULL);
  195.  
  196. void
  197. DEFUN_VOID (initialize_primitives)
  198. {
  199.   unsigned long counter;
  200.  
  201.   /* MAX_STATIC_PRIMITIVE is the index of the last primitive */
  202.  
  203.   MAX_PRIMITIVE = (MAX_STATIC_PRIMITIVE + 1);
  204.   if (! (grow_primitive_tables ()))
  205.     initialization_error ("allocating", "the primitive tables");
  206.  
  207.   tree_error_message = ((char *) NULL);
  208.   prim_procedure_tree = (tree_build (MAX_PRIMITIVE, Primitive_Name_Table, 0));
  209.   if (tree_error_message != ((char *) NULL))
  210.   {
  211.     outf_fatal (tree_error_message, tree_error_noise);
  212.     initialization_error ("building", "prim_procedure_tree");
  213.   }
  214.  
  215.   for (counter = 0; counter < N_PRIMITIVE_ALIASES; counter++)
  216.   {
  217.     unsigned long index;
  218.     tree_node new;
  219.     tree_node orig = (tree_lookup (prim_procedure_tree,
  220.                    primitive_aliases[counter].name));
  221.  
  222.     if (orig != ((tree_node) NULL))
  223.       index = orig->value;
  224.     else
  225.     {
  226.       SCHEME_OBJECT old = (make_primitive (primitive_aliases[counter].name,
  227.                        UNKNOWN_PRIMITIVE_ARITY));
  228.       
  229.       if (old == SHARP_F)
  230.       {
  231.     outf_fatal ("Error declaring unknown primitive %s.\n",
  232.             primitive_aliases[counter].name);
  233.     initialization_error ("aliasing", primitive_aliases[counter].alias);
  234.       }
  235.       index = (PRIMITIVE_NUMBER (old));
  236.     }
  237.  
  238.     new = (tree_insert (prim_procedure_tree,
  239.             primitive_aliases[counter].alias,
  240.             index));
  241.     if (tree_error_message != ((char *) NULL))
  242.     {
  243.       outf_fatal (tree_error_message, tree_error_noise);
  244.       initialization_error ("aliasing", primitive_aliases[counter].alias);
  245.     }
  246.     prim_procedure_tree = new;
  247.   }
  248.   return;
  249. }
  250.  
  251. static SCHEME_OBJECT
  252. DEFUN (declare_primitive_internal,
  253.        (override_p, name, code, nargs_lo, nargs_hi, docstr),
  254.        Boolean override_p
  255.        AND CONST char * name
  256.        AND primitive_procedure_t code
  257.        AND int nargs_lo
  258.        AND int nargs_hi
  259.        AND CONST char * docstr)
  260. /* nargs_lo ignored, for now */
  261. {
  262.   unsigned long index;
  263.   SCHEME_OBJECT primitive;
  264.   CONST char * ndocstr = docstr;
  265.   tree_node prim = (tree_lookup (prim_procedure_tree, name));
  266.  
  267.   if (prim != ((tree_node) NULL))
  268.   {
  269.     index = prim->value;
  270.     primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
  271.     if ((((PRIMITIVE_ARITY (primitive)) != nargs_hi)
  272.      && ((PRIMITIVE_ARITY (primitive)) != UNKNOWN_PRIMITIVE_ARITY))
  273.     || ((IMPLEMENTED_PRIMITIVE_P (primitive)) && (! override_p)))
  274.       return (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (primitive)));
  275.     if (docstr == 0)
  276.       ndocstr = (Primitive_Documentation_Table[index]);
  277.   }
  278.   else
  279.   {
  280.     if (MAX_PRIMITIVE == prim_table_size)
  281.       if (! (grow_primitive_tables ()))
  282.     return (SHARP_F);
  283.  
  284.     /* Allocate a new primitive index, and insert in data base. */
  285.  
  286.     index = MAX_PRIMITIVE;
  287.     prim = (tree_insert (prim_procedure_tree, name, index));
  288.     if (tree_error_message != ((char *) NULL))
  289.     {
  290.       outf_error (tree_error_message, tree_error_noise);
  291.       tree_error_message = ((char *) NULL);
  292.       return (SHARP_F);
  293.     }
  294.     prim_procedure_tree = prim;
  295.  
  296.     MAX_PRIMITIVE += 1;
  297.     primitive = (MAKE_PRIMITIVE_OBJECT (index));
  298.     Primitive_Name_Table[index]        = name;
  299.   }
  300.  
  301.   Primitive_Procedure_Table[index]     = code;
  302.   Primitive_Arity_Table[index]         = nargs_hi;
  303.   Primitive_Count_Table[index]         = (nargs_hi * (sizeof (SCHEME_OBJECT)));
  304.   Primitive_Documentation_Table[index] = ndocstr;
  305.   UPDATE_PRIMITIVE_TABLE_HOOK (index, (index + 1));
  306.   return (primitive);
  307. }
  308.  
  309. /* declare_primitive installs a new primitive in the system.
  310.    It returns:
  311.    - A primitive object if it succeeds.
  312.    - SHARP_F if there was a problem trying to install it (e.g. out of memory).
  313.    - A fixnum whose value is the number of the pre-existing primitive
  314.      that it would replace.
  315.    Note that even if a primitive is returned, its number may not
  316.    be the previous value of MAX_PRIMITIVE, since the system may
  317.    have pre-existent references to the previously-unimplemented primitive.
  318.  */
  319.  
  320. SCHEME_OBJECT
  321. DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr),
  322.        CONST char * name
  323.        AND primitive_procedure_t code
  324.        AND int nargs_lo
  325.        AND int nargs_hi
  326.        AND CONST char * docstr)
  327. {
  328.   return (declare_primitive_internal (false, name, code,
  329.                       nargs_lo, nargs_hi, docstr));
  330. }
  331.  
  332. /* install_primitive is similar to declare_primitive, but will
  333.    replace a pre-existing primitive if the arities are consistent.
  334.    If they are not, it returns a fixnum whose value is the index
  335.    of the pre-existing primitive.
  336.  */
  337.  
  338. SCHEME_OBJECT
  339. DEFUN (install_primitive, (name, code, nargs_lo, nargs_hi, docstr),
  340.        CONST char * name
  341.        AND primitive_procedure_t code
  342.        AND int nargs_lo
  343.        AND int nargs_hi
  344.        AND CONST char * docstr)
  345. {
  346.   return (declare_primitive_internal (true, name, code,
  347.                       nargs_lo, nargs_hi, docstr));
  348. }
  349.  
  350. /*
  351.   make_primitive returns a primitive object,
  352.   constructing one if necessary.
  353.  */
  354.  
  355. SCHEME_OBJECT
  356. DEFUN (make_primitive, (name, arity), char * name AND int arity)
  357. {
  358.   SCHEME_OBJECT result;
  359.  
  360.   result = (declare_primitive (name,
  361.                    Prim_unimplemented,
  362.                    arity,
  363.                    arity,
  364.                    ((char *) NULL)));
  365.   return ((result == SHARP_F)
  366.       ? SHARP_F
  367.       : (OBJECT_NEW_TYPE (TC_PRIMITIVE, result)));
  368. }
  369.  
  370. /* This returns all sorts of different things that the runtime
  371.    system decodes.
  372.  */
  373.  
  374. SCHEME_OBJECT
  375. DEFUN (find_primitive, (sname, intern_p, allow_p, arity),
  376.        SCHEME_OBJECT sname AND Boolean intern_p
  377.        AND Boolean allow_p AND int arity)
  378. {
  379.   tree_node prim = (tree_lookup (prim_procedure_tree,
  380.                  ((char *) (STRING_LOC (sname, 0)))));
  381.  
  382.   if (prim != ((tree_node) NULL))
  383.   {
  384.     SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
  385.  
  386.     if ((! allow_p) && (! (IMPLEMENTED_PRIMITIVE_P (primitive))))
  387.       return (SHARP_F);
  388.     
  389.     if ((arity == UNKNOWN_PRIMITIVE_ARITY)
  390.     || (arity == (PRIMITIVE_ARITY (primitive))))
  391.       return (primitive);
  392.     else if ((PRIMITIVE_ARITY (primitive)) == UNKNOWN_PRIMITIVE_ARITY)
  393.     {
  394.       /* We've just learned the arity of the primitive. */
  395.       Primitive_Arity_Table[PRIMITIVE_NUMBER (primitive)] = arity;
  396.       return (primitive);
  397.     }
  398.     else
  399.       /* Arity mismatch, notify the runtime system. */
  400.       return (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive)));
  401.   }
  402.   else if (! intern_p)
  403.     return (SHARP_F);
  404.   else
  405.   {
  406.     SCHEME_OBJECT primitive;
  407.     char * cname = ((char *) (malloc (1 + (STRING_LENGTH (sname)))));
  408.  
  409.     if (cname == ((char *) NULL))
  410.       error_in_system_call (syserr_not_enough_space, syscall_malloc);
  411.     strcpy (cname, ((char *) (STRING_LOC (sname, 0))));
  412.     primitive =
  413.       (declare_primitive (cname,
  414.               Prim_unimplemented,
  415.               ((arity < 0) ? 0 : arity),
  416.               arity,
  417.               ((char *) NULL)));
  418.     if (primitive == SHARP_F)
  419.       error_in_system_call (syserr_not_enough_space, syscall_malloc);
  420.     return (primitive);
  421.   }
  422. }
  423.  
  424. /* These are used by fasdump to renumber primitives on the way out.
  425.    Only those primitives actually referenced by the object being
  426.    dumped are described in the output.  The primitives being
  427.    dumped are renumbered in the output to a contiguous range
  428.    starting at 0.
  429.  */
  430.  
  431. static SCHEME_OBJECT * internal_renumber_table;
  432. static SCHEME_OBJECT * external_renumber_table;
  433. static long next_primitive_renumber;
  434.  
  435. /* This is called during fasdump setup. */
  436.  
  437. SCHEME_OBJECT *
  438. DEFUN (initialize_primitive_table, (where, end),
  439.        fast SCHEME_OBJECT * where AND SCHEME_OBJECT * end)
  440. {
  441.   SCHEME_OBJECT * top;
  442.   fast long number_of_primitives;
  443.  
  444.   top = &where[2 * MAX_PRIMITIVE];
  445.   if (top < end)
  446.   {
  447.     internal_renumber_table = where;
  448.     external_renumber_table = &where[MAX_PRIMITIVE];
  449.     next_primitive_renumber = 0;
  450.  
  451.     for (number_of_primitives = MAX_PRIMITIVE;
  452.      (--number_of_primitives >= 0);)
  453.       (*where++) = SHARP_F;
  454.   }
  455.   return (top);
  456. }
  457.  
  458. /* This is called every time fasdump meets a primitive to be renumbered.
  459.    It is called on objects with tag TC_PRIMITIVE or TC_PCOMB0,
  460.    so it preserves the tag of its argument.
  461.  */
  462.  
  463. SCHEME_OBJECT
  464. DEFUN (dump_renumber_primitive, (primitive), fast SCHEME_OBJECT primitive)
  465. {
  466.   fast long number;
  467.   fast SCHEME_OBJECT result;
  468.  
  469.   number = (PRIMITIVE_NUMBER (primitive));
  470.   result = internal_renumber_table[number];
  471.   if (result != SHARP_F)
  472.     return (MAKE_OBJECT_FROM_OBJECTS (primitive, result));
  473.   else
  474.   {
  475.     result = (OBJECT_NEW_DATUM (primitive, next_primitive_renumber));
  476.     internal_renumber_table[number] = result;
  477.     external_renumber_table[next_primitive_renumber] = primitive;
  478.     next_primitive_renumber += 1;
  479.     return (result);
  480.   }
  481. }
  482.  
  483. /* Utility for fasdump and dump-band */
  484.  
  485. static SCHEME_OBJECT *
  486. DEFUN (copy_primitive_information, (code, start, end),
  487.        long code AND fast SCHEME_OBJECT * start AND fast SCHEME_OBJECT * end)
  488. {
  489.   static char null_string [] = "\0";
  490.   CONST char * source;
  491.   char * dest;
  492.   char * limit;
  493.   long char_count, word_count;
  494.   SCHEME_OBJECT * saved;
  495.  
  496.   if (start < end)
  497.     (*start++) = (LONG_TO_FIXNUM (Primitive_Arity_Table [code]));
  498.  
  499.   source = (Primitive_Name_Table [code]);
  500.   saved = start;
  501.   start += STRING_CHARS;
  502.   dest = ((char *) start);
  503.   limit = ((char *) end);
  504.   if (source == ((char *) 0))
  505.     source = ((char *) (& (null_string [0])));
  506.   while ((dest < limit) && (((*dest++) = (*source++)) != '\0'))
  507.     ;
  508.   if (dest >= limit)
  509.     while ((*source++) != '\0')
  510.       dest += 1;
  511.   char_count = ((dest - 1) - ((char *) start));
  512.   word_count = (STRING_LENGTH_TO_GC_LENGTH (char_count));
  513.   start = (saved + 1 + word_count);
  514.   if (start < end)
  515.   {
  516.     (saved [STRING_HEADER]) =
  517.       (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, word_count));
  518.     (saved [STRING_LENGTH_INDEX]) = ((SCHEME_OBJECT) char_count);
  519.   }
  520.   return (start);
  521. }
  522.  
  523. /* This is called at the end of the relocation step to
  524.    allocate the actual table to dump on the output file.
  525.  */
  526.  
  527. SCHEME_OBJECT *
  528. DEFUN (cons_primitive_table, (start, end, length),
  529.        SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND long * length)
  530.  
  531. {
  532.   SCHEME_OBJECT * saved;
  533.   long count, code;
  534.  
  535.   saved = start;
  536.   * length = next_primitive_renumber;
  537.  
  538.   for (count = 0;
  539.        ((count < next_primitive_renumber) && (start < end));
  540.        count += 1)
  541.   {
  542.     code = (PRIMITIVE_NUMBER (external_renumber_table[count]));
  543.     start = (copy_primitive_information (code, start, end));
  544.   }
  545.   return (start);
  546. }
  547.  
  548. /* This is called when a band is dumped.
  549.    All the primitives are dumped unceremoniously.
  550.  */
  551.  
  552. SCHEME_OBJECT *
  553. DEFUN (cons_whole_primitive_table, (start, end, length),
  554.        SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND long * length)
  555. {
  556.   SCHEME_OBJECT * saved;
  557.   long count;
  558.  
  559.   saved = start;
  560.   * length = MAX_PRIMITIVE;
  561.  
  562.   for (count = 0;
  563.        ((count < MAX_PRIMITIVE) && (start < end));
  564.        count += 1)
  565.     start = (copy_primitive_information (count, start, end));
  566.  
  567.   return (start);
  568. }
  569.  
  570. /* This is called from fasload and load-band */
  571.  
  572. void
  573. DEFUN (install_primitive_table, (table, length),
  574.        fast SCHEME_OBJECT * table
  575.        AND fast long length)
  576. {
  577.   fast SCHEME_OBJECT * translation_table;
  578.   SCHEME_OBJECT result;
  579.   long arity;
  580.  
  581.   translation_table = load_renumber_table;
  582.   while (--length >= 0)
  583.   {
  584.     arity = (FIXNUM_TO_LONG (* table));
  585.     table += 1;
  586.     result =
  587.       (find_primitive ((MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, table)),
  588.                true, true, arity));
  589.     if ((OBJECT_TYPE (result)) != TC_PRIMITIVE)
  590.       signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES);
  591.  
  592.     *translation_table++ = result;
  593.     table += (1 + (OBJECT_DATUM (* table)));
  594.   }
  595.   return;
  596. }
  597.