1 /* 2 Ypsilon Scheme System 3 Copyright (c) 2004-2008 Y.FUJITA / LittleWing Company Limited. 4 See license.txt for terms and conditions of use 5 */ 6 7 #ifndef SUBR_H_INCLUDED 8 #define SUBR_H_INCLUDED 9 10 #include "core.h" 11 #include "object.h" 12 #include "arith.h" 13 14 void init_subr_ffi(object_heap_t* heap); 15 void init_subr_base_arith(object_heap_t* heap); 16 void init_subr_r5rs_arith(object_heap_t* heap); 17 void init_subr_base(object_heap_t* heap); 18 void init_subr_bvector(object_heap_t* heap); 19 void init_subr_port(object_heap_t* heap); 20 void init_subr_socket(object_heap_t* heap); 21 void init_subr_bitwise(object_heap_t* heap); 22 void init_subr_fixnum(object_heap_t* heap); 23 void init_subr_flonum(object_heap_t* heap); 24 void init_subr_unicode(object_heap_t* heap); 25 void init_subr_hash(object_heap_t* heap); 26 void init_subr_list(object_heap_t* heap); 27 void init_subr_others(object_heap_t* heap); 28 29 #define CHECK_OPENED_INPUT_PORT(pos, subr) \ 30 do { \ 31 assert(PORTP(argv[pos])); \ 32 scm_port_t port = (scm_port_t)argv[pos]; \ 33 if (port_open_pred(port)) { \ 34 if (port_input_pred(port)) break; \ 35 wrong_type_argument_violation(vm, subr, pos, "input port", port, argc, argv); \ 36 return scm_undef; \ 37 } \ 38 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 39 return scm_undef; \ 40 } while (false) 41 42 #define CHECK_OPENED_OUTPUT_PORT(pos, subr) \ 43 do { \ 44 assert(PORTP(argv[pos])); \ 45 scm_port_t port = (scm_port_t)argv[pos]; \ 46 if (port_open_pred(port)) { \ 47 if (port_output_pred(port)) break; \ 48 wrong_type_argument_violation(vm, subr, pos, "output port", port, argc, argv); \ 49 return scm_undef; \ 50 } \ 51 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 52 return scm_undef; \ 53 } while (false) 54 55 #define CHECK_OPENED_TEXTUAL_INPUT_PORT(pos, subr) \ 56 do { \ 57 assert(PORTP(argv[pos])); \ 58 scm_port_t port = (scm_port_t)argv[pos]; \ 59 if (port_open_pred(port)) { \ 60 if (port_input_pred(port)) { \ 61 if (port_textual_pred(port)) break; \ 62 wrong_type_argument_violation(vm, subr, pos, "textual port", port, argc, argv); \ 63 return scm_undef; \ 64 } \ 65 wrong_type_argument_violation(vm, subr, pos, "input port", port, argc, argv); \ 66 return scm_undef; \ 67 } \ 68 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 69 return scm_undef; \ 70 } while (false) 71 72 #define CHECK_OPENED_TEXTUAL_OUTPUT_PORT(pos, subr) \ 73 do { \ 74 assert(PORTP(argv[pos])); \ 75 scm_port_t port = (scm_port_t)argv[pos]; \ 76 if (port_open_pred(port)) { \ 77 if (port_output_pred(port)) { \ 78 if (port_textual_pred(port)) break; \ 79 wrong_type_argument_violation(vm, subr, pos, "textual port", port, argc, argv); \ 80 return scm_undef; \ 81 } \ 82 wrong_type_argument_violation(vm, subr, pos, "output port", port, argc, argv); \ 83 return scm_undef; \ 84 } \ 85 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 86 return scm_undef; \ 87 } while (false) 88 89 #define CHECK_OPENED_BINARY_INPUT_PORT(pos, subr) \ 90 do { \ 91 assert(PORTP(argv[pos])); \ 92 scm_port_t port = (scm_port_t)argv[pos]; \ 93 if (port_open_pred(port)) { \ 94 if (port_input_pred(port)) { \ 95 if (port_binary_pred(port)) break; \ 96 wrong_type_argument_violation(vm, subr, pos, "binary port", port, argc, argv); \ 97 return scm_undef; \ 98 } \ 99 wrong_type_argument_violation(vm, subr, pos, "input port", port, argc, argv); \ 100 return scm_undef; \ 101 } \ 102 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 103 return scm_undef; \ 104 } while (false) 105 106 #define CHECK_OPENED_BINARY_OUTPUT_PORT(pos, subr) \ 107 do { \ 108 assert(PORTP(argv[pos])); \ 109 scm_port_t port = (scm_port_t)argv[pos]; \ 110 if (port_open_pred(port)) { \ 111 if (port_output_pred(port)) { \ 112 if (port_binary_pred(port)) break; \ 113 wrong_type_argument_violation(vm, subr, pos, "binary port", port, argc, argv); \ 114 return scm_undef; \ 115 } \ 116 wrong_type_argument_violation(vm, subr, pos, "output port", port, argc, argv); \ 117 return scm_undef; \ 118 } \ 119 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 120 return scm_undef; \ 121 } while (false) 122 123 #define CHECK_OPENED_PORT(pos, subr) \ 124 do { \ 125 assert(PORTP(argv[pos])); \ 126 scm_port_t port = (scm_port_t)argv[pos]; \ 127 if (port_open_pred(port)) break; \ 128 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 129 return scm_undef; \ 130 } while (false) 131 132 #define CHECK_OPENED_BINARY_PORT(pos, subr) \ 133 do { \ 134 assert(PORTP(argv[pos])); \ 135 scm_port_t port = (scm_port_t)argv[pos]; \ 136 if (port_open_pred(port)) { \ 137 if (port_binary_pred(port)) break; \ 138 wrong_type_argument_violation(vm, subr, pos, "binary port", port, argc, argv); \ 139 return scm_undef; \ 140 } \ 141 wrong_type_argument_violation(vm, subr, pos, "opened port", port, argc, argv); \ 142 return scm_undef; \ 143 } while (false) 144 145 #define CHECK_OUTPUT_PORT(pos, subr) \ 146 do { \ 147 assert(PORTP(argv[pos])); \ 148 scm_port_t port = (scm_port_t)argv[pos]; \ 149 if (port_output_pred(port)) break; \ 150 wrong_type_argument_violation(vm, subr, pos, "output port", port, argc, argv); \ 151 return scm_undef; \ 152 } while (false) 153 154 #define CHECK_NON_NEGATIVE_FIXNUM(pos, subr) \ 155 do { \ 156 scm_obj_t obj = argv[pos]; \ 157 if (FIXNUMP(obj) && FIXNUM(obj) >= 0) break; \ 158 if (exact_non_negative_integer_pred(obj)) { \ 159 invalid_argument_violation(vm, subr, "value out of bounds,", obj, pos, argc, argv); \ 160 return scm_undef; \ 161 } \ 162 wrong_type_argument_violation(vm, subr, pos, "exact non-negative integer", obj, argc, argv);\ 163 return scm_undef; \ 164 } while (false) 165 166 #define CHECK_OCTET(pos, subr) \ 167 do { \ 168 scm_obj_t obj = argv[pos]; \ 169 if (FIXNUMP(obj) && (FIXNUM(obj) >= 0) && (FIXNUM(obj) <= UINT8_MAX)) break; \ 170 wrong_type_argument_violation(vm, subr, pos, "octet", obj, argc, argv); \ 171 return scm_undef; \ 172 } while (false) 173 174 #define CONVERT_TO_MACHINE_INT(pos, subr, var) \ 175 do { \ 176 scm_obj_t obj = argv[pos]; \ 177 if (exact_integer_pred(obj)) { \ 178 if (exact_integer_to_int(obj, var) == false) { \ 179 invalid_argument_violation(vm, subr, "value out of bound,", obj, pos, argc, argv); \ 180 return scm_undef; \ 181 } \ 182 } else { \ 183 wrong_type_argument_violation(vm, subr, pos, "exact integer", obj, argc, argv); \ 184 return scm_undef; \ 185 } \ 186 } while (false) 187 188 #endif 189