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 / list.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  11KB  |  351 lines
  1. /* -*-C-*-
  2.  
  3. $Id: list.c,v 9.32 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. /* List creation and manipulation primitives. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27. DEFINE_PRIMITIVE ("PAIR?", Prim_pair, 1, 1, 
  28.  "(object)\n\
  29.   Returns #t if object is a pair; otherwise returns #f.\
  30. ")
  31. {
  32.   fast SCHEME_OBJECT object;
  33.   PRIMITIVE_HEADER (1);
  34.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  35.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (PAIR_P (object)));
  36. }
  37.  
  38. SCHEME_OBJECT
  39. DEFUN (cons, (car, cdr),
  40.        SCHEME_OBJECT car
  41.        AND SCHEME_OBJECT cdr)
  42. {
  43.   Primitive_GC_If_Needed (2);
  44.   (*Free++) = car;
  45.   (*Free++) = cdr;
  46.   return (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
  47. }
  48.  
  49. DEFINE_PRIMITIVE ("CONS", Prim_cons, 2, 2,
  50.  "(obj1 obj2)\n\
  51.   Returns a newly allocated pair whose car is OBJ1 and whose cdr is OBJ2.\n\
  52.   The pair is guaranteed to be different (in the sense of EQV?) from other\n\
  53.   previously existing object.\
  54.  ")
  55. {
  56.   PRIMITIVE_HEADER (2);
  57.   PRIMITIVE_RETURN (cons ((ARG_REF (1)), (ARG_REF (2))));
  58. }
  59.  
  60. DEFINE_PRIMITIVE ("CAR", Prim_car, 1, 1,
  61.  "(pair)\n\
  62.   Returns the contents of the car field of PAIR.\n\
  63.   Note that it is an error to take the CAR of an empty list.\
  64.  ")
  65. {
  66.   PRIMITIVE_HEADER (1);
  67.   CHECK_ARG (1, PAIR_P);
  68.   PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1)));
  69. }
  70.  
  71. DEFINE_PRIMITIVE ("CDR", Prim_cdr, 1, 1,
  72.  "(pair)\n\
  73.   Returns the contents of the cdr field of PAIR.\n\
  74.   Note that it is an error to take the CDR of an empty list.\
  75.  ")
  76. {
  77.   PRIMITIVE_HEADER (1);
  78.   CHECK_ARG (1, PAIR_P);
  79.   PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1)));
  80. }
  81.  
  82. DEFINE_PRIMITIVE ("SET-CAR!", Prim_set_car, 2, 2,
  83.  "(pair object)\n\
  84.   Store OBJECT in the car field of PAIR.\n\
  85.   The value returned by SET-CAR! is unspecified.\
  86.  ")
  87. {
  88.   PRIMITIVE_HEADER (2);
  89.   CHECK_ARG (1, PAIR_P);
  90.   {
  91.     fast SCHEME_OBJECT pair = (ARG_REF (1));
  92.     fast SCHEME_OBJECT car = (ARG_REF (2));
  93.     SIDE_EFFECT_IMPURIFY (pair, car);
  94.     SET_PAIR_CAR (pair, car);
  95.   }
  96.   PRIMITIVE_RETURN (UNSPECIFIC);
  97. }
  98.  
  99. DEFINE_PRIMITIVE ("SET-CDR!", Prim_set_cdr, 2, 2,
  100.  "(pair object)\n\
  101.   Store OBJECT in the cdr field of PAIR.\n\
  102.   The value returned by SET-CDR! is unspecified.\
  103.  ")
  104. {
  105.   PRIMITIVE_HEADER (2);
  106.   CHECK_ARG (1, PAIR_P);
  107.   {
  108.     fast SCHEME_OBJECT pair = (ARG_REF (1));
  109.     fast SCHEME_OBJECT cdr = (ARG_REF (2));
  110.     SIDE_EFFECT_IMPURIFY (pair, cdr);
  111.     SET_PAIR_CDR (pair, cdr);
  112.   }
  113.   PRIMITIVE_RETURN (UNSPECIFIC);
  114. }
  115.  
  116. /* (GENERAL-CAR-CDR LIST DIRECTIONS)
  117.    DIRECTIONS encodes a string of CAR and CDR operations to be
  118.    performed on LIST as follows:
  119.      1   = NOP    101 = CDAR
  120.      10  = CDR    110 = CADR
  121.      11  = CAR    111 = CAAR
  122.      100 = CDDR    ... */
  123.  
  124. DEFINE_PRIMITIVE ("GENERAL-CAR-CDR", Prim_general_car_cdr, 2, 2,
  125.  "(object path)\n\
  126.  This procedure is a generalization of `car' and `cdr'. PATH\n\
  127.  encodes a particular sequence of `car' and `cdr' operations, which\n\
  128.  `general-car-cdr' executes on OBJECT. PATH is an exact\n\
  129.  non-negative integer that encodes the operations in a bitwise\n\
  130.  fashion: a zero bit represents a `cdr' operation, and a one bit\n\
  131.  represents a `car'.  The bits are executed LSB to MSB, and the\n\
  132.  most significant one bit, rather than being interpreted as an\n\
  133.  operation, signals the end of the sequence.\n\
  134.  \n\
  135.  For example, the following are equivalent:\n\
  136.       (general-car-cdr OBJECT #b1011)\n\
  137.       (cdr (car (car OBJECT)))\n\
  138.  \n\
  139.  Here is a partial table of path/operation equivalents:\n\
  140.  \n\
  141.       #b10    cdr\n\
  142.       #b11    car\n\
  143.       #b100   cddr\n\
  144.       #b101   cdar\n\
  145.       #b110   cadr\n\
  146.       #b111   caar\n\
  147.       #b1000  cdddr\n\
  148.   \n\
  149.   Note that PATH is restricted to a machine-dependent range,\n\
  150.   usually the size of a machine word.  On many machines, this means that\n\
  151.   the maximum length of PATH will be 30 operations (32 bits, less the\n\
  152.   sign bit and the "end-of-sequence" bit).\
  153.  ")
  154. {
  155.   PRIMITIVE_HEADER (2);
  156.   {
  157.     fast SCHEME_OBJECT object = (ARG_REF (1));
  158.     fast long CAR_CDR_Pattern = (arg_nonnegative_integer (2));
  159.     while (CAR_CDR_Pattern > 1)
  160.       {
  161.     TOUCH_IN_PRIMITIVE (object, object);
  162.     if (! (PAIR_P (object)))
  163.       error_wrong_type_arg (1);
  164.     object =
  165.       (((CAR_CDR_Pattern & 1) == 0)
  166.        ? (PAIR_CDR (object))
  167.        : (PAIR_CAR (object)));
  168.     CAR_CDR_Pattern >>= 1;
  169.       }
  170.     PRIMITIVE_RETURN (object);
  171.   }
  172. }
  173.  
  174. DEFINE_PRIMITIVE ("LENGTH", Prim_length, 1, 1,
  175.  "(list)\n\
  176.   Returns the length of LIST.\
  177.  ")
  178. {
  179.   fast SCHEME_OBJECT list;
  180.   fast long i = 0;
  181.   PRIMITIVE_HEADER (1);
  182.  
  183.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), list);
  184.   while (PAIR_P (list))
  185.     {
  186.       i += 1;
  187.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
  188.     }
  189.   if (list != EMPTY_LIST)
  190.     error_wrong_type_arg (1);
  191.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (i));
  192. }
  193.  
  194. DEFINE_PRIMITIVE ("MEMQ", Prim_memq, 2, 2,
  195.  "(object list)\n\
  196.   Returns the first pair of LIST whose car is OBJECT;\n\
  197.   the returned pair is always one from which LIST is composed.\n\
  198.   If OBJECT does not occur in LIST, `#f' (n.b.: not the\n\
  199.   empty list) is returned.  `memq' uses `eq?' to compare OBJECT with\n\
  200.   the elements of LIST, while `memv' uses `eqv?' and `member' uses\n\
  201.   `equal?'.\n\
  202.   \n\
  203.        (memq 'a '(a b c))                      =>  (a b c)\n\
  204.        (memq 'b '(a b c))                      =>  (b c)\n\
  205.        (memq 'a '(b c d))                      =>  #f\n\
  206.        (memq (list 'a) '(b (a) c))             =>  #f\n\
  207.        (member (list 'a) '(b (a) c))           =>  ((a) c)\n\
  208.        (memq 101 '(100 101 102))               =>  unspecified\n\
  209.        (memv 101 '(100 101 102))               =>  (101 102)\n\
  210.   \n\
  211.   Although they are often used as predicates, `memq', `memv', and\n\
  212.   `member' do not have question marks in their names because they return\n\
  213.   useful values rather than just `#t' or `#f'.\
  214.  ")
  215. {
  216.   fast SCHEME_OBJECT key;
  217.   fast SCHEME_OBJECT list;
  218.   fast SCHEME_OBJECT list_key;
  219.   PRIMITIVE_HEADER (2);
  220.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), key);
  221.   TOUCH_IN_PRIMITIVE ((ARG_REF (2)), list);
  222.   while (PAIR_P (list))
  223.     {
  224.       TOUCH_IN_PRIMITIVE ((PAIR_CAR (list)), list_key);
  225.       if (list_key == key)
  226.     PRIMITIVE_RETURN (list);
  227.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (list)), list);
  228.     }
  229.   if (list != EMPTY_LIST)
  230.     error_wrong_type_arg (2);
  231.   PRIMITIVE_RETURN (SHARP_F);
  232. }
  233.  
  234. DEFINE_PRIMITIVE ("ASSQ", Prim_assq, 2, 2,
  235.  "(object alist)\n\
  236.   These procedures find the first pair in ALIST whose car field is\n\
  237.   OBJECT, and return that pair; the returned pair is always an\n\
  238.   *element* of ALIST, *not* one of the pairs from which ALIST is\n\
  239.   composed.  If no pair in ALIST has OBJECT as its car, `#f' (n.b.:\n\
  240.   not the empty list) is returned.  `assq' uses `eq?' to compare\n\
  241.   OBJECT with the car fields of the pairs in ALIST, while `assv'\n\
  242.   uses `eqv?' and `assoc' uses `equal?'.\n\
  243.   \n\
  244.        (define e '((a 1) (b 2) (c 3)))\n\
  245.        (assq 'a e)                             =>  (a 1)\n\
  246.        (assq 'b e)                             =>  (b 2)\n\
  247.        (assq 'd e)                             =>  #f\n\
  248.        (assq (list 'a) '(((a)) ((b)) ((c))))   =>  #f\n\
  249.        (assoc (list 'a) '(((a)) ((b)) ((c))))  =>  ((a))\n\
  250.        (assq 5 '((2 3) (5 7) (11 13)))         =>  unspecified\n\
  251.        (assv 5 '((2 3) (5 7) (11 13)))         =>  (5 7)\n\
  252.   \n\
  253.   Although they are often used as predicates, `assq', `assv', and\n\
  254.   `assoc' do not have question marks in their names because they return\n\
  255.   useful values rather than just `#t' or `#f'.\
  256.  ")
  257. {
  258.   fast SCHEME_OBJECT key;
  259.   fast SCHEME_OBJECT alist;
  260.   fast SCHEME_OBJECT association;
  261.   fast SCHEME_OBJECT association_key;
  262.   PRIMITIVE_HEADER (2);
  263.  
  264.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), key);
  265.   TOUCH_IN_PRIMITIVE ((ARG_REF (2)), alist);
  266.   while (PAIR_P (alist))
  267.     {
  268.       TOUCH_IN_PRIMITIVE ((PAIR_CAR (alist)), association);
  269.       if (! (PAIR_P (association)))
  270.     error_wrong_type_arg (2);
  271.       TOUCH_IN_PRIMITIVE ((PAIR_CAR (association)), association_key);
  272.       if (association_key == key)
  273.     PRIMITIVE_RETURN (association);
  274.       TOUCH_IN_PRIMITIVE ((PAIR_CDR (alist)), alist);
  275.     }
  276.   if (alist != EMPTY_LIST)
  277.     error_wrong_type_arg (2);
  278.   PRIMITIVE_RETURN (SHARP_F);
  279. }
  280.  
  281. DEFINE_PRIMITIVE ("SYSTEM-PAIR?", Prim_sys_pair, 1, 1, 0)
  282. {
  283.   fast SCHEME_OBJECT object;
  284.   PRIMITIVE_HEADER (1);
  285.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  286.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (GC_PAIR_P (object)));
  287. }
  288.  
  289. SCHEME_OBJECT
  290. DEFUN (system_pair_cons, (type, car, cdr),
  291.        long type
  292.        AND SCHEME_OBJECT car
  293.        AND SCHEME_OBJECT cdr)
  294. {
  295.   Primitive_GC_If_Needed (2);
  296.   (*Free++) = car;
  297.   (*Free++) = cdr;
  298.   return (MAKE_POINTER_OBJECT (type, (Free - 2)));
  299. }
  300.  
  301. DEFINE_PRIMITIVE ("SYSTEM-PAIR-CONS", Prim_sys_pair_cons, 3, 3, 0)
  302. {
  303.   PRIMITIVE_HEADER (3);
  304.   {
  305.     long type = (arg_index_integer (1, (MAX_TYPE_CODE + 1)));
  306.     if ((GC_Type_Code (type)) != GC_Pair)
  307.       error_bad_range_arg (1);
  308.     PRIMITIVE_RETURN (system_pair_cons (type, (ARG_REF (2)), (ARG_REF (3))));
  309.   }
  310. }
  311.  
  312. DEFINE_PRIMITIVE ("SYSTEM-PAIR-CAR", Prim_sys_pair_car, 1, 1, 0)
  313. {
  314.   PRIMITIVE_HEADER (1);
  315.   CHECK_ARG (1, GC_PAIR_P);
  316.   PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1)));
  317. }
  318.  
  319. DEFINE_PRIMITIVE ("SYSTEM-PAIR-CDR", Prim_sys_pair_cdr, 1, 1, 0)
  320. {
  321.   PRIMITIVE_HEADER (1);
  322.   CHECK_ARG (1, GC_PAIR_P);
  323.   PRIMITIVE_RETURN (PAIR_CDR (ARG_REF (1)));
  324. }
  325.  
  326. DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CAR!", Prim_sys_set_car, 2, 2, 0)
  327. {
  328.   PRIMITIVE_HEADER (2);
  329.   CHECK_ARG (1, GC_PAIR_P);
  330.   {
  331.     fast SCHEME_OBJECT pair = (ARG_REF (1));
  332.     fast SCHEME_OBJECT car = (ARG_REF (2));
  333.     SIDE_EFFECT_IMPURIFY (pair, car);
  334.     SET_PAIR_CAR (pair, car);
  335.   }
  336.   PRIMITIVE_RETURN (UNSPECIFIC);
  337. }
  338.  
  339. DEFINE_PRIMITIVE ("SYSTEM-PAIR-SET-CDR!", Prim_sys_set_cdr, 2, 2, 0)
  340. {
  341.   PRIMITIVE_HEADER (2);
  342.   CHECK_ARG (1, GC_PAIR_P);
  343.   {
  344.     fast SCHEME_OBJECT pair = (ARG_REF (1));
  345.     fast SCHEME_OBJECT cdr = (ARG_REF (2));
  346.     SIDE_EFFECT_IMPURIFY (pair, cdr);
  347.     SET_PAIR_CDR (pair, cdr);
  348.   }
  349.   PRIMITIVE_RETURN (UNSPECIFIC);
  350. }
  351.