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 / prims.h < prev    next >
C/C++ Source or Header  |  2001-03-08  |  5KB  |  135 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prims.h,v 9.48 2001/03/08 17:03:32 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. /* This file contains some macros for defining primitives,
  23.    for argument type or value checking, and for accessing
  24.    the arguments. */
  25.  
  26. #ifndef SCM_PRIMS_H
  27. #define SCM_PRIMS_H
  28.  
  29. #include "ansidecl.h"
  30.  
  31. /* Definition of primitives. */
  32.  
  33. #define DEFINE_PRIMITIVE(scheme_name, fn_name, min_args, max_args, doc)    \
  34. extern SCHEME_OBJECT EXFUN (fn_name, (void));                \
  35. SCHEME_OBJECT DEFUN_VOID (fn_name)
  36.  
  37. /* Can be used for `max_args' in `DEFINE_PRIMITIVE' to indicate that
  38.    the primitive has no upper limit on its arity.  */
  39. #define LEXPR (-1)
  40.  
  41. /* Primitives should have this as their first statement. */
  42. #ifdef ENABLE_PRIMITIVE_PROFILING
  43. #define PRIMITIVE_HEADER(n_args) record_primitive_entry (Fetch_Expression ())
  44. #else
  45. #define PRIMITIVE_HEADER(n_args) {}
  46. #endif
  47.  
  48. /* Primitives return by performing one of the following operations. */
  49. #define PRIMITIVE_RETURN(value)    return (value)
  50. #define PRIMITIVE_ABORT abort_to_interpreter
  51.  
  52. extern void EXFUN (canonicalize_primitive_context, (void));
  53. #define PRIMITIVE_CANONICALIZE_CONTEXT canonicalize_primitive_context
  54.  
  55. /* Various utilities */
  56.  
  57. #define Primitive_GC(Amount)                        \
  58. {                                    \
  59.   Request_GC (Amount);                            \
  60.   signal_interrupt_from_primitive ();                    \
  61. }
  62.  
  63. #define Primitive_GC_If_Needed(Amount)                    \
  64. {                                    \
  65.   if (GC_Check (Amount)) Primitive_GC (Amount);                \
  66. }
  67.  
  68. #define CHECK_ARG(argument, type_p) do                    \
  69. {                                    \
  70.   if (! (type_p (ARG_REF (argument))))                    \
  71.     error_wrong_type_arg (argument);                    \
  72. } while (0)
  73.  
  74. #define ARG_LOC(argument) (STACK_LOC (argument - 1))
  75. #define ARG_REF(argument) (STACK_REF (argument - 1))
  76. #define LEXPR_N_ARGUMENTS() (Regs [REGBLOCK_LEXPR_ACTUALS])
  77.  
  78. extern void EXFUN (signal_error_from_primitive, (long error_code));
  79. extern void EXFUN (signal_interrupt_from_primitive, (void));
  80. extern void EXFUN (error_wrong_type_arg, (int));
  81. extern void EXFUN (error_bad_range_arg, (int));
  82. extern void EXFUN (error_external_return, (void));
  83. extern void EXFUN (error_with_argument, (SCHEME_OBJECT));
  84. extern long EXFUN (arg_integer, (int));
  85. extern long EXFUN (arg_nonnegative_integer, (int));
  86. extern long EXFUN (arg_index_integer, (int, long));
  87. extern long EXFUN (arg_integer_in_range, (int, long, long));
  88. extern unsigned long EXFUN (arg_ulong_integer, (int));
  89. extern unsigned long EXFUN (arg_ulong_index_integer, (int, unsigned long));
  90. extern double EXFUN (arg_real_number, (int));
  91. extern double EXFUN (arg_real_in_range, (int, double, double));
  92. extern long EXFUN (arg_ascii_char, (int));
  93. extern long EXFUN (arg_ascii_integer, (int));
  94.  
  95. #define UNSIGNED_FIXNUM_ARG(arg)                    \
  96.   ((FIXNUM_P (ARG_REF (arg)))                        \
  97.    ? (UNSIGNED_FIXNUM_TO_LONG (ARG_REF (arg)))                \
  98.    : ((error_wrong_type_arg (arg)), 0))
  99.  
  100. #define STRING_ARG(arg)                            \
  101.   ((STRING_P (ARG_REF (arg)))                        \
  102.    ? ((char *) (STRING_LOC ((ARG_REF (arg)), 0)))            \
  103.    : ((error_wrong_type_arg (arg)), ((char *) 0)))
  104.  
  105. extern PTR EXFUN (arg_extended_string, (unsigned int, unsigned long *));
  106.  
  107. #define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != SHARP_F)
  108.  
  109. #define CELL_ARG(arg)                            \
  110.   ((CELL_P (ARG_REF (arg)))                        \
  111.    ? (ARG_REF (arg))                            \
  112.    : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
  113.  
  114. #define PAIR_ARG(arg)                            \
  115.   ((PAIR_P (ARG_REF (arg)))                        \
  116.    ? (ARG_REF (arg))                            \
  117.    : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
  118.  
  119. #define WEAK_PAIR_ARG(arg)                        \
  120.   ((WEAK_PAIR_P (ARG_REF (arg)))                    \
  121.    ? (ARG_REF (arg))                            \
  122.    : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
  123.  
  124. #define VECTOR_ARG(arg)                            \
  125.   ((VECTOR_P (ARG_REF (arg)))                        \
  126.    ? (ARG_REF (arg))                            \
  127.    : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
  128.  
  129. #define FLOATING_VECTOR_ARG(arg)                    \
  130.   ((FLONUM_P (ARG_REF (arg)))                        \
  131.    ? (ARG_REF (arg))                            \
  132.    : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0)))
  133.  
  134. #endif /* SCM_PRIMS_H */
  135.