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 / string.c < prev    next >
C/C++ Source or Header  |  2001-03-08  |  25KB  |  828 lines
  1. /* -*-C-*-
  2.  
  3. $Id: string.c,v 9.44 2001/03/08 17:14:36 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* String primitives. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27. #ifndef STDC_HEADERS
  28. #  ifdef HAVE_MALLOC_H
  29. #    include <malloc.h>
  30. #  else
  31.      extern PTR EXFUN (malloc, (size_t));
  32.      extern PTR EXFUN (realloc, (PTR, size_t));
  33. #  endif
  34. #endif
  35.  
  36. SCHEME_OBJECT
  37. DEFUN (allocate_string, (nbytes), unsigned long nbytes)
  38. {
  39.   SCHEME_OBJECT result
  40.     = (allocate_non_marked_vector
  41.        (TC_CHARACTER_STRING,
  42.     (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
  43.     1));
  44.   SET_STRING_LENGTH (result, nbytes);
  45.   return (result);
  46. }
  47.  
  48. SCHEME_OBJECT
  49. DEFUN (allocate_string_no_gc, (nbytes), unsigned long nbytes)
  50. {
  51.   SCHEME_OBJECT result
  52.     = (allocate_non_marked_vector
  53.        (TC_CHARACTER_STRING,
  54.     (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
  55.     0));
  56.   SET_STRING_LENGTH (result, nbytes);
  57.   return (result);
  58. }
  59.  
  60. SCHEME_OBJECT
  61. DEFUN (memory_to_string, (nbytes, data),
  62.        unsigned long nbytes AND
  63.        CONST unsigned char * data)
  64. {
  65.   SCHEME_OBJECT result = (allocate_string (nbytes));
  66.   unsigned char * scan_result = (STRING_LOC (result, 0));
  67.   unsigned char * end_result = (scan_result + nbytes);
  68.   while (scan_result < end_result)
  69.     (*scan_result++) = (*data++);
  70.   return (result);
  71. }
  72.  
  73. SCHEME_OBJECT
  74. DEFUN (memory_to_string_no_gc, (nbytes, data),
  75.        unsigned long nbytes AND
  76.        CONST unsigned char * data)
  77. {
  78.   SCHEME_OBJECT result = (allocate_string_no_gc (nbytes));
  79.   unsigned char * scan_result = (STRING_LOC (result, 0));
  80.   unsigned char * end_result = (scan_result + nbytes);
  81.   while (scan_result < end_result)
  82.     (*scan_result++) = (*data++);
  83.   return (result);
  84. }
  85.  
  86. SCHEME_OBJECT
  87. DEFUN (char_pointer_to_string, (char_pointer),
  88.        CONST unsigned char * char_pointer)
  89. {
  90.   CONST unsigned char * scan = char_pointer;
  91.   if (scan == 0)
  92.     scan += 1;
  93.   else
  94.     while ((*scan++) != '\0')
  95.       ;
  96.   return (memory_to_string (((scan - 1) - char_pointer), char_pointer));
  97. }
  98.  
  99. SCHEME_OBJECT
  100. DEFUN (char_pointer_to_string_no_gc, (char_pointer),
  101.        CONST unsigned char * char_pointer)
  102. {
  103.   CONST unsigned char * scan = char_pointer;
  104.   if (scan == 0)
  105.     scan += 1;
  106.   else
  107.     while ((*scan++) != '\0')
  108.       ;
  109.   return (memory_to_string_no_gc (((scan - 1) - char_pointer), char_pointer));
  110. }
  111.  
  112. /* Currently the strings used in symbols have type codes in the length
  113.    field.  They should be changed to have just longwords there. */
  114.  
  115. DEFINE_PRIMITIVE ("STRING-ALLOCATE", Prim_string_allocate, 1, 1, 0)
  116. {
  117.   PRIMITIVE_HEADER (1);
  118.   PRIMITIVE_RETURN (allocate_string (arg_nonnegative_integer (1)));
  119. }
  120.  
  121. DEFINE_PRIMITIVE ("STRING?", Prim_string_p, 1, 1, 0)
  122. {
  123.   PRIMITIVE_HEADER (1);
  124.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (STRING_P (ARG_REF (1))));
  125. }
  126.  
  127. DEFINE_PRIMITIVE ("STRING-LENGTH", Prim_string_length, 1, 1, 0)
  128. {
  129.   PRIMITIVE_HEADER (1);
  130.   CHECK_ARG (1, STRING_P);
  131.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (STRING_LENGTH (ARG_REF (1))));
  132. }
  133.  
  134. DEFINE_PRIMITIVE ("STRING-MAXIMUM-LENGTH", Prim_string_maximum_length, 1, 1, 0)
  135. {
  136.   PRIMITIVE_HEADER (1);
  137.   CHECK_ARG (1, STRING_P);
  138.   PRIMITIVE_RETURN
  139.     (LONG_TO_UNSIGNED_FIXNUM (MAXIMUM_STRING_LENGTH (ARG_REF (1))));
  140. }
  141.  
  142. DEFINE_PRIMITIVE ("SET-STRING-LENGTH!", Prim_set_string_length, 2, 2, 0)
  143. {
  144.   PRIMITIVE_HEADER (2);
  145.   CHECK_ARG (1, STRING_P);
  146.   {
  147.     SCHEME_OBJECT string = (ARG_REF (1));
  148.     SET_STRING_LENGTH
  149.       (string,
  150.        (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1))));
  151.   }
  152.   PRIMITIVE_RETURN (UNSPECIFIC);
  153. }
  154.  
  155. DEFINE_PRIMITIVE ("SET-STRING-MAXIMUM-LENGTH!", Prim_set_string_maximum_length, 2, 2, 0)
  156. {
  157.   PRIMITIVE_HEADER (2);
  158.   CHECK_ARG (1, STRING_P);
  159.   {
  160.     SCHEME_OBJECT string = (ARG_REF (1));
  161.     long length =
  162.       (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1)));
  163.     MEMORY_SET
  164.       (string,
  165.        STRING_HEADER,
  166.        (MAKE_OBJECT
  167.     (TC_MANIFEST_NM_VECTOR, ((BYTES_TO_WORDS (length + 1)) + 1))));
  168.     SET_STRING_LENGTH (string, length);
  169.   }
  170.   PRIMITIVE_RETURN (UNSPECIFIC);
  171. }
  172.  
  173. #define STRING_REF_BODY(process_result)                    \
  174. {                                    \
  175.   PRIMITIVE_HEADER (2);                            \
  176.   CHECK_ARG (1, STRING_P);                        \
  177.   {                                    \
  178.     SCHEME_OBJECT string = (ARG_REF (1));                \
  179.     PRIMITIVE_RETURN                            \
  180.       (process_result                            \
  181.        (STRING_REF                            \
  182.     (string, (arg_index_integer (2, (STRING_LENGTH (string)))))));    \
  183.   }                                    \
  184. }
  185.  
  186. DEFINE_PRIMITIVE ("STRING-REF", Prim_string_ref, 2, 2, 0)
  187.      STRING_REF_BODY (ASCII_TO_CHAR)
  188.  
  189. DEFINE_PRIMITIVE ("VECTOR-8B-REF", Prim_vec_8b_ref, 2, 2, 0)
  190.      STRING_REF_BODY (LONG_TO_UNSIGNED_FIXNUM)
  191.  
  192. #define STRING_SET_BODY(get_ascii)                    \
  193. {                                    \
  194.   PRIMITIVE_HEADER (3);                            \
  195.   CHECK_ARG (1, STRING_P);                        \
  196.   {                                    \
  197.     SCHEME_OBJECT string = (ARG_REF (1));                \
  198.     STRING_SET                                \
  199.       (string,                                \
  200.        (arg_index_integer (2, (STRING_LENGTH (string)))),        \
  201.        ((unsigned char) (get_ascii (3))));                \
  202.   }                                    \
  203.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  204. }
  205.  
  206. DEFINE_PRIMITIVE ("STRING-SET!", Prim_string_set, 3, 3, 0)
  207.      STRING_SET_BODY (arg_ascii_char)
  208.  
  209. DEFINE_PRIMITIVE ("VECTOR-8B-SET!", Prim_vec_8b_set, 3, 3, 0)
  210.      STRING_SET_BODY (arg_ascii_integer)
  211.  
  212. #define SUBSTRING_MOVE_PREFIX()                        \
  213.   unsigned char *ptr1, *ptr2;                        \
  214.   unsigned long len1, len2;                        \
  215.   unsigned long start1, end1, start2, end2, length;            \
  216.   unsigned char *scan1, *scan2, *limit;                    \
  217.   PRIMITIVE_HEADER (5);                            \
  218.   ptr1 = (arg_extended_string (1, (&len1)));                \
  219.   end1 = (arg_ulong_index_integer (3, (len1 + 1)));            \
  220.   start1 = (arg_ulong_index_integer (2, (end1 + 1)));            \
  221.   ptr2 = (arg_extended_string (4, (&len2)));                \
  222.   start2 = (arg_ulong_index_integer (5, (len2 + 1)));            \
  223.   length = (end1 - start1);                        \
  224.   end2 = (start2 + length);                        \
  225.   if (end2 > len2)                            \
  226.     error_bad_range_arg (5)
  227.  
  228. DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_substring_move_right, 5, 5, 0)
  229. {
  230.   SUBSTRING_MOVE_PREFIX ();
  231.   scan1 = (ptr1 + end1);
  232.   scan2 = (ptr2 + end2);
  233.   limit = (scan1 - length);
  234.   while (scan1 > limit)
  235.     (*--scan2) = (*--scan1);
  236.   PRIMITIVE_RETURN (UNSPECIFIC);
  237. }
  238.  
  239. DEFINE_PRIMITIVE ("SUBSTRING-MOVE-LEFT!", Prim_substring_move_left, 5, 5, 0)
  240. {
  241.   SUBSTRING_MOVE_PREFIX ();
  242.   scan1 = (ptr1 + start1);
  243.   scan2 = (ptr2 + start2);
  244.   limit = (scan1 + length);
  245.   while (scan1 < limit)
  246.     (*scan2++) = (*scan1++);
  247.   PRIMITIVE_RETURN (UNSPECIFIC);
  248. }
  249.  
  250. #define SUBSTRING_MODIFIER(char_map)                    \
  251. {                                    \
  252.   SCHEME_OBJECT string;                            \
  253.   long start, end;                            \
  254.   long length;                                \
  255.   unsigned char *scan, temp;                        \
  256.   PRIMITIVE_HEADER (3);                            \
  257.   CHECK_ARG (1, STRING_P);                        \
  258.   string = (ARG_REF (1));                        \
  259.   start = (arg_nonnegative_integer (2));                \
  260.   end = (arg_nonnegative_integer (3));                    \
  261.   if (end > (STRING_LENGTH (string)))                    \
  262.     error_bad_range_arg (3);                        \
  263.   if (start > end)                            \
  264.     error_bad_range_arg (2);                        \
  265.   length = (end - start);                        \
  266.   scan = (STRING_LOC (string, start));                    \
  267.   while ((length--) > 0)                        \
  268.     {                                    \
  269.       temp = (*scan);                            \
  270.       (*scan++) = ((unsigned char) (char_map (temp)));            \
  271.     }                                    \
  272.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  273. }
  274.  
  275. DEFINE_PRIMITIVE ("SUBSTRING-UPCASE!", Prim_substring_upcase, 3, 3, 0)
  276.      SUBSTRING_MODIFIER (char_upcase)
  277.  
  278. DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_substring_downcase, 3, 3, 0)
  279.      SUBSTRING_MODIFIER (char_downcase)
  280.  
  281. #define VECTOR_8B_SUBSTRING_PREFIX()                    \
  282.   long start, end, ascii;                        \
  283.   unsigned char *string_start, *scan, *limit;                \
  284.   PRIMITIVE_HEADER (4);                            \
  285.   CHECK_ARG (1, STRING_P);                        \
  286.   string_start = (STRING_LOC ((ARG_REF (1)), 0));            \
  287.   start = (arg_nonnegative_integer (2));                \
  288.   end = (arg_nonnegative_integer (3));                    \
  289.   ascii = (arg_ascii_integer (4));                    \
  290.   if (end > (STRING_LENGTH (ARG_REF (1))))                \
  291.     error_bad_range_arg (3);                        \
  292.   if (start > end)                            \
  293.     error_bad_range_arg (2)
  294.  
  295. #define VECTOR_8B_SUBSTRING_PREFIX_FORWARD()                \
  296.   VECTOR_8B_SUBSTRING_PREFIX ();                    \
  297.   scan = (string_start + start);                    \
  298.   limit = (string_start + end);
  299.  
  300. #define VECTOR_8B_SUBSTRING_PREFIX_BACKWARD()                \
  301.   VECTOR_8B_SUBSTRING_PREFIX ();                    \
  302.   scan = (string_start + end);                        \
  303.   limit = (string_start + start);
  304.  
  305. DEFINE_PRIMITIVE ("VECTOR-8B-FILL!", Prim_vec_8b_fill, 4, 4, 0)
  306. {
  307.   VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
  308.   while (scan < limit)
  309.     (*scan++) = ((unsigned char) ascii);
  310.   PRIMITIVE_RETURN (UNSPECIFIC);
  311. }
  312.  
  313. DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR", Prim_vec_8b_find_next_char, 4, 4, 0)
  314. {
  315.   VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
  316.   while (scan < limit)
  317.     if ((*scan++) == ascii)
  318.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
  319.   PRIMITIVE_RETURN (SHARP_F);
  320. }
  321.  
  322. DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR", Prim_vec_8b_find_prev_char, 4, 4, 0)
  323. {
  324.   VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
  325.   while (scan > limit)
  326.     if ((*--scan) == ascii)
  327.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
  328.   PRIMITIVE_RETURN (SHARP_F);
  329. }
  330.  
  331. DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR-CI", Prim_vec_8b_find_next_char_ci, 4, 4, 0)
  332. {
  333.   VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
  334.   {
  335.     unsigned char char1 = ((unsigned char) (char_upcase (ascii)));
  336.     while (scan < limit)
  337.       if ((char_upcase (*scan++)) == char1)
  338.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
  339.   }
  340.   PRIMITIVE_RETURN (SHARP_F);
  341. }
  342.  
  343. DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR-CI", Prim_vec_8b_find_prev_char_ci, 4, 4, 0)
  344. {
  345.   VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
  346.   {
  347.     unsigned char char1 = ((unsigned char) (char_upcase (ascii)));
  348.     while (scan > limit)
  349.       if ((char_upcase (*--scan)) == char1)
  350.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
  351.   }
  352.   PRIMITIVE_RETURN (SHARP_F);
  353. }
  354.  
  355. #define SUBSTR_FIND_CHAR_IN_SET_PREFIX()                \
  356.   long start, end;                            \
  357.   unsigned char *char_set, *string_start, *scan, *limit;        \
  358.   PRIMITIVE_HEADER (4);                            \
  359.   CHECK_ARG (1, STRING_P);                        \
  360.   string_start = (STRING_LOC ((ARG_REF (1)), 0));            \
  361.   start = (arg_nonnegative_integer (2));                \
  362.   end = (arg_nonnegative_integer (3));                    \
  363.   CHECK_ARG (4, STRING_P);                        \
  364.   char_set = (STRING_LOC ((ARG_REF (4)), 0));                \
  365.   if (end > (STRING_LENGTH (ARG_REF (1))))                \
  366.     error_bad_range_arg (3);                        \
  367.   if (start > end)                            \
  368.     error_bad_range_arg (2);                        \
  369.   if ((STRING_LENGTH (ARG_REF (4))) != MAX_ASCII)            \
  370.     error_bad_range_arg (4)
  371.  
  372. DEFINE_PRIMITIVE ("SUBSTRING-FIND-NEXT-CHAR-IN-SET", Prim_find_next_char_in_set, 4, 4, 0)
  373. {
  374.   SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
  375.   scan = (string_start + start);
  376.   limit = (string_start + end);
  377.   while (scan < limit)
  378.     if ((char_set [*scan++]) != '\0')
  379.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
  380.   PRIMITIVE_RETURN (SHARP_F);
  381. }
  382.  
  383. DEFINE_PRIMITIVE ("SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", Prim_find_prev_char_in_set, 4, 4, 0)
  384. {
  385.   SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
  386.   scan = (string_start + end);
  387.   limit = (string_start + start);
  388.   while (scan > limit)
  389.     if ((char_set [*--scan]) != '\0')
  390.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
  391.   PRIMITIVE_RETURN (SHARP_F);
  392. }
  393.  
  394. #define SUBSTRING_COMPARE_PREFIX()                \
  395.   long start1, end1, start2, end2;                \
  396.   unsigned char *string1_start, *string2_start;            \
  397.   PRIMITIVE_HEADER (6);                        \
  398.   CHECK_ARG (1, STRING_P);                    \
  399.   string1_start = (STRING_LOC ((ARG_REF (1)), 0));        \
  400.   start1 = (arg_nonnegative_integer (2));            \
  401.   end1 = (arg_nonnegative_integer (3));                \
  402.   CHECK_ARG (4, STRING_P);                    \
  403.   string2_start = (STRING_LOC ((ARG_REF (4)), 0));        \
  404.   start2 = (arg_nonnegative_integer (5));            \
  405.   end2 = (arg_nonnegative_integer (6));                \
  406.   if (end1 > (STRING_LENGTH (ARG_REF (1))))            \
  407.     error_bad_range_arg (3);                    \
  408.   if (start1 > end1)                        \
  409.     error_bad_range_arg (2);                    \
  410.   if (end2 > (STRING_LENGTH (ARG_REF (4))))            \
  411.     error_bad_range_arg (6);                    \
  412.   if (start2 > end2)                        \
  413.     error_bad_range_arg (5)
  414.  
  415. #define SUBSTRING_EQUAL_PREFIX()                \
  416.   unsigned char *scan1, *scan2, *limit;                \
  417.   SUBSTRING_COMPARE_PREFIX ();                    \
  418.   if ((end1 - start1) != (end2 - start2))            \
  419.     PRIMITIVE_RETURN (SHARP_F);                    \
  420.   scan1 = (string1_start + start1);                \
  421.   limit = (string1_start + end1);                \
  422.   scan2 = (string2_start + start2)
  423.  
  424. DEFINE_PRIMITIVE ("SUBSTRING=?", Prim_substring_equal, 6, 6, 0)
  425. {
  426.   SUBSTRING_EQUAL_PREFIX ();
  427.   while (scan1 < limit)
  428.     if ((*scan1++) != (*scan2++))
  429.       PRIMITIVE_RETURN (SHARP_F);
  430.   PRIMITIVE_RETURN (SHARP_T);
  431. }
  432.  
  433. DEFINE_PRIMITIVE ("SUBSTRING-CI=?", Prim_substring_ci_equal, 6, 6, 0)
  434. {
  435.   SUBSTRING_EQUAL_PREFIX ();
  436.   while (scan1 < limit)
  437.     if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
  438.       PRIMITIVE_RETURN (SHARP_F);
  439.   PRIMITIVE_RETURN (SHARP_T);
  440. }
  441.  
  442. DEFINE_PRIMITIVE ("SUBSTRING<?", Prim_substring_less, 6, 6, 0)
  443. {
  444.   SUBSTRING_COMPARE_PREFIX ();
  445.   {
  446.     unsigned char * scan1 = (string1_start + start1);
  447.     unsigned char * scan2 = (string2_start + start2);
  448.     long length1 = (end1 - start1);
  449.     long length2 = (end2 - start2);
  450.     unsigned char * limit =
  451.       (scan1 + ((length1 < length2) ? length1 : length2));
  452.     while (scan1 < limit)
  453.       if ((*scan1++) != (*scan2++))
  454.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1 [-1]) < (scan2 [-1])));
  455.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (length1 < length2));
  456.   }
  457. }
  458.  
  459. static long
  460. DEFUN (substring_length_min, (start1, end1, start2, end2),
  461.        long start1
  462.        AND long end1
  463.        AND long start2
  464.        AND long end2)
  465. {
  466.   long length1 = (end1 - start1);
  467.   long length2 = (end2 - start2);
  468.   return ((length1 < length2) ? length1 : length2);
  469. }
  470.  
  471. #define SUBSTRING_MATCH_PREFIX()                    \
  472.   unsigned char *scan1, *scan2, *limit;                    \
  473.   long length;                                \
  474.   unsigned char *scan1_start;                        \
  475.   SUBSTRING_COMPARE_PREFIX ();                        \
  476.   length = (substring_length_min (start1, end1, start2, end2))
  477.  
  478. DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD", Prim_match_forward, 6, 6, 0)
  479. {
  480.   SUBSTRING_MATCH_PREFIX ();
  481.   scan1 = (string1_start + start1);
  482.   scan2 = (string2_start + start2);
  483.   limit = (scan1 + length);
  484.   scan1_start = scan1;
  485.   while (scan1 < limit)
  486.     if ((*scan1++) != (*scan2++))
  487.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
  488.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
  489. }
  490.  
  491. DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD-CI", Prim_match_forward_ci, 6, 6, 0)
  492. {
  493.   SUBSTRING_MATCH_PREFIX ();
  494.   scan1 = (string1_start + start1);
  495.   scan2 = (string2_start + start2);
  496.   limit = (scan1 + length);
  497.   scan1_start = scan1;
  498.   while (scan1 < limit)
  499.     if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
  500.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
  501.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
  502. }
  503.  
  504. DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD", Prim_match_backward, 6, 6, 0)
  505. {
  506.   SUBSTRING_MATCH_PREFIX ();
  507.   scan1 = (string1_start + end1);
  508.   scan2 = (string2_start + end2);
  509.   limit = (scan1 - length);
  510.   scan1_start = scan1;
  511.   while (scan1 > limit)
  512.     if ((*--scan1) != (*--scan2))
  513.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
  514.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
  515. }
  516.  
  517. DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_match_backward_ci, 6, 6, 0)
  518. {
  519.   SUBSTRING_MATCH_PREFIX ();
  520.   scan1 = (string1_start + end1);
  521.   scan2 = (string2_start + end2);
  522.   limit = (scan1 - length);
  523.   scan1_start = scan1;
  524.   while (scan1 > limit)
  525.     if ((char_upcase (*--scan1)) != (char_upcase (*--scan2)))
  526.       PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
  527.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
  528. }
  529.  
  530. /* External strings */
  531.  
  532. /* An external string is just a chunk of memory allocated using malloc
  533.    outside of Scheme's address space.  It is represented to Scheme as
  534.    an integer -- the address of the memory.  Each external string is
  535.    registered in a hash table when it is allocated so that we can
  536.    validate the incoming integers.  */
  537.  
  538. typedef struct ht_record_s ht_record_t;
  539. struct ht_record_s
  540. {
  541.   ht_record_t * next;
  542.   unsigned long n_bytes;
  543. };
  544.  
  545. #define HT_RECORD_PTR(record) ((PTR) ((record) + 1))
  546. #define HT_RECORD_KEY(record) ((unsigned long) ((record) + 1))
  547. #define HT_RECORD_NEXT(record) ((record) -> next)
  548. #define HT_RECORD_N_BYTES(record) ((record) -> n_bytes)
  549.  
  550. typedef struct
  551. {
  552.   unsigned long n_records;
  553.   unsigned long n_buckets;
  554.   ht_record_t ** buckets;
  555. } hash_table_t;
  556.  
  557. #define HT_N_RECORDS(table) ((table) -> n_records)
  558. #define HT_N_BUCKETS(table) ((table) -> n_buckets)
  559. #define HT_BUCKET_INDEX(table, key) ((key) % (HT_N_BUCKETS (table)))
  560. #define HT_BUCKETS(table) ((table) -> buckets)
  561. #define HT_BUCKET_REF(table, index) ((HT_BUCKETS (table)) [(index)])
  562. #define HT_SHRINK_POINT(table) ((((HT_N_BUCKETS (table)) + 1) / 2) - 1)
  563.  
  564. static hash_table_t * EXFUN (make_hash_table, (void));
  565. static void EXFUN (ht_resize, (hash_table_t *, unsigned long));
  566. static void EXFUN (zero_ht_buckets, (hash_table_t *));
  567. static ht_record_t * EXFUN (ht_records_list, (hash_table_t *));
  568. static ht_record_t * EXFUN (ht_lookup, (hash_table_t *, unsigned long));
  569. static unsigned long EXFUN (ht_insert, (hash_table_t *, ht_record_t *));
  570. static ht_record_t * EXFUN (ht_delete, (hash_table_t *, unsigned long));
  571.  
  572. static hash_table_t * external_strings = 0;
  573.  
  574. DEFINE_PRIMITIVE ("ALLOCATE-EXTERNAL-STRING", Prim_alloc_external_string, 1, 1, 0)
  575. {
  576.   PRIMITIVE_HEADER (1);
  577.   {
  578.     unsigned long n_bytes = (arg_ulong_integer (1));
  579.     ht_record_t * result = (malloc (n_bytes + 1 + (sizeof (ht_record_t))));
  580.     if (result == 0)
  581.       error_bad_range_arg (1);
  582.     if (external_strings == 0)
  583.       external_strings = (make_hash_table ());
  584.     (HT_RECORD_N_BYTES (result)) = n_bytes;
  585.     /* Guarantee zero termination in case used as C string.  */
  586.     (((char *) (HT_RECORD_PTR (result))) [n_bytes]) = '\0';
  587.     PRIMITIVE_RETURN (ulong_to_integer (ht_insert (external_strings, result)));
  588.   }
  589. }
  590.  
  591. DEFINE_PRIMITIVE ("EXTERNAL-STRING?", Prim_external_string_p, 1, 1, 0)
  592. {
  593.   PRIMITIVE_HEADER (1);
  594.   {
  595.     SCHEME_OBJECT x = (ARG_REF (1));
  596.     if ((INTEGER_P (x)) && (integer_to_ulong_p (x)))
  597.       {
  598.     ht_record_t * record;
  599.     if (external_strings == 0)
  600.       external_strings = (make_hash_table ());
  601.     record = (ht_lookup (external_strings, (integer_to_ulong (x))));
  602.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (record != 0));
  603.       }
  604.     else
  605.       PRIMITIVE_RETURN (SHARP_F);
  606.   }
  607. }
  608.  
  609. DEFINE_PRIMITIVE ("DEALLOCATE-EXTERNAL-STRING", Prim_dealloc_external_string, 1, 1, 0)
  610. {
  611.   PRIMITIVE_HEADER (1);
  612.   {
  613.     unsigned long n = (arg_ulong_integer (1));
  614.     ht_record_t * record;
  615.     if (external_strings == 0)
  616.       external_strings = (make_hash_table ());
  617.     record = (ht_delete (external_strings, n));
  618.     if (record == 0)
  619.       error_wrong_type_arg (1);
  620.     free (record);
  621.     PRIMITIVE_RETURN (UNSPECIFIC);
  622.   }
  623. }
  624.  
  625. DEFINE_PRIMITIVE ("EXTENDED-STRING-LENGTH", Prim_extended_string_length, 1, 1, 0)
  626. {
  627.   PRIMITIVE_HEADER (1);
  628.   {
  629.     unsigned long len;
  630.     arg_extended_string (1, (&len));
  631.     PRIMITIVE_RETURN (ulong_to_integer (len));
  632.   }
  633. }
  634.  
  635. PTR
  636. DEFUN (arg_extended_string, (n), unsigned int n AND unsigned long * lp)
  637. {
  638.   SCHEME_OBJECT object = (ARG_REF (n));
  639.   if (STRING_P (object))
  640.     {
  641.       if (lp != 0)
  642.     (*lp) = (STRING_LENGTH (object));
  643.       return (STRING_LOC (object, 0));
  644.     }
  645.   else if ((INTEGER_P (object)) && (integer_to_ulong_p (object)))
  646.     {
  647.       ht_record_t * record;
  648.       if (external_strings == 0)
  649.     external_strings = (make_hash_table ());
  650.       record = (ht_lookup (external_strings, (integer_to_ulong (object))));
  651.       if (record == 0)
  652.     error_wrong_type_arg (n);
  653.       if (lp != 0)
  654.     (*lp) = (HT_RECORD_N_BYTES (record));
  655.       return (HT_RECORD_PTR (record));
  656.     }
  657.   else
  658.     {
  659.       error_wrong_type_arg (n);
  660.       return (0);
  661.     }
  662. }
  663.  
  664. #define HT_MIN_EXPT 4
  665. #define HT_MAX_EXPT 24
  666.  
  667. #define EXPT_TO_N(e) ((1 << (e)) - 1)
  668.  
  669. static hash_table_t *
  670. DEFUN_VOID (make_hash_table)
  671. {
  672.   unsigned long n = (EXPT_TO_N (HT_MIN_EXPT));
  673.   hash_table_t * table = (malloc (sizeof (hash_table_t)));
  674.   if (table == 0)
  675.     abort ();
  676.   (HT_N_RECORDS (table)) = 0;
  677.   (HT_N_BUCKETS (table)) = n;
  678.   (HT_BUCKETS (table)) = (malloc (n * (sizeof (ht_record_t *))));
  679.   if ((HT_BUCKETS (table)) == 0)
  680.     abort ();
  681.   zero_ht_buckets (table);
  682.   return (table);
  683. }
  684.  
  685. static void
  686. DEFUN (ht_resize, (table, new_n_buckets),
  687.        hash_table_t * table AND
  688.        unsigned long new_n_buckets)
  689. {
  690.   ht_record_t ** new_buckets
  691.     = (malloc (new_n_buckets * (sizeof (ht_record_t *))));
  692.   if (new_buckets != 0)
  693.     {
  694.       ht_record_t * records = (ht_records_list (table));
  695.       (HT_BUCKETS (table)) = new_buckets;
  696.       (HT_N_BUCKETS (table)) = new_n_buckets;
  697.       (HT_N_RECORDS (table)) = 0;
  698.       zero_ht_buckets (table);
  699.       while (records != 0)
  700.     {
  701.       ht_record_t * next = (HT_RECORD_NEXT (records));
  702.       ht_insert (table, records);
  703.       records = next;
  704.     }
  705.     }
  706. }
  707.  
  708. static void
  709. DEFUN (zero_ht_buckets, (table), hash_table_t * table)
  710. {
  711.   ht_record_t ** scan = (HT_BUCKETS (table));
  712.   ht_record_t ** end = (scan + (HT_N_BUCKETS (table)));
  713.   while (scan < end)
  714.     (*scan++) = 0;
  715. }
  716.  
  717. static ht_record_t *
  718. DEFUN (ht_records_list, (table), hash_table_t * table)
  719. {
  720.   ht_record_t ** scan_buckets = (HT_BUCKETS (table));
  721.   ht_record_t ** end_buckets = (scan_buckets + (HT_N_BUCKETS (table)));
  722.   ht_record_t * result = 0;
  723.   while (scan_buckets < end_buckets)
  724.     {
  725.       ht_record_t * scan = (*scan_buckets);
  726.       while (scan != 0)
  727.     {
  728.       ht_record_t * next = (HT_RECORD_NEXT (scan));
  729.       (HT_RECORD_NEXT (scan)) = result;
  730.       result = scan;
  731.       scan = next;
  732.     }
  733.       (*scan_buckets++) = 0;
  734.     }
  735.   return (result);
  736. }
  737.  
  738. static ht_record_t *
  739. DEFUN (ht_lookup, (table, key),
  740.        hash_table_t * table AND
  741.        unsigned long key)
  742. {
  743.   unsigned long index = (HT_BUCKET_INDEX (table, key));
  744.   ht_record_t * record = (HT_BUCKET_REF (table, index));
  745.   while (record != 0)
  746.     {
  747.       if ((HT_RECORD_KEY (record)) == key)
  748.     return (record);
  749.       record = (HT_RECORD_NEXT (record));
  750.     }
  751.   return (0);
  752. }
  753.  
  754. static unsigned long
  755. DEFUN (ht_insert, (table, record),
  756.        hash_table_t * table AND
  757.        ht_record_t * record)
  758. {
  759.   unsigned long index = (HT_BUCKET_INDEX (table, (HT_RECORD_KEY (record))));
  760.   ht_record_t * scan = (HT_BUCKET_REF (table, index));
  761.   (HT_RECORD_NEXT (record)) = 0;
  762.   if (scan == 0)
  763.     (HT_BUCKET_REF (table, index)) = record;
  764.   else
  765.     {
  766.       while ((HT_RECORD_NEXT (scan)) != 0)
  767.     scan = (HT_RECORD_NEXT (scan));
  768.       (HT_RECORD_NEXT (scan)) = record;
  769.     }
  770.   (HT_N_RECORDS (table)) += 1;
  771.   if (((HT_N_RECORDS (table)) >= (HT_N_BUCKETS (table)))
  772.       && ((HT_N_BUCKETS (table)) < (EXPT_TO_N (HT_MAX_EXPT))))
  773.     {
  774.       unsigned int e = HT_MIN_EXPT;
  775.       while (e <= HT_MAX_EXPT)
  776.     {
  777.       unsigned long n = (EXPT_TO_N (e));
  778.       if (n > (HT_N_BUCKETS (table)))
  779.         {
  780.           ht_resize (table, n);
  781.           break;
  782.         }
  783.       e += 1;
  784.     }
  785.     }
  786.   return (HT_RECORD_KEY (record));
  787. }
  788.  
  789. static ht_record_t *
  790. DEFUN (ht_delete, (table, key),
  791.        hash_table_t * table AND
  792.        unsigned long key)
  793. {
  794.   unsigned long index = (HT_BUCKET_INDEX (table, key));
  795.   ht_record_t * scan = (HT_BUCKET_REF (table, index));
  796.   ht_record_t * prev = 0;
  797.   while (1)
  798.     {
  799.       if (scan == 0)
  800.     return (0);
  801.       if ((HT_RECORD_KEY (scan)) == key)
  802.     break;
  803.       prev = scan;
  804.       scan = (HT_RECORD_NEXT (scan));
  805.     }
  806.   if (prev == 0)
  807.     (HT_BUCKET_REF (table, index)) = (HT_RECORD_NEXT (scan));
  808.   else
  809.     (HT_RECORD_NEXT (prev)) = (HT_RECORD_NEXT (scan));
  810.   (HT_N_RECORDS (table)) -= 1;
  811.   if (((HT_N_RECORDS (table)) < (HT_SHRINK_POINT (table)))
  812.       && ((HT_N_BUCKETS (table)) > (EXPT_TO_N (HT_MIN_EXPT))))
  813.     {
  814.       unsigned int e = HT_MAX_EXPT;
  815.       while (e >= HT_MIN_EXPT)
  816.     {
  817.       unsigned long n = (EXPT_TO_N (e));
  818.       if (n < (HT_N_BUCKETS (table)))
  819.         {
  820.           ht_resize (table, n);
  821.           break;
  822.         }
  823.       e -= 1;
  824.     }
  825.     }
  826.   return (scan);
  827. }
  828.