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 / generic.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  4KB  |  126 lines
  1. /* -*-C-*-
  2.  
  3. $Id: generic.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. #include "scheme.h"
  23. #include "prims.h"
  24.  
  25. #define INDIRECT(slot, arity)                        \
  26. {                                    \
  27.   PRIMITIVE_CANONICALIZE_CONTEXT ();                    \
  28.  Will_Push (STACK_ENV_EXTRA_SLOTS + 1);                    \
  29.   STACK_PUSH (Get_Fixed_Obj_Slot (slot));                \
  30.   STACK_PUSH (STACK_FRAME_HEADER + arity);                \
  31.  Pushed ();                                \
  32.   PRIMITIVE_ABORT (PRIM_APPLY);                        \
  33.   /*NOTREACHED*/                            \
  34.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  35. }
  36.  
  37. #define INDIRECT_TEST_1(test, slot)                    \
  38. {                                    \
  39.   PRIMITIVE_HEADER (1);                            \
  40.   {                                    \
  41.     fast SCHEME_OBJECT x = (ARG_REF (1));                \
  42.     if (FIXNUM_P (x))                            \
  43.       return (BOOLEAN_TO_OBJECT (test (x)));                \
  44.   }                                    \
  45.   INDIRECT (slot, 1);                            \
  46. }
  47.  
  48. DEFINE_PRIMITIVE ("ZERO?", Prim_zero, 1, 1, 0)
  49.      INDIRECT_TEST_1 (FIXNUM_ZERO_P, GENERIC_TRAMPOLINE_ZERO_P)
  50. DEFINE_PRIMITIVE ("POSITIVE?", Prim_positive, 1, 1, 0)
  51.      INDIRECT_TEST_1 (FIXNUM_POSITIVE_P, GENERIC_TRAMPOLINE_POSITIVE_P)
  52. DEFINE_PRIMITIVE ("NEGATIVE?", Prim_negative, 1, 1, 0)
  53.      INDIRECT_TEST_1 (FIXNUM_NEGATIVE_P, GENERIC_TRAMPOLINE_NEGATIVE_P)
  54.  
  55. #define INDIRECT_INCREMENT(op, slot)                    \
  56. {                                    \
  57.   PRIMITIVE_HEADER (1);                            \
  58.   {                                    \
  59.     fast SCHEME_OBJECT x = (ARG_REF (1));                \
  60.     if (FIXNUM_P (x))                            \
  61.       return (long_to_integer ((FIXNUM_TO_LONG (x)) op 1));        \
  62.   }                                    \
  63.   INDIRECT (slot, 1);                            \
  64. }
  65.  
  66. DEFINE_PRIMITIVE ("1+", Prim_add_one, 1, 1, 0)
  67.      INDIRECT_INCREMENT (+, GENERIC_TRAMPOLINE_SUCCESSOR)
  68. DEFINE_PRIMITIVE ("-1+", Prim_subtract_one, 1, 1, 0)
  69.      INDIRECT_INCREMENT (-, GENERIC_TRAMPOLINE_PREDECESSOR)
  70.  
  71. #define INDIRECT_TEST_2(test, slot)                    \
  72. {                                    \
  73.   PRIMITIVE_HEADER (2);                            \
  74.   {                                    \
  75.     fast SCHEME_OBJECT x = (ARG_REF (1));                \
  76.     fast SCHEME_OBJECT y = (ARG_REF (2));                \
  77.     if ((FIXNUM_P (x)) && (FIXNUM_P (y)))                \
  78.       return (BOOLEAN_TO_OBJECT (test (x, y)));                \
  79.   }                                    \
  80.   INDIRECT (slot, 2);                            \
  81. }
  82.  
  83. #define FIXNUM_GREATER_P(x, y) FIXNUM_LESS_P (y, x)
  84.  
  85. DEFINE_PRIMITIVE ("&=", Prim_equal_number, 2, 2, 0)
  86.      INDIRECT_TEST_2 (FIXNUM_EQUAL_P, GENERIC_TRAMPOLINE_EQUAL_P)
  87. DEFINE_PRIMITIVE ("&<", Prim_less, 2, 2, 0)
  88.      INDIRECT_TEST_2 (FIXNUM_LESS_P, GENERIC_TRAMPOLINE_LESS_P)
  89. DEFINE_PRIMITIVE ("&>", Prim_greater, 2, 2, 0)
  90.      INDIRECT_TEST_2 (FIXNUM_GREATER_P, GENERIC_TRAMPOLINE_GREATER_P)
  91.  
  92. #define INDIRECT_SUM(op, slot)                        \
  93. {                                    \
  94.   PRIMITIVE_HEADER (2);                            \
  95.   {                                    \
  96.     fast SCHEME_OBJECT x = (ARG_REF (1));                \
  97.     fast SCHEME_OBJECT y = (ARG_REF (2));                \
  98.     if ((FIXNUM_P (x)) && (FIXNUM_P (y)))                \
  99.       return (long_to_integer ((FIXNUM_TO_LONG (x)) op            \
  100.                    (FIXNUM_TO_LONG (y))));            \
  101.   }                                    \
  102.   INDIRECT (slot, 2);                            \
  103. }
  104.  
  105. DEFINE_PRIMITIVE ("&+", Prim_add, 2, 2, 0)
  106.      INDIRECT_SUM (+, GENERIC_TRAMPOLINE_ADD)
  107. DEFINE_PRIMITIVE ("&-", Prim_subtract, 2, 2, 0)
  108.      INDIRECT_SUM (-, GENERIC_TRAMPOLINE_SUBTRACT)
  109.  
  110. #define INDIRECT_2(slot)                        \
  111. {                                    \
  112.   PRIMITIVE_HEADER (2);                            \
  113.   INDIRECT (slot, 2);                            \
  114. }
  115.  
  116. DEFINE_PRIMITIVE ("&*", Prim_multiply, 2, 2, 0)
  117.      INDIRECT_2 (GENERIC_TRAMPOLINE_MULTIPLY)
  118. DEFINE_PRIMITIVE ("&/", Prim_divide, 2, 2, 0)
  119.      INDIRECT_2 (GENERIC_TRAMPOLINE_DIVIDE)
  120. DEFINE_PRIMITIVE ("QUOTIENT", Prim_quotient, 2, 2, 0)
  121.      INDIRECT_2 (GENERIC_TRAMPOLINE_QUOTIENT)
  122. DEFINE_PRIMITIVE ("REMAINDER", Prim_remainder, 2, 2, 0)
  123.      INDIRECT_2 (GENERIC_TRAMPOLINE_REMAINDER)
  124. DEFINE_PRIMITIVE ("MODULO", Prim_modulo, 2, 2, 0)
  125.      INDIRECT_2 (GENERIC_TRAMPOLINE_MODULO)
  126.