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 / hunk.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  4KB  |  127 lines
  1. /* -*-C-*-
  2.  
  3. $Id: hunk.c,v 9.29 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. /* Support for Hunk3s (triples) */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27. SCHEME_OBJECT
  28. DEFUN (hunk3_cons,
  29.        (cxr0, cxr1, cxr2),
  30.        SCHEME_OBJECT cxr0
  31.        AND SCHEME_OBJECT cxr1
  32.        AND SCHEME_OBJECT cxr2)
  33. {
  34.   Primitive_GC_If_Needed (3);
  35.   (*Free++) = cxr0;
  36.   (*Free++) = cxr1;
  37.   (*Free++) = cxr2;
  38.   return (MAKE_POINTER_OBJECT (TC_HUNK3, (Free - 3)));
  39. }
  40.  
  41. DEFINE_PRIMITIVE ("HUNK3-CONS", Prim_hunk3_cons, 3, 3, 0)
  42. {
  43.   PRIMITIVE_HEADER (3);
  44.   PRIMITIVE_RETURN (hunk3_cons ((ARG_REF (1)), (ARG_REF (2)), (ARG_REF (3))));
  45. }
  46.  
  47. DEFINE_PRIMITIVE ("HUNK3-CXR", Prim_hunk3_cxr, 2, 2, 0)
  48. {
  49.   PRIMITIVE_HEADER (2);
  50.   CHECK_ARG (1, HUNK3_P);
  51.   PRIMITIVE_RETURN (MEMORY_REF ((ARG_REF (1)), (arg_index_integer (2, 3))));
  52. }
  53.  
  54. DEFINE_PRIMITIVE ("HUNK3-SET-CXR!", Prim_hunk3_set_cxr, 3, 3, 0)
  55. {
  56.   PRIMITIVE_HEADER (3);
  57.   CHECK_ARG (1, HUNK3_P);
  58.   {
  59.     fast SCHEME_OBJECT hunk3 = (ARG_REF (1));
  60.     fast long index = (arg_index_integer (2, 3));
  61.     fast SCHEME_OBJECT object = (ARG_REF (3));
  62.     SIDE_EFFECT_IMPURIFY (hunk3, object);
  63.     MEMORY_SET (hunk3, index, object);
  64.   }
  65.   PRIMITIVE_RETURN (UNSPECIFIC);
  66. }
  67.  
  68. #define ARG_GC_TRIPLE(arg_number)                    \
  69.   (((GC_Type (ARG_REF (arg_number))) == GC_Triple)            \
  70.    ? (ARG_REF (arg_number))                        \
  71.    : ((error_wrong_type_arg (arg_number)), ((SCHEME_OBJECT) 0)))
  72.  
  73. DEFINE_PRIMITIVE ("SYSTEM-HUNK3-CXR0", Prim_sys_h3_0, 1, 1, 0)
  74. {
  75.   PRIMITIVE_HEADER (1);
  76.   PRIMITIVE_RETURN (MEMORY_REF ((ARG_GC_TRIPLE (1)), 0));
  77. }
  78.  
  79. DEFINE_PRIMITIVE ("SYSTEM-HUNK3-CXR1", Prim_sys_h3_1, 1, 1, 0)
  80. {
  81.   PRIMITIVE_HEADER (1);
  82.   PRIMITIVE_RETURN (MEMORY_REF ((ARG_GC_TRIPLE (1)), 1));
  83. }
  84.  
  85. DEFINE_PRIMITIVE ("SYSTEM-HUNK3-CXR2", Prim_sys_h3_2, 1, 1, 0)
  86. {
  87.   PRIMITIVE_HEADER (1);
  88.   PRIMITIVE_RETURN (MEMORY_REF ((ARG_GC_TRIPLE (1)), 2));
  89. }
  90.  
  91. DEFINE_PRIMITIVE ("SYSTEM-HUNK3-SET-CXR0!", Prim_sh3_set_0, 2, 2, 0)
  92. {
  93.   PRIMITIVE_HEADER (2);
  94.   {
  95.     SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
  96.     SCHEME_OBJECT object = (ARG_REF (2));
  97.     SIDE_EFFECT_IMPURIFY (hunk3, object);
  98.     MEMORY_SET (hunk3, 0, object);
  99.   }
  100.   PRIMITIVE_RETURN (UNSPECIFIC);
  101. }
  102.  
  103. DEFINE_PRIMITIVE ("SYSTEM-HUNK3-SET-CXR1!", Prim_sh3_set_1, 2, 2, 0)
  104. {
  105.   PRIMITIVE_HEADER (2);
  106.   {
  107.     SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
  108.     SCHEME_OBJECT object = (ARG_REF (2));
  109.     SIDE_EFFECT_IMPURIFY (hunk3, object);
  110.     MEMORY_SET (hunk3, 1, object);
  111.   }
  112.   PRIMITIVE_RETURN (UNSPECIFIC);
  113. }
  114.  
  115. DEFINE_PRIMITIVE ("SYSTEM-HUNK3-SET-CXR2!", Prim_sh3_set_2, 2, 2, 0)
  116. {
  117.   PRIMITIVE_HEADER (2);
  118.   {
  119.     SCHEME_OBJECT hunk3 = (ARG_GC_TRIPLE (1));
  120.     SCHEME_OBJECT object = (ARG_REF (2));
  121.     SIDE_EFFECT_IMPURIFY (hunk3, object);
  122.     MEMORY_SET (hunk3, 2, object);
  123.   }
  124.   PRIMITIVE_RETURN (UNSPECIFIC);
  125. }
  126.  
  127.