1 /* -*-C-*- 2 3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8 This file is part of MIT/GNU Scheme. 9 10 MIT/GNU Scheme is free software; you can redistribute it and/or modify 11 it under the terms of the GNU General Public License as published by 12 the Free Software Foundation; either version 2 of the License, or (at 13 your option) any later version. 14 15 MIT/GNU Scheme is distributed in the hope that it will be useful, but 16 WITHOUT ANY WARRANTY; without even the implied warranty of 17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 General Public License for more details. 19 20 You should have received a copy of the GNU General Public License 21 along with MIT/GNU Scheme; if not, write to the Free Software 22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23 USA. 24 25 */ 26 27 /* This file contains some macros for defining primitives, 28 for argument type or value checking, and for accessing 29 the arguments. */ 30 31 #ifndef SCM_PRIMS_H 32 #define SCM_PRIMS_H 33 34 #include "scheme.h" 35 36 /* Definition of primitives. */ 37 38 #define DEFINE_PRIMITIVE(scheme_name, fn_name, min_args, max_args, doc) \ 39 SCHEME_OBJECT fn_name (void) 40 41 /* Can be used for `max_args' in `DEFINE_PRIMITIVE' to indicate that 42 the primitive has no upper limit on its arity. */ 43 #define LEXPR (-1) 44 45 /* Primitives should have this as their first statement. */ 46 #ifdef ENABLE_PRIMITIVE_PROFILING 47 extern void record_primitive_entry (SCHEME_OBJECT); 48 # define PRIMITIVE_HEADER(n_args) record_primitive_entry (GET_EXP) 49 #else 50 # define PRIMITIVE_HEADER(n_args) do {} while (0) 51 #endif 52 53 /* Primitives return by performing one of the following operations. */ 54 #define PRIMITIVE_RETURN(value) return (value) 55 #define PRIMITIVE_ABORT abort_to_interpreter 56 57 /* Various utilities */ 58 59 #define Primitive_GC(Amount) do \ 60 { \ 61 if (Free_primitive < heap_start) \ 62 { \ 63 outf_fatal \ 64 ("\nMicrocode requested primitive GC outside primitive!\n"); \ 65 Microcode_Termination (TERM_EXIT); \ 66 } \ 67 if (Free < Free_primitive) \ 68 { \ 69 outf_fatal ("\nFree has gone backwards!\n"); \ 70 Microcode_Termination (TERM_EXIT); \ 71 } \ 72 REQUEST_GC ((Amount) + (Free - Free_primitive)); \ 73 signal_interrupt_from_primitive (); \ 74 } while (0) 75 76 #define Primitive_GC_If_Needed(Amount) do \ 77 { \ 78 if (GC_NEEDED_P (Amount)) Primitive_GC (Amount); \ 79 } while (0) 80 81 #define CHECK_ARG(argument, type_p) do \ 82 { \ 83 if (! (type_p (ARG_REF (argument)))) \ 84 error_wrong_type_arg (argument); \ 85 } while (0) 86 87 #define ARG_LOC(argument) (STACK_LOC (argument - 1)) 88 #define ARG_REF(argument) (STACK_REF (argument - 1)) 89 90 extern void signal_error_from_primitive (long) NORETURN; 91 extern void signal_interrupt_from_primitive (void) NORETURN; 92 extern void error_wrong_type_arg (int) NORETURN; 93 extern void error_bad_range_arg (int) NORETURN; 94 extern void error_external_return (void) NORETURN; 95 extern void error_with_argument (SCHEME_OBJECT) NORETURN; 96 extern long arg_integer (int); 97 extern intmax_t arg_integer_to_intmax (int); 98 extern long arg_nonnegative_integer (int); 99 extern long arg_index_integer (int, long); 100 extern intmax_t arg_index_integer_to_intmax (int, intmax_t); 101 extern long arg_integer_in_range (int, long, long); 102 extern unsigned long arg_ulong_integer (int); 103 extern unsigned long arg_ulong_index_integer (int, unsigned long); 104 extern unsigned long arg_ulong_integer_in_range 105 (int, unsigned long, unsigned long); 106 extern double arg_real_number (int); 107 extern double arg_real_in_range (int, double, double); 108 extern long arg_ascii_char (int); 109 extern long arg_ascii_integer (int); 110 111 #define UNSIGNED_FIXNUM_ARG(arg) \ 112 ((FIXNUM_P (ARG_REF (arg))) \ 113 ? (UNSIGNED_FIXNUM_TO_LONG (ARG_REF (arg))) \ 114 : ((error_wrong_type_arg (arg)), 0)) 115 116 #define STRING_ARG(arg) \ 117 ((STRING_P (ARG_REF (arg))) \ 118 ? (STRING_POINTER (ARG_REF (arg))) \ 119 : ((error_wrong_type_arg (arg)), ((char *) 0))) 120 121 extern unsigned char * arg_extended_string (unsigned int, unsigned long *); 122 123 #define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != SHARP_F) 124 125 #define CELL_ARG(arg) \ 126 ((CELL_P (ARG_REF (arg))) \ 127 ? (ARG_REF (arg)) \ 128 : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0))) 129 130 #define PAIR_ARG(arg) \ 131 ((PAIR_P (ARG_REF (arg))) \ 132 ? (ARG_REF (arg)) \ 133 : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0))) 134 135 #define WEAK_PAIR_ARG(arg) \ 136 ((WEAK_PAIR_P (ARG_REF (arg))) \ 137 ? (ARG_REF (arg)) \ 138 : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0))) 139 140 #define VECTOR_ARG(arg) \ 141 ((VECTOR_P (ARG_REF (arg))) \ 142 ? (ARG_REF (arg)) \ 143 : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0))) 144 145 #define FLOATING_VECTOR_ARG(arg) \ 146 ((FLONUM_P (ARG_REF (arg))) \ 147 ? (ARG_REF (arg)) \ 148 : ((error_wrong_type_arg (arg)), ((SCHEME_OBJECT) 0))) 149 150 #endif /* SCM_PRIMS_H */ 151