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 / vector.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  12KB  |  370 lines
  1. /* -*-C-*-
  2.  
  3. $Id: vector.c,v 9.39 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* This file contains procedures for handling vectors. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27. #define ARG_VECTOR(argument_number)                    \
  28.   ((VECTOR_P (ARG_REF (argument_number)))                \
  29.    ? (ARG_REF (argument_number))                    \
  30.    : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
  31.  
  32. #define ARG_RECORD(argument_number)                    \
  33.   ((RECORD_P (ARG_REF (argument_number)))                \
  34.    ? (ARG_REF (argument_number))                    \
  35.    : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
  36.  
  37. #define ARG_VECTOR_INDEX(argument_number, vector)            \
  38.   (arg_index_integer (argument_number, (VECTOR_LENGTH (vector))))
  39.  
  40. #define ARG_GC_VECTOR(argument_number)                    \
  41.   ((GC_VECTOR_P (ARG_REF (argument_number)))                \
  42.    ? (ARG_REF (argument_number))                    \
  43.    : ((error_wrong_type_arg (argument_number)), ((SCHEME_OBJECT) 0)))
  44.  
  45. SCHEME_OBJECT
  46. DEFUN (allocate_non_marked_vector, (type_code, length, gc_check_p),
  47.        int type_code AND fast long length AND Boolean gc_check_p)
  48. {
  49.   fast SCHEME_OBJECT result;
  50.  
  51.   if (gc_check_p)
  52.     Primitive_GC_If_Needed (length + 1);
  53.   result = (MAKE_POINTER_OBJECT (type_code, Free));
  54.   (*Free++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length));
  55.   Free += length;
  56.   return (result);
  57. }
  58.  
  59. SCHEME_OBJECT
  60. DEFUN (allocate_marked_vector, (type_code, length, gc_check_p),
  61.        int type_code AND fast long length AND Boolean gc_check_p)
  62. {
  63.   if (gc_check_p)
  64.     Primitive_GC_If_Needed (length + 1);
  65.   {
  66.     fast SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (type_code, Free));
  67.     (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
  68.     Free += length;
  69.     return (result);
  70.   }
  71. }
  72.  
  73. SCHEME_OBJECT
  74. DEFUN (make_vector, (length, contents, gc_check_p),
  75.        fast long length AND fast SCHEME_OBJECT contents AND Boolean gc_check_p)
  76. {
  77.   if (gc_check_p)
  78.     Primitive_GC_If_Needed (length + 1);
  79.   {
  80.     fast SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_VECTOR, Free));
  81.     (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
  82.     while ((length--) > 0)
  83.       (*Free++) = contents;
  84.     return (result);
  85.   }
  86. }
  87.  
  88. DEFINE_PRIMITIVE ("VECTOR-CONS", Prim_vector_cons, 2, 2, 0)
  89. {
  90.   PRIMITIVE_HEADER (2);
  91.   PRIMITIVE_RETURN
  92.     (make_vector ((arg_nonnegative_integer (1)), (ARG_REF (2)), true));
  93. }
  94.  
  95. DEFINE_PRIMITIVE ("VECTOR", Prim_vector, 0, LEXPR, 0)
  96. {
  97.   PRIMITIVE_HEADER (LEXPR);
  98.   {
  99.     SCHEME_OBJECT result =
  100.       (allocate_marked_vector (TC_VECTOR, (LEXPR_N_ARGUMENTS ()), true));
  101.     fast SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
  102.     fast SCHEME_OBJECT * argument_limit =
  103.       (ARG_LOC ((LEXPR_N_ARGUMENTS ()) + 1));
  104.     fast SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
  105.     while (argument_scan != argument_limit)
  106.       (*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
  107.     PRIMITIVE_RETURN (result);
  108.   }
  109. }
  110.  
  111. DEFINE_PRIMITIVE ("%RECORD", Prim_record, 0, LEXPR, 0)
  112. {
  113.   PRIMITIVE_HEADER (LEXPR);
  114.   {
  115.     long nargs = (LEXPR_N_ARGUMENTS ());
  116.     if (nargs < 1)
  117.       signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  118.     {
  119.       SCHEME_OBJECT result = (allocate_marked_vector (TC_RECORD, nargs, true));
  120.       fast SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
  121.       fast SCHEME_OBJECT * argument_limit = (ARG_LOC (nargs + 1));
  122.       fast SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
  123.       while (argument_scan != argument_limit)
  124.     (*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
  125.       PRIMITIVE_RETURN (result);
  126.     }
  127.   }
  128. }
  129.  
  130. DEFINE_PRIMITIVE ("VECTOR?", Prim_vector_p, 1, 1, 0)
  131. {
  132.   fast SCHEME_OBJECT object;
  133.   PRIMITIVE_HEADER (1);
  134.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  135.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (VECTOR_P (object)));
  136. }
  137.  
  138. DEFINE_PRIMITIVE ("%RECORD?", Prim_record_p, 1, 1, 0)
  139. {
  140.   fast SCHEME_OBJECT object;
  141.   PRIMITIVE_HEADER (1);
  142.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  143.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (RECORD_P (object)));
  144. }
  145.  
  146. DEFINE_PRIMITIVE ("SYSTEM-VECTOR?", Prim_sys_vector, 1, 1, 0)
  147. {
  148.   fast SCHEME_OBJECT object;
  149.   PRIMITIVE_HEADER (1);
  150.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  151.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_VECTOR_P (object)));
  152. }
  153.  
  154. #define VECTOR_LENGTH_PRIMITIVE(arg_type)                \
  155. {                                    \
  156.   fast SCHEME_OBJECT vector;                        \
  157.   PRIMITIVE_HEADER (1);                            \
  158.   TOUCH_IN_PRIMITIVE ((arg_type (1)), vector);                \
  159.   PRIMITIVE_RETURN (long_to_integer (VECTOR_LENGTH (vector)));        \
  160. }
  161.  
  162. DEFINE_PRIMITIVE ("VECTOR-LENGTH", Prim_vector_length, 1, 1, 0)
  163.      VECTOR_LENGTH_PRIMITIVE (ARG_VECTOR)
  164.  
  165. DEFINE_PRIMITIVE ("%RECORD-LENGTH", Prim_record_length, 1, 1, 0)
  166.      VECTOR_LENGTH_PRIMITIVE (ARG_RECORD)
  167.  
  168. DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SIZE", Prim_sys_vec_size, 1, 1, 0)
  169.      VECTOR_LENGTH_PRIMITIVE (ARG_GC_VECTOR)
  170.  
  171. #define VECTOR_REF_PRIMITIVE(arg_type)                    \
  172. {                                    \
  173.   fast SCHEME_OBJECT vector;                        \
  174.   PRIMITIVE_HEADER (2);                            \
  175.   TOUCH_IN_PRIMITIVE ((arg_type (1)), vector);                \
  176.   PRIMITIVE_RETURN                            \
  177.     (VECTOR_REF (vector, (ARG_VECTOR_INDEX (2, vector))));        \
  178. }
  179.  
  180. DEFINE_PRIMITIVE ("VECTOR-REF", Prim_vector_ref, 2, 2, 0)
  181.      VECTOR_REF_PRIMITIVE (ARG_VECTOR)
  182.  
  183. DEFINE_PRIMITIVE ("%RECORD-REF", Prim_record_ref, 2, 2, 0)
  184.      VECTOR_REF_PRIMITIVE (ARG_RECORD)
  185.  
  186. DEFINE_PRIMITIVE ("SYSTEM-VECTOR-REF", Prim_sys_vector_ref, 2, 2, 0)
  187.      VECTOR_REF_PRIMITIVE (ARG_GC_VECTOR)
  188.  
  189. #define VECTOR_SET_PRIMITIVE(arg_type)                    \
  190. {                                    \
  191.   fast SCHEME_OBJECT vector;                        \
  192.   PRIMITIVE_HEADER (3);                            \
  193.   TOUCH_IN_PRIMITIVE ((arg_type (1)), vector);                \
  194.   {                                    \
  195.     fast SCHEME_OBJECT new_value = (ARG_REF (3));            \
  196.     SIDE_EFFECT_IMPURIFY (vector, new_value);                \
  197.     VECTOR_SET (vector, (ARG_VECTOR_INDEX (2, vector)), new_value);    \
  198.   }                                    \
  199.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  200. }
  201.  
  202. DEFINE_PRIMITIVE ("VECTOR-SET!", Prim_vector_set, 3, 3, 0)
  203.      VECTOR_SET_PRIMITIVE (ARG_VECTOR)
  204.  
  205. DEFINE_PRIMITIVE ("%RECORD-SET!", Prim_record_set, 3, 3, 0)
  206.      VECTOR_SET_PRIMITIVE (ARG_RECORD)
  207.  
  208. DEFINE_PRIMITIVE ("SYSTEM-VECTOR-SET!", Prim_sys_vec_set, 3, 3, 0)
  209.      VECTOR_SET_PRIMITIVE (ARG_GC_VECTOR)
  210.  
  211. #define SUBVECTOR_TO_LIST_PRIMITIVE(arg_type)                \
  212. {                                    \
  213.   fast SCHEME_OBJECT vector;                        \
  214.   fast long start;                            \
  215.   fast long end;                            \
  216.   PRIMITIVE_HEADER (3);                            \
  217.   TOUCH_IN_PRIMITIVE ((arg_type (1)), vector);                \
  218.   start = (arg_nonnegative_integer (2));                \
  219.   end = (arg_nonnegative_integer (3));                    \
  220.   if (end > ((long) (VECTOR_LENGTH (vector))))                \
  221.     error_bad_range_arg (3);                        \
  222.   if (start > end)                            \
  223.     error_bad_range_arg (2);                        \
  224.   PRIMITIVE_RETURN (subvector_to_list (vector, start, end));        \
  225. }
  226.  
  227. static SCHEME_OBJECT
  228. DEFUN (subvector_to_list, (vector, start, end),
  229.        SCHEME_OBJECT vector AND long start AND long end)
  230. {
  231.   SCHEME_OBJECT result;
  232.   fast SCHEME_OBJECT *scan;
  233.   fast SCHEME_OBJECT *end_scan;
  234.   fast SCHEME_OBJECT *pair_scan;
  235.   if (start == end)
  236.     return (EMPTY_LIST);
  237.   Primitive_GC_If_Needed (2 * (end - start));
  238.   result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  239.   scan = (VECTOR_LOC (vector, start));
  240.   end_scan = (VECTOR_LOC (vector, (end - 1)));
  241.   pair_scan = Free;
  242.   while (scan < end_scan)
  243.     {
  244.       Free += 2;
  245.       (*pair_scan++) = (MEMORY_FETCH (*scan++));
  246.       (*pair_scan++) = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  247.     }
  248.   Free += 2;
  249.   (*pair_scan++) = (MEMORY_FETCH (*scan));
  250.   (*pair_scan) = EMPTY_LIST;
  251.   return (result);
  252. }
  253.  
  254. DEFINE_PRIMITIVE ("SUBVECTOR->LIST", Prim_subvector_to_list, 3, 3, 0)
  255.      SUBVECTOR_TO_LIST_PRIMITIVE (ARG_VECTOR)
  256.  
  257. DEFINE_PRIMITIVE ("SYSTEM-SUBVECTOR-TO-LIST", Prim_sys_subvector_to_list, 3, 3, 0)
  258.      SUBVECTOR_TO_LIST_PRIMITIVE (ARG_GC_VECTOR)
  259.  
  260. static SCHEME_OBJECT
  261. DEFUN (list_to_vector, (result_type, argument_number),
  262.        long result_type AND long argument_number)
  263. {
  264.   fast SCHEME_OBJECT list;
  265.   fast long count;
  266.   SCHEME_OBJECT *result;
  267.  
  268.   list = (ARG_REF (argument_number));
  269.   TOUCH_IN_PRIMITIVE (list, list);
  270.   count = 0;
  271.   result = (Free++);
  272.   while (PAIR_P (list))
  273.     {
  274.       Primitive_GC_If_Needed (0);
  275.       count += 1;
  276.       (*Free++) = (PAIR_CAR (list));
  277.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
  278.     }
  279.   if (list != EMPTY_LIST)
  280.     error_wrong_type_arg (argument_number);
  281.   (*result) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, count));
  282.   return (MAKE_POINTER_OBJECT (result_type, result));
  283. }
  284.  
  285. DEFINE_PRIMITIVE ("LIST->VECTOR", Prim_list_to_vector, 1, 1, 0)
  286. {
  287.   PRIMITIVE_HEADER (1);
  288.  
  289.   PRIMITIVE_RETURN (list_to_vector (TC_VECTOR, 1));
  290. }
  291.  
  292. DEFINE_PRIMITIVE ("SYSTEM-LIST-TO-VECTOR", Prim_sys_list_to_vector, 2, 2, 0)
  293. {
  294.   long type_code;
  295.   PRIMITIVE_HEADER (2);
  296.  
  297.   type_code = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
  298.   if ((GC_Type_Code (type_code)) != GC_Vector)
  299.     error_bad_range_arg (1);
  300.   PRIMITIVE_RETURN (list_to_vector (type_code, 2));
  301. }
  302.  
  303. /* Primitive vector copy and fill */
  304.  
  305. #define SUBVECTOR_MOVE_PREFIX()                        \
  306.   SCHEME_OBJECT vector1, vector2;                    \
  307.   long start1, end1, start2, end2;                    \
  308.   fast long length;                            \
  309.   fast SCHEME_OBJECT *scan1, *scan2;                    \
  310.   PRIMITIVE_HEADER (5);                            \
  311.   TOUCH_IN_PRIMITIVE ((ARG_VECTOR (1)), vector1);            \
  312.   start1 = (arg_nonnegative_integer (2));                \
  313.   end1 = (arg_nonnegative_integer (3));                    \
  314.   TOUCH_IN_PRIMITIVE ((ARG_VECTOR (4)), vector2);            \
  315.   start2 = (arg_nonnegative_integer (5));                \
  316.   if (end1 > ((long) (VECTOR_LENGTH (vector1))))            \
  317.     error_bad_range_arg (3);                        \
  318.   if (start1 > end1)                            \
  319.     error_bad_range_arg (2);                        \
  320.   length = (end1 - start1);                        \
  321.   end2 = (start2 + length);                        \
  322.   if (end2 > ((long) (VECTOR_LENGTH (vector2))))            \
  323.     error_bad_range_arg (5);                        \
  324.   if (ADDRESS_PURE_P (OBJECT_ADDRESS (vector2)))            \
  325.     signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE)
  326.  
  327. DEFINE_PRIMITIVE ("SUBVECTOR-MOVE-RIGHT!", Prim_subvector_move_right, 5, 5, 0)
  328. {
  329.   SUBVECTOR_MOVE_PREFIX ();
  330.   scan1 = (VECTOR_LOC (vector1, end1));
  331.   scan2 = (VECTOR_LOC (vector2, end2));
  332.   while ((length--) > 0)
  333.     (*--scan2) = (*--scan1);
  334.   PRIMITIVE_RETURN (UNSPECIFIC);
  335. }
  336.  
  337. DEFINE_PRIMITIVE ("SUBVECTOR-MOVE-LEFT!", Prim_subvector_move_left, 5, 5, 0)
  338. {
  339.   SUBVECTOR_MOVE_PREFIX ();
  340.   scan1 = (VECTOR_LOC (vector1, start1));
  341.   scan2 = (VECTOR_LOC (vector2, start2));
  342.   while ((length--) > 0)
  343.     (*scan2++) = (*scan1++);
  344.   PRIMITIVE_RETURN (UNSPECIFIC);
  345. }
  346.  
  347. DEFINE_PRIMITIVE ("SUBVECTOR-FILL!", Prim_vector_fill, 4, 4, 0)
  348. {
  349.   SCHEME_OBJECT vector;
  350.   long start, end;
  351.   fast SCHEME_OBJECT fill_value;
  352.   fast SCHEME_OBJECT *scan;
  353.   fast long length;
  354.   PRIMITIVE_HEADER (4);
  355.   TOUCH_IN_PRIMITIVE ((ARG_VECTOR (1)), vector);
  356.   start = (arg_nonnegative_integer (2));
  357.   end = (arg_nonnegative_integer (3));
  358.   fill_value = (ARG_REF (4));
  359.   if (end > ((long) (VECTOR_LENGTH (vector))))
  360.     error_bad_range_arg (3);
  361.   if (start > end)
  362.     error_bad_range_arg (2);
  363.   length = (end - start);
  364.   SIDE_EFFECT_IMPURIFY (vector, fill_value);
  365.   scan = (VECTOR_LOC (vector, start));
  366.   while ((length--) > 0)
  367.     (*scan++) = fill_value;
  368.   PRIMITIVE_RETURN (UNSPECIFIC);
  369. }
  370.