1 /* s7 ffi tester
2 *
3 * gcc -o ffitest ffitest.c -g3 -Wall s7.o -lm -I. -ldl -Wl,-export-dynamic
4 * gcc -o ffitest ffitest.c -g3 -Wall s7.o -DWITH_GMP -lgmp -lmpfr -lmpc -lm -I. -ldl -Wl,-export-dynamic
5 */
6
7 #include <stdlib.h>
8 #include <stdio.h>
9 #include <string.h>
10 #include <stdarg.h>
11 #include <inttypes.h>
12
13 #if WITH_GMP
14 #include <gmp.h>
15 #include <mpfr.h>
16 #include <mpc.h>
17 #endif
18
19 #include "s7.h"
20
21 #define print_s7_int PRId64
22
23 #define TO_STR(x) s7_object_to_c_string(sc, x)
24 #define TO_S7_INT(x) s7_make_integer(sc, x)
25
a_function(s7_scheme * sc,s7_pointer args)26 static s7_pointer a_function(s7_scheme *sc, s7_pointer args)
27 {
28 return(s7_car(args));
29 }
30
test_hook_function(s7_scheme * sc,s7_pointer args)31 static s7_pointer test_hook_function(s7_scheme *sc, s7_pointer args)
32 {
33 s7_pointer val;
34 val = s7_symbol_local_value(sc, s7_make_symbol(sc, "a"), s7_car(args));
35 if ((!s7_is_integer(val)) ||
36 (s7_integer(val) != 1))
37 {
38 char *s1;
39 s1 = TO_STR(val);
40 fprintf(stderr, "%d: (hook 'a) is %s\n", __LINE__, s1);
41 free(s1);
42 }
43 return(val);
44 }
45
46 static char last_c;
my_print(s7_scheme * sc,unsigned char c,s7_pointer port)47 static void my_print(s7_scheme *sc, unsigned char c, s7_pointer port)
48 {
49 last_c = c;
50 }
51
my_read(s7_scheme * sc,s7_read_t peek,s7_pointer port)52 static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port)
53 {
54 return(s7_make_character(sc, '0'));
55 }
56
57
58 static bool tested_begin_hook = false;
test_begin_hook(s7_scheme * sc,bool * val)59 static void test_begin_hook(s7_scheme *sc, bool *val)
60 {
61 tested_begin_hook = true;
62 }
63
test_error_handler(s7_scheme * sc,s7_pointer args)64 static s7_pointer test_error_handler(s7_scheme *sc, s7_pointer args)
65 {
66 s7_display(sc, s7_make_symbol(sc, "error!"), s7_current_error_port(sc));
67 return(s7_f(sc));
68 }
69
70 static s7_pointer set_sym, set_val;
scheme_set_notification(s7_scheme * sc,s7_pointer args)71 static s7_pointer scheme_set_notification(s7_scheme *sc, s7_pointer args)
72 {
73 set_sym = s7_car(args);
74 set_val = s7_cadr(args);
75 return(set_val);
76 }
77
78
79 typedef struct {
80 s7_double x;
81 s7_pointer data;
82 } dax;
83
84 static s7_int dax_type_tag = 0;
85
dax_to_string(s7_scheme * sc,s7_pointer args)86 static s7_pointer dax_to_string(s7_scheme *sc, s7_pointer args)
87 {
88 char *data_str, *str;
89 s7_pointer result;
90 int data_str_len;
91 dax *o = (dax *)s7_c_object_value(s7_car(args));
92 data_str = s7_object_to_c_string(sc, o->data);
93 data_str_len = strlen(data_str);
94 str = (char *)calloc(data_str_len + 32, sizeof(char));
95 snprintf(str, data_str_len + 32, "#<dax %.3f %s>", o->x, data_str);
96 free(data_str);
97 result = s7_make_string(sc, str);
98 free(str);
99 return(result);
100 }
101
free_dax(void * val)102 static void free_dax(void *val)
103 {
104 if (val) free(val);
105 }
106
mark_dax(void * val)107 static void mark_dax(void *val)
108 {
109 dax *o = (dax *)val;
110 if (o) s7_mark(o->data);
111 }
112
make_dax(s7_scheme * sc,s7_pointer args)113 static s7_pointer make_dax(s7_scheme *sc, s7_pointer args)
114 {
115 dax *o;
116 o = (dax *)malloc(sizeof(dax));
117 o->x = s7_real(s7_car(args));
118 if (s7_cdr(args) != s7_nil(sc))
119 o->data = s7_car(s7_cdr(args));
120 else o->data = s7_nil(sc);
121 return(s7_make_c_object(sc, dax_type_tag, (void *)o));
122 }
123
is_dax(s7_scheme * sc,s7_pointer args)124 static s7_pointer is_dax(s7_scheme *sc, s7_pointer args)
125 {
126 return(s7_make_boolean(sc,
127 s7_is_c_object(s7_car(args)) &&
128 s7_c_object_type(s7_car(args)) == dax_type_tag));
129 }
130
dax_x(s7_scheme * sc,s7_pointer args)131 static s7_pointer dax_x(s7_scheme *sc, s7_pointer args)
132 {
133 dax *o;
134 o = (dax *)s7_c_object_value(s7_car(args));
135 return(s7_make_real(sc, o->x));
136 }
137
set_dax_x(s7_scheme * sc,s7_pointer args)138 static s7_pointer set_dax_x(s7_scheme *sc, s7_pointer args)
139 {
140 dax *o;
141 o = (dax *)s7_c_object_value(s7_car(args));
142 o->x = s7_real(s7_car(s7_cdr(args)));
143 return(s7_car(s7_cdr(args)));
144 }
145
dax_data(s7_scheme * sc,s7_pointer args)146 static s7_pointer dax_data(s7_scheme *sc, s7_pointer args)
147 {
148 dax *o;
149 o = (dax *)s7_c_object_value(s7_car(args));
150 return(o->data);
151 }
152
set_dax_data(s7_scheme * sc,s7_pointer args)153 static s7_pointer set_dax_data(s7_scheme *sc, s7_pointer args)
154 {
155 dax *o;
156 o = (dax *)s7_c_object_value(s7_car(args));
157 o->data = s7_car(s7_cdr(args));
158 return(o->data);
159 }
160
equal_dax(void * val1,void * val2)161 static bool equal_dax(void *val1, void *val2) /* this is the old form of equal? */
162 {
163 dax *d1, *d2;
164 if (val1 == val2)
165 return(true);
166 d1 = (dax *)val1;
167 d2 = (dax *)val2;
168 return((d1->x == d2->x) &&
169 (d1->data == d2->data)); /* we want s7_is_equal here, but the interpreter is not passed to us */
170 }
171
equality_dax(s7_scheme * sc,s7_pointer args)172 static s7_pointer equality_dax(s7_scheme *sc, s7_pointer args) /* this is the new form of equal? */
173 {
174 s7_pointer p1, p2;
175 dax *d1, *d2;
176 p1 = s7_car(args); /* we know this is a dax object */
177 p2 = s7_cadr(args);
178 if (p1 == p2)
179 return(s7_t(sc));
180 if ((!s7_is_c_object(p2)) ||
181 (s7_c_object_type(p2) != dax_type_tag))
182 return(s7_f(sc));
183 d1 = (dax *)s7_c_object_value(p1);
184 d2 = (dax *)s7_c_object_value(p2);
185 return(s7_make_boolean(sc, /* here we can call s7_is_equal */
186 (d1->x == d2->x) &&
187 (s7_is_equal(sc, d1->data, d2->data))));
188 }
189
plus(s7_scheme * sc,s7_pointer args)190 static s7_pointer plus(s7_scheme *sc, s7_pointer args)
191 {
192 /* (define* (plus (red 32) blue) (+ (* 2 red) blue)) */
193 return(TO_S7_INT(2 * s7_integer(s7_car(args)) + s7_integer(s7_car(s7_cdr(args)))));
194 }
195
plus1(s7_scheme * sc,s7_pointer args)196 static s7_pointer plus1(s7_scheme *sc, s7_pointer args) /* check recursion in "unsafe" case */
197 {
198 s7_pointer d;
199 if (s7_integer(s7_car(args)) == 4)
200 d = s7_apply_function_star(sc, s7_name_to_value(sc, "plus1"),
201 s7_list(sc, 3,
202 s7_make_integer(sc, 1),
203 s7_make_integer(sc, 2),
204 s7_make_integer(sc, 3)));
205 else d = s7_make_integer(sc, 0);
206 return(s7_make_integer(sc, s7_integer(s7_car(args)) +
207 s7_integer(s7_cadr(args)) +
208 s7_integer(s7_caddr(args)) +
209 s7_integer(d)));
210 }
211
fs1(s7_scheme * sc,s7_pointer args)212 s7_pointer fs1(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
fs2(s7_scheme * sc,s7_pointer args)213 s7_pointer fs2(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
fs3(s7_scheme * sc,s7_pointer args)214 s7_pointer fs3(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
fs31(s7_scheme * sc,s7_pointer args)215 s7_pointer fs31(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
216
fs4(s7_scheme * sc,s7_pointer args)217 s7_pointer fs4(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
fs5(s7_scheme * sc,s7_pointer args)218 s7_pointer fs5(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
fs6(s7_scheme * sc,s7_pointer args)219 s7_pointer fs6(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
fs61(s7_scheme * sc,s7_pointer args)220 s7_pointer fs61(s7_scheme* sc, s7_pointer args) {if (s7_is_pair(args)) return(s7_car(args)); return s7_nil(sc);}
221
mac_plus(s7_scheme * sc,s7_pointer args)222 static s7_pointer mac_plus(s7_scheme *sc, s7_pointer args)
223 {
224 /* (define-macro (plus a b) `(+ ,a ,b)) */
225 s7_pointer a, b;
226 a = s7_car(args);
227 b = s7_cadr(args);
228 return(s7_list(sc, 3, s7_make_symbol(sc, "+"), a, b));
229 }
230
mac_plus_mv(s7_scheme * sc,s7_pointer args)231 static s7_pointer mac_plus_mv(s7_scheme *sc, s7_pointer args)
232 {
233 /* (define-macro (plus-mv a b) (values `(define a ,a) `(define b ,b))) */
234 return(s7_values(sc, args));
235 }
236
open_plus(s7_scheme * sc,s7_pointer args)237 static s7_pointer open_plus(s7_scheme *sc, s7_pointer args)
238 {
239 #define plus_help "(plus obj ...) applies obj's plus method to obj and any trailing arguments."
240 s7_pointer obj, method;
241 obj = s7_car(args);
242 if (s7_is_openlet(obj))
243 {
244 method = s7_method(sc, obj, s7_make_symbol(sc, "plus"));
245 if (s7_is_procedure(method))
246 return(s7_apply_function(sc, method, s7_cdr(args)));
247 }
248 return(s7_f(sc));
249 }
250
251
252 typedef struct {
253 size_t size;
254 double *data;
255 } g_block;
256
257 static s7_int g_block_type = 0;
258 static s7_pointer g_block_methods;
259
g_make_block(s7_scheme * sc,s7_pointer args)260 static s7_pointer g_make_block(s7_scheme *sc, s7_pointer args)
261 {
262 #define g_make_block_help "(make-block size) returns a new block of the given size"
263 g_block *g;
264 s7_pointer new_g;
265 g = (g_block *)calloc(1, sizeof(g_block));
266 g->size = (size_t)s7_integer(s7_car(args));
267 g->data = (double *)calloc(g->size, sizeof(double));
268 new_g = s7_make_c_object(sc, g_block_type, (void *)g);
269 s7_c_object_set_let(sc, new_g, g_block_methods);
270 s7_openlet(sc, new_g);
271 return(new_g);
272 }
273
g_to_block(s7_scheme * sc,s7_pointer args)274 static s7_pointer g_to_block(s7_scheme *sc, s7_pointer args)
275 {
276 #define g_block_help "(block ...) returns a block c_object with the arguments as its contents."
277 s7_pointer p, b;
278 size_t i, len;
279 g_block *gb;
280 len = s7_list_length(sc, args);
281 b = g_make_block(sc, s7_cons(sc, s7_make_integer(sc, len), s7_nil(sc)));
282 gb = (g_block *)s7_c_object_value(b);
283 for (i = 0, p = args; i < len; i++, p = s7_cdr(p))
284 gb->data[i] = s7_number_to_real(sc, s7_car(p));
285 return(b);
286 }
287
g_block_to_string(s7_scheme * sc,s7_pointer args)288 static s7_pointer g_block_to_string(s7_scheme *sc, s7_pointer args)
289 {
290 return(s7_make_string(sc, "<block>"));
291 }
292
g_block_free(void * value)293 static void g_block_free(void *value)
294 {
295 g_block *g = (g_block *)value;
296 free(g->data);
297 free(g);
298 }
299
g_blocks_are_eql(void * val1,void * val2)300 static bool g_blocks_are_eql(void *val1, void *val2)
301 {
302 s7_int i, len;
303 g_block *b1 = (g_block *)val1;
304 g_block *b2 = (g_block *)val2;
305 if (val1 == val2) return(true);
306 len = b1->size;
307 if (len != b2->size) return(false);
308 for (i = 0; i < len; i++)
309 if (b1->data[i] != b2->data[i])
310 return(false);
311 return(true);
312 }
313
g_blocks_are_equal(s7_scheme * sc,s7_pointer args)314 static s7_pointer g_blocks_are_equal(s7_scheme *sc, s7_pointer args)
315 {
316 return(s7_make_boolean(sc, g_blocks_are_eql((void *)s7_c_object_value(s7_car(args)), (void *)s7_c_object_value(s7_cadr(args)))));
317 }
318
g_blocks_are_equivalent(s7_scheme * sc,s7_pointer args)319 static s7_pointer g_blocks_are_equivalent(s7_scheme *sc, s7_pointer args)
320 {
321 s7_pointer v1, v2, arg1, arg2;
322 g_block *g1, *g2;
323 bool result;
324 uint32_t gc1, gc2;
325 size_t len;
326 arg1 = s7_car(args);
327 arg2 = s7_cadr(args);
328 if (!s7_is_c_object(arg2))
329 return(s7_f(sc));
330 if (arg1 == arg2)
331 return(s7_make_boolean(sc, true));
332 if (s7_is_let(arg1)) /* (block-let (block)) */
333 return(s7_make_boolean(sc, false)); /* checked == above */
334 g1 = (g_block *)s7_c_object_value(arg1);
335 if (s7_c_object_type(arg2) != g_block_type)
336 return(s7_make_boolean(sc, false));
337 g2 = (g_block *)s7_c_object_value(arg2);
338 len = g1->size;
339 if (len != g2->size)
340 return(s7_make_boolean(sc, false));
341 v1 = s7_make_float_vector_wrapper(sc, len, g1->data, 1, NULL, false);
342 gc1 = s7_gc_protect(sc, v1);
343 v2 = s7_make_float_vector_wrapper(sc, len, g2->data, 1, NULL, false);
344 gc2 = s7_gc_protect(sc, v2);
345 result = s7_is_equivalent(sc, v1, v2);
346 s7_gc_unprotect_at(sc, gc1);
347 s7_gc_unprotect_at(sc, gc2);
348 return(s7_make_boolean(sc, result));
349 }
350
g_block_mark(void * val)351 static void g_block_mark(void *val)
352 {
353 /* nothing to mark */
354 }
355
g_block_ref(s7_scheme * sc,s7_pointer args)356 static s7_pointer g_block_ref(s7_scheme *sc, s7_pointer args)
357 {
358 g_block *g;
359 size_t index;
360 g = (g_block *)s7_c_object_value(s7_car(args));
361 index = (size_t)s7_integer(s7_cadr(args));
362 if (index < g->size)
363 return(s7_make_real(sc, g->data[index]));
364 return(s7_out_of_range_error(sc, "block-ref", 2, s7_cadr(args), "should be less than block length"));
365 }
366
g_block_set(s7_scheme * sc,s7_pointer args)367 static s7_pointer g_block_set(s7_scheme *sc, s7_pointer args)
368 {
369 g_block *g;
370 s7_int index;
371 if (s7_list_length(sc, args) != 3)
372 return(s7_wrong_number_of_args_error(sc, "block-set! takes 3 arguments: ~S", args));
373 g = (g_block *)s7_c_object_value(s7_car(args));
374 index = s7_integer(s7_cadr(args));
375 if ((index >= 0) && (index < g->size))
376 {
377 g->data[index] = s7_number_to_real(sc, s7_caddr(args));
378 return(s7_caddr(args));
379 }
380 return(s7_out_of_range_error(sc, "block-set", 2, s7_cadr(args), "should be less than block length"));
381 }
382
g_block_length(s7_scheme * sc,s7_pointer args)383 static s7_pointer g_block_length(s7_scheme *sc, s7_pointer args)
384 {
385 g_block *g = (g_block *)s7_c_object_value(s7_car(args));
386 return(s7_make_integer(sc, g->size));
387 }
388
g_block_copy(s7_scheme * sc,s7_pointer args)389 static s7_pointer g_block_copy(s7_scheme *sc, s7_pointer args)
390 {
391 s7_pointer obj, new_g;
392 g_block *g, *g1;
393 obj = s7_car(args);
394 g = (g_block *)s7_c_object_value(obj);
395 new_g = g_make_block(sc, s7_cons(sc, s7_make_integer(sc, g->size), s7_nil(sc)));
396 g1 = (g_block *)s7_c_object_value(new_g);
397 memcpy((void *)(g1->data), (void *)(g->data), g->size * sizeof(double));
398 return(new_g);
399 }
400
g_block_reverse(s7_scheme * sc,s7_pointer args)401 static s7_pointer g_block_reverse(s7_scheme *sc, s7_pointer args)
402 {
403 size_t i, j;
404 s7_pointer obj, new_g;
405 g_block *g, *g1;
406 obj = s7_car(args);
407 g = (g_block *)s7_c_object_value(obj);
408 new_g = g_make_block(sc, s7_cons(sc, s7_make_integer(sc, g->size), s7_nil(sc)));
409 g1 = (g_block *)s7_c_object_value(new_g);
410 for (i = 0, j = g->size - 1; i < g->size; i++, j--)
411 g1->data[i] = g->data[j];
412 return(new_g);
413 }
414
g_block_fill(s7_scheme * sc,s7_pointer args)415 static s7_pointer g_block_fill(s7_scheme *sc, s7_pointer args)
416 {
417 s7_pointer obj;
418 size_t i;
419 double fill_val;
420 g_block *g;
421 obj = s7_car(args);
422 g = (g_block *)s7_c_object_value(obj);
423 fill_val = s7_number_to_real(sc, s7_cadr(args));
424 for (i = 0; i < g->size; i++)
425 g->data[i] = fill_val;
426 return(obj);
427 }
428
symbol_func(const char * symbol_name,void * data)429 static bool symbol_func(const char *symbol_name, void *data)
430 {
431 return(false);
432 }
433
symbol_func_1(const char * symbol_name,void * data)434 static bool symbol_func_1(const char *symbol_name, void *data)
435 {
436 return(false);
437 }
438
439 static s7_scheme *cur_sc;
ap_1(s7_pointer a1)440 static s7_pointer ap_1(s7_pointer a1)
441 {
442 return(s7_make_integer(cur_sc, s7_integer(a1)));
443 }
444
ap_2(s7_pointer a1,s7_pointer a2)445 static s7_pointer ap_2(s7_pointer a1, s7_pointer a2)
446 {
447 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2)));
448 }
449
ap_3(s7_pointer a1,s7_pointer a2,s7_pointer a3)450 static s7_pointer ap_3(s7_pointer a1, s7_pointer a2, s7_pointer a3)
451 {
452 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3)));
453 }
454
ap_4(s7_pointer a1,s7_pointer a2,s7_pointer a3,s7_pointer a4)455 static s7_pointer ap_4(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4)
456 {
457 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3) + s7_integer(a4)));
458 }
459
ap_5(s7_pointer a1,s7_pointer a2,s7_pointer a3,s7_pointer a4,s7_pointer a5)460 static s7_pointer ap_5(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5)
461 {
462 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3) + s7_integer(a4) + s7_integer(a5)));
463 }
464
ap_6(s7_pointer a1,s7_pointer a2,s7_pointer a3,s7_pointer a4,s7_pointer a5,s7_pointer a6)465 static s7_pointer ap_6(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5, s7_pointer a6)
466 {
467 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3) + s7_integer(a4) + s7_integer(a5) + s7_integer(a6)));
468 }
469
ap_7(s7_pointer a1,s7_pointer a2,s7_pointer a3,s7_pointer a4,s7_pointer a5,s7_pointer a6,s7_pointer a7)470 static s7_pointer ap_7(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5, s7_pointer a6, s7_pointer a7)
471 {
472 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3) + s7_integer(a4) + s7_integer(a5) + s7_integer(a6) + s7_integer(a7)));
473 }
474
ap_8(s7_pointer a1,s7_pointer a2,s7_pointer a3,s7_pointer a4,s7_pointer a5,s7_pointer a6,s7_pointer a7,s7_pointer a8)475 static s7_pointer ap_8(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8)
476 {
477 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3) + s7_integer(a4) + s7_integer(a5) + s7_integer(a6) + s7_integer(a7) + s7_integer(a8)));
478 }
479
ap_9(s7_pointer a1,s7_pointer a2,s7_pointer a3,s7_pointer a4,s7_pointer a5,s7_pointer a6,s7_pointer a7,s7_pointer a8,s7_pointer a9)480 static s7_pointer ap_9(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8, s7_pointer a9)
481 {
482 return(s7_make_integer(cur_sc, s7_integer(a1) + s7_integer(a2) + s7_integer(a3) + s7_integer(a4) + s7_integer(a5) + s7_integer(a6) + s7_integer(a7) + s7_integer(a8) + s7_integer(a9)));
483 }
484
int_list(s7_scheme * sc,s7_int len)485 static s7_pointer int_list(s7_scheme *sc, s7_int len)
486 {
487 s7_int i, gc_loc;
488 s7_pointer result;
489 s7_eval_c_string(sc, "(set! (*s7* 'safety) 1)");
490 result = s7_list(sc, 1, s7_nil(sc));
491 s7_eval_c_string(sc, "(set! (*s7* 'safety) 0)");
492 gc_loc = s7_gc_protect(sc, result);
493 for (i = 1; i <= len; i++)
494 s7_set_car(result, s7_cons(sc, s7_make_integer(sc, i), s7_car(result)));
495 s7_gc_unprotect_at(sc, gc_loc);
496 return(s7_reverse(sc, s7_car(result)));
497 }
498
pretty_print(s7_scheme * sc,s7_pointer obj)499 static const char *pretty_print(s7_scheme *sc, s7_pointer obj) /* (pretty-print obj) */
500 {
501 return(s7_string(
502 s7_eval_c_string_with_environment(sc,
503 "(catch #t \
504 (lambda () \
505 (unless (defined? 'pp) \
506 (load \"write.scm\")) \
507 (pp obj)) \
508 (lambda (type info) \
509 (apply format #f info)))",
510 s7_inlet(sc, s7_list(sc, 1, s7_cons(sc, s7_make_symbol(sc, "obj"), obj))))));
511 }
512
513 #if WITH_GMP
big_add_1(s7_scheme * sc,s7_pointer args)514 static s7_pointer big_add_1(s7_scheme *sc, s7_pointer args)
515 {
516 /* add 1 to either a normal number or a bignum */
517 s7_pointer x, n;
518 x = s7_car(args);
519 if (s7_is_big_integer(x))
520 {
521 mpz_t big_n;
522 mpz_init_set(big_n, *s7_big_integer(x));
523 mpz_add_ui(big_n, big_n, 1);
524 n = s7_make_big_integer(sc, &big_n);
525 mpz_clear(big_n);
526 return(n);
527 }
528 if (s7_is_big_ratio(x))
529 {
530 mpq_t big_q;
531 mpq_init(big_q);
532 mpq_set_si(big_q, 1, 1);
533 mpq_add(big_q, *s7_big_ratio(x), big_q);
534 mpq_canonicalize(big_q);
535 n = s7_make_big_ratio(sc, &big_q);
536 mpq_clear(big_q);
537 return(n);
538 }
539 if (s7_is_big_real(x))
540 {
541 mpfr_t big_x;
542 mpfr_init_set(big_x, *s7_big_real(x), MPFR_RNDN);
543 mpfr_add_ui(big_x, big_x, 1, MPFR_RNDN);
544 n = s7_make_big_real(sc, &big_x);
545 mpfr_clear(big_x);
546 return(n);
547 }
548 if (s7_is_big_complex(x))
549 {
550 mpc_t big_z;
551 mpc_init2(big_z, mpc_get_prec(*s7_big_complex(x)));
552 mpc_add_ui(big_z, *s7_big_complex(x), 1, MPC_RNDNN);
553 n = s7_make_big_complex(sc, &big_z);
554 mpc_clear(big_z);
555 return(n);
556 }
557 if (s7_is_integer(x))
558 return(s7_make_integer(sc, 1 + s7_integer(x)));
559 if (s7_is_rational(x))
560 return(s7_make_ratio(sc, s7_numerator(x) + s7_denominator(x), s7_denominator(x)));
561 if (s7_is_real(x))
562 return(s7_make_real(sc, 1.0 + s7_real(x)));
563 if (s7_is_complex(x))
564 return(s7_make_complex(sc, 1.0 + s7_real_part(x), s7_imag_part(x)));
565 return(s7_wrong_type_arg_error(sc, "add-1", 0, x, "a number"));
566 }
567 #endif
568
main(int argc,char ** argv)569 int main(int argc, char **argv)
570 {
571 s7_scheme *sc;
572 s7_pointer p, p1;
573 s7_int i, gc_loc;
574 char *s1, *s2;
575
576 sc = s7_init();
577 cur_sc = sc;
578
579 /* try each straight (no errors) case */
580
581 if (!s7_is_null(sc, s7_nil(sc)))
582 {fprintf(stderr, "%d: %s is not null?\n", __LINE__, s1 = TO_STR(s7_nil(sc))); free(s1);}
583
584 if (s7_is_pair(s7_nil(sc)))
585 {fprintf(stderr, "%d: %s is a pair?\n", __LINE__, s1 = TO_STR(s7_nil(sc))); free(s1);}
586
587 if (!s7_is_boolean(s7_t(sc)))
588 {fprintf(stderr, "%d: %s is not boolean?\n", __LINE__, s1 = TO_STR(s7_t(sc))); free(s1);}
589
590 if (!s7_is_boolean(s7_f(sc)))
591 {fprintf(stderr, "%d: %s is not boolean?\n", __LINE__, s1 = TO_STR(s7_f(sc))); free(s1);}
592
593 if (s7_boolean(sc, s7_f(sc)))
594 {fprintf(stderr, "%d: %s is #t?\n", __LINE__, s1 = TO_STR(s7_f(sc))); free(s1);}
595
596 if (!s7_boolean(sc, s7_t(sc)))
597 {fprintf(stderr, "%d: %s is #f?\n", __LINE__, s1 = TO_STR(s7_t(sc))); free(s1);}
598
599 p = s7_make_boolean(sc, true);
600 if (p != s7_t(sc))
601 {fprintf(stderr, "%d: %s is not #t?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
602
603 p = s7_make_boolean(sc, false);
604 if (p != s7_f(sc))
605 {fprintf(stderr, "%d: %s is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
606
607 if (!s7_is_eq(s7_f(sc), s7_f(sc)))
608 {fprintf(stderr, "%d: (eq? %s %s) -> #f?\n", __LINE__, s1 = TO_STR(s7_f(sc)), s2 = TO_STR(s7_f(sc))); free(s1); free(s2);}
609
610 if (!s7_is_eqv(sc, s7_f(sc), s7_f(sc)))
611 {fprintf(stderr, "%d: (eqv? %s %s) -> #f?\n", __LINE__, s1 = TO_STR(s7_f(sc)), s2 = TO_STR(s7_f(sc))); free(s1); free(s2);}
612
613 if (!s7_is_equal(sc, s7_f(sc), s7_f(sc)))
614 {fprintf(stderr, "%d: (equal? %s %s) -> #f?\n", __LINE__, s1 = TO_STR(s7_f(sc)), s2 = TO_STR(s7_f(sc))); free(s1); free(s2);}
615
616 if (!s7_is_unspecified(sc, s7_unspecified(sc)))
617 {fprintf(stderr, "%d: %s is not #<unspecified>?\n", __LINE__, s1 = TO_STR(s7_unspecified(sc))); free(s1);}
618
619 if (s7_is_eq(s7_eof_object(sc), s7_undefined(sc)))
620 {fprintf(stderr, "%d: (eq? %s %s) -> #t?\n", __LINE__, s1 = TO_STR(s7_eof_object(sc)), s2 = TO_STR(s7_undefined(sc))); free(s1); free(s2);}
621
622 if (s7_is_eqv(sc, s7_eof_object(sc), s7_undefined(sc)))
623 {fprintf(stderr, "%d: (eqv? %s %s) -> #t?\n", __LINE__, s1 = TO_STR(s7_eof_object(sc)), s2 = TO_STR(s7_undefined(sc))); free(s1); free(s2);}
624
625 if (s7_is_equal(sc, s7_eof_object(sc), s7_undefined(sc)))
626 {fprintf(stderr, "%d: (equal? %s %s) -> #t?\n", __LINE__, s1 = TO_STR(s7_eof_object(sc)), s2 = TO_STR(s7_undefined(sc))); free(s1); free(s2);}
627
628 if (!s7_is_valid(sc, s7_t(sc)))
629 {fprintf(stderr, "%d: %s is not valid?\n", __LINE__, s1 = TO_STR(s7_t(sc))); free(s1);}
630 {
631 typedef struct fake_cell {
632 union {
633 uint64_t flag;
634 uint8_t type_field;
635 } tf;
636 int64_t hloc, i1, i2, i3;
637 } fake_cell;
638 fake_cell *x;
639 x = calloc(1, sizeof(fake_cell));
640 x->tf.flag = 53 + (1 << 11);
641 if (s7_is_valid(sc, (s7_pointer)x))
642 fprintf(stderr, "fake_cell is ok?\n");
643 if (!s7_is_provided(sc, "debugging"))
644 s7_object_to_c_string(sc, (s7_pointer)x);
645 free(x);
646 }
647 if (s7_is_c_pointer(s7_t(sc)))
648 {fprintf(stderr, "%d: %s is a raw c pointer?\n", __LINE__, s1 = TO_STR(s7_t(sc))); free(s1);}
649
650 i = 32;
651 p = s7_make_c_pointer(sc, (void *)(&i));
652 if (!s7_is_c_pointer(p))
653 {fprintf(stderr, "%d: %s is not a raw c pointer?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
654
655 i = (*((int *)s7_c_pointer(p)));
656 if (i != 32)
657 fprintf(stderr, "%d: 32 -> %" print_s7_int " via raw c pointer?\n", __LINE__, i);
658
659 s7_provide(sc, "ffitest");
660 if (!s7_is_provided(sc, "ffitest"))
661 {fprintf(stderr, "%d: *features* %s doesn't provide 'ffitest?\n", __LINE__, s1 = TO_STR(s7_name_to_value(sc, "*features*"))); free(s1);}
662
663 p = s7_cons(sc, s7_f(sc), s7_t(sc));
664 gc_loc = s7_gc_protect(sc, p);
665 if (p != s7_gc_protected_at(sc, gc_loc))
666 {fprintf(stderr, "%d: %s is not gc protected at %" print_s7_int ": %s?\n", __LINE__, s1 = TO_STR(p), gc_loc, s2 = TO_STR(s7_gc_protected_at(sc, gc_loc))); free(s1); free(s2);}
667
668 if (s7_car(p) != s7_f(sc))
669 {fprintf(stderr, "%d: (car %s) is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
670
671 if (s7_cdr(p) != s7_t(sc))
672 {fprintf(stderr, "%d: (cdr %s) is not #t?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
673
674 if (!s7_is_pair(p))
675 {fprintf(stderr, "%d: %s is not a pair?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
676
677 s7_set_car(p, s7_eof_object(sc));
678 if (s7_car(p) != s7_eof_object(sc))
679 {fprintf(stderr, "%d: (car %s) is not #<eof>?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
680
681 s7_set_cdr(p, s7_unspecified(sc));
682 if (s7_cdr(p) != s7_unspecified(sc))
683 {fprintf(stderr, "%d: (cdr %s) is not #<unspecified>?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
684
685 s7_gc_unprotect_at(sc, gc_loc);
686
687
688
689 p = TO_S7_INT(123);
690 gc_loc = s7_gc_protect(sc, p);
691
692 if (!s7_is_integer(p))
693 {fprintf(stderr, "%d: %s is not integral?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
694
695 if (!s7_is_rational(p))
696 {fprintf(stderr, "%d: %s is not rational?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
697
698 if (s7_is_ratio(p))
699 {fprintf(stderr, "%d: %s is a ratio?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
700
701 if (!s7_is_real(p))
702 {fprintf(stderr, "%d: %s is not real?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
703
704 if (!s7_is_complex(p))
705 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
706
707 if (!s7_is_number(p))
708 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
709
710 if (s7_integer(p) != 123)
711 {fprintf(stderr, "%d: %s is not 123?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
712
713 s2 = s7_number_to_string(sc, p, 10);
714 if (strcmp(s2, "123") != 0)
715 {fprintf(stderr, "%d: (number->string %s) is not \"123\"?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
716 free(s2);
717
718 if (s7_number_to_integer(sc, p) != 123)
719 {fprintf(stderr, "%d: s7_number_to_integer %s is not 123?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
720 if (s7_number_to_integer_with_caller(sc, p, "ffitest") != 123)
721 {fprintf(stderr, "%d: s7_number_to_integer_with_caller %s is not 123?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
722
723 s7_gc_unprotect_at(sc, gc_loc);
724
725
726 p = s7_make_ratio(sc, 123, 5);
727 gc_loc = s7_gc_protect(sc, p);
728
729 if (s7_is_integer(p))
730 {fprintf(stderr, "%d: %s is integral?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
731
732 if (!s7_is_rational(p))
733 {fprintf(stderr, "%d: %s is not rational?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
734
735 if (!s7_is_ratio(p))
736 {fprintf(stderr, "%d: %s is not a ratio?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
737
738 if (!s7_is_real(p))
739 {fprintf(stderr, "%d: %s is not real?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
740
741 if (!s7_is_complex(p))
742 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
743
744 if (!s7_is_number(p))
745 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
746
747 if (s7_numerator(p) != 123)
748 {fprintf(stderr, "%d: (numerator %s) is not 123?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
749
750 if (s7_denominator(p) != 5)
751 {fprintf(stderr, "%d: (denominator %s) is not 5?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
752
753 s2 = s7_number_to_string(sc, p, 10);
754 if (strcmp(s2, "123/5") != 0)
755 {fprintf(stderr, "%d: (number->string %s) is not \"123/5\"?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
756 free(s2);
757
758 s7_gc_unprotect_at(sc, gc_loc);
759
760
761 p = s7_make_real(sc, 1.5);
762 gc_loc = s7_gc_protect(sc, p);
763
764 if (s7_is_integer(p))
765 {fprintf(stderr, "%d: %s is integral?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
766
767 if (s7_is_rational(p))
768 {fprintf(stderr, "%d: %s is rational?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
769
770 if (s7_is_ratio(p))
771 {fprintf(stderr, "%d: %s is a ratio?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
772
773 if (!s7_is_real(p))
774 {fprintf(stderr, "%d: %s is not real?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
775
776 if (!s7_is_complex(p))
777 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
778
779 if (!s7_is_number(p))
780 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
781
782 if (s7_real(p) != 1.5)
783 {fprintf(stderr, "%d: %s is not 1.5?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
784
785 s2 = s7_number_to_string(sc, p, 10);
786 if (strcmp(s2, "1.5") != 0)
787 {fprintf(stderr, "%d: (number->string %s) is not \"1.5\"?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
788 free(s2);
789
790 if (s7_number_to_real(sc, p) != 1.5)
791 {fprintf(stderr, "%d: s7_number_to_real %s is not 1.5?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
792
793 s7_gc_unprotect_at(sc, gc_loc);
794
795 p = s7_make_mutable_real(sc, 1.5);
796 if (!s7_is_real(p))
797 {fprintf(stderr, "%d: %s is not real?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
798
799 p = s7_make_complex(sc, 1.0, 1.0);
800 gc_loc = s7_gc_protect(sc, p);
801
802 if (s7_is_integer(p))
803 {fprintf(stderr, "%d: %s is integral?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
804
805 if (s7_is_rational(p))
806 {fprintf(stderr, "%d: %s is rational?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
807
808 if (s7_is_ratio(p))
809 {fprintf(stderr, "%d: %s is a ratio?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
810
811 if (s7_is_real(p))
812 {fprintf(stderr, "%d: %s is real?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
813
814 if (!s7_is_complex(p))
815 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
816
817 if (!s7_is_number(p))
818 {fprintf(stderr, "%d: %s is not complex?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
819
820 if (s7_real_part(p) != 1.0)
821 {fprintf(stderr, "%d: (real-part %s) is not 1.0?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
822
823 if (s7_integer(s7_apply_1(sc, int_list(sc, 1), ap_1)) != 1) fprintf(stderr, "apply_1 != 1\n");
824 if (s7_integer(s7_apply_2(sc, int_list(sc, 2), ap_2)) != 3) fprintf(stderr, "apply_2 != 3\n");
825 if (s7_integer(s7_apply_3(sc, int_list(sc, 3), ap_3)) != 6) fprintf(stderr, "apply_3 != 6\n");
826 if (s7_integer(s7_apply_4(sc, int_list(sc, 4), ap_4)) != 10) fprintf(stderr, "apply_4 != 10\n");
827 if (s7_integer(s7_apply_5(sc, int_list(sc, 5), ap_5)) != 15) fprintf(stderr, "apply_5 != 15\n");
828 if (s7_integer(s7_apply_6(sc, int_list(sc, 6), ap_6)) != 21) fprintf(stderr, "apply_6 != 21\n");
829 if (s7_integer(s7_apply_7(sc, int_list(sc, 7), ap_7)) != 28) fprintf(stderr, "apply_7 != 28\n");
830 if (s7_integer(s7_apply_8(sc, int_list(sc, 8), ap_8)) != 36) fprintf(stderr, "apply_8 != 36\n");
831 if (s7_integer(s7_apply_9(sc, int_list(sc, 9), ap_9)) != 45) fprintf(stderr, "apply_9 != 45\n");
832
833 if (s7_integer(s7_apply_n_1(sc, int_list(sc, 1), ap_1)) != 1) fprintf(stderr, "apply_1 != 1\n");
834 if (s7_integer(s7_apply_n_2(sc, int_list(sc, 2), ap_2)) != 3) fprintf(stderr, "apply_2 != 3\n");
835 if (s7_integer(s7_apply_n_3(sc, int_list(sc, 3), ap_3)) != 6) fprintf(stderr, "apply_3 != 6\n");
836 if (s7_integer(s7_apply_n_4(sc, int_list(sc, 4), ap_4)) != 10) fprintf(stderr, "apply_4 != 10\n");
837 if (s7_integer(s7_apply_n_5(sc, int_list(sc, 5), ap_5)) != 15) fprintf(stderr, "apply_5 != 15\n");
838 if (s7_integer(s7_apply_n_6(sc, int_list(sc, 6), ap_6)) != 21) fprintf(stderr, "apply_6 != 21\n");
839 if (s7_integer(s7_apply_n_7(sc, int_list(sc, 7), ap_7)) != 28) fprintf(stderr, "apply_7 != 28\n");
840 if (s7_integer(s7_apply_n_8(sc, int_list(sc, 8), ap_8)) != 36) fprintf(stderr, "apply_8 != 36\n");
841 if (s7_integer(s7_apply_n_9(sc, int_list(sc, 9), ap_9)) != 45) fprintf(stderr, "apply_9 != 45\n");
842
843 if (s7_imag_part(p) != 1.0)
844 {fprintf(stderr, "%d: (imag-part %s) is not 1.0?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
845
846 s2 = s7_number_to_string(sc, p, 10);
847 if (strcmp(s2, "1.0+1.0i") != 0)
848 {fprintf(stderr, "%d: (number->string %s) is not \"1.0+1.0i\"?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
849 free(s2);
850
851 s7_immutable(p);
852 if (!s7_is_immutable(p))
853 fprintf(stderr, "s7_immutable failed?\n");
854 s7_gc_unprotect_at(sc, gc_loc);
855
856 p = s7_signature(sc, s7_name_to_value(sc, "abs"));
857 if (!s7_is_pair(p))
858 {fprintf(stderr, "%d: %s is not a pair?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
859
860 {
861 s7_pointer p;
862 p = s7_shadow_rootlet(sc);
863 if ((!s7_is_null(sc, p)) &&
864 (!s7_is_let(p)))
865 fprintf(stderr, "shadow rootlet is %s\n", s7_object_to_c_string(sc, p));
866 s7_set_shadow_rootlet(sc, p);
867 }
868
869 if (s7_c_pointer(s7_make_c_pointer(sc, NULL)))
870 fprintf(stderr, "s7_c_pointer 0 is not null\n");
871 if (s7_c_pointer_type(s7_make_c_pointer_with_type(sc, NULL, s7_nil(sc), s7_f(sc))) != s7_nil(sc))
872 fprintf(stderr, "s7_c_pointer_type is not ()\n");
873 {
874 s7_pointer csc;
875 csc = s7_make_c_pointer_with_type(sc, (void *)sc, s7_make_symbol(sc, "s7_scheme*"), s7_f(sc));
876 if (!s7_is_c_pointer_of_type(csc, s7_make_symbol(sc, "s7_scheme*")))
877 fprintf(stderr, "c-pointer type %s != s7_scheme*\n", s7_object_to_c_string(sc, s7_c_pointer_type(csc)));
878 s7_c_pointer_with_type(sc, csc, s7_make_symbol(sc, "s7_scheme*"), "ffitest", __LINE__);
879 }
880 if (!s7_is_int_vector(s7_make_int_vector(sc, 3, 1, NULL)))
881 fprintf(stderr, "s7_make_int_vector did not make an int-vector\n");
882 if (s7_is_float_vector(s7_make_int_vector(sc, 3, 1, NULL)))
883 fprintf(stderr, "s7_make_int_vector made a float-vector?\n");
884
885 {
886 s7_int* dims;
887 s7_pointer p;
888 s7_double *els;
889 dims = (s7_int *)malloc(2 * sizeof(s7_int));
890 dims[0] = 2;
891 dims[1] = 3;
892 p = s7_make_int_vector(sc, 6, 2, dims);
893 if (s7_vector_rank(p) != 2) fprintf(stderr, "int vector rank not 2?\n");
894 p = s7_make_float_vector(sc, 6, 2, dims);
895 if (s7_vector_rank(p) != 2) fprintf(stderr, "float vector rank not 2?\n");
896 free(dims); /* ?? */
897
898 p = s7_make_float_vector(sc, 6, 1, NULL);
899 s7_float_vector_set(p, 1, 32.0);
900 if (s7_float_vector_ref(p, 1) != 32.0) fprintf(stderr, "float_vector[1] not 32.0?\n");
901 els = s7_float_vector_elements(p);
902 if (els[1] != 32.0) fprintf(stderr, "float_vector els[1] not 32.0?\n");
903 if (!s7_is_float_vector(p)) fprintf(stderr, "not a float_vector?\n");
904 }
905
906 {
907 s7_pointer p;
908 s7_int *els;
909 p = s7_make_int_vector(sc, 6, 1, NULL);
910 s7_int_vector_set(p, 1, 32);
911 if (s7_int_vector_ref(p, 1) != 32) fprintf(stderr, "int_vector[1] not 32?\n");
912 els = s7_int_vector_elements(p);
913 if (els[1] != 32) fprintf(stderr, "int_vector els[1] not 32?\n");
914 if (!s7_is_int_vector(p)) fprintf(stderr, "not an int_vector?\n");
915 }
916
917 {
918 s7_int len;
919 len = s7_integer(s7_let_field_ref(sc, s7_make_symbol(sc, "print-length")));
920 s7_let_field_set(sc, s7_make_symbol(sc, "print-length"), s7_make_integer(sc, len));
921 }
922
923 p = s7_rationalize(sc, 1.5, 1e-12);
924 gc_loc = s7_gc_protect(sc, p);
925 s1 = TO_STR(p);
926 if (strcmp(s1, "3/2") != 0)
927 fprintf(stderr, "%d: ratio is %s?\n", __LINE__, s1);
928 free(s1);
929 s7_gc_unprotect_at(sc, gc_loc);
930
931 s7_set_default_random_state(sc, 1234, 5678);
932 s7_random(sc, NULL);
933 s7_stacktrace(sc);
934
935 if (s7_list(sc, 0) != s7_nil(sc))
936 fprintf(stderr, "s7_list 0 is not ()\n");
937 if (s7_list_nl(sc, 0, NULL) != s7_nil(sc))
938 fprintf(stderr, "s7_list_nl 0 is not ()\n");
939
940 p = s7_make_vector(sc, 12);
941 gc_loc = s7_gc_protect(sc, p);
942
943 if (!s7_is_vector(p))
944 {fprintf(stderr, "%d: %s is not a vector?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
945 if (s7_type_of(sc, p) != s7_make_symbol(sc, "vector?"))
946 fprintf(stderr, "type-of(vector) confused?\n");
947
948 if (s7_vector_rank(p) != 1)
949 {fprintf(stderr, "%d: (dimensions %s) is not 1?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
950
951 s7_vector_set(sc, p, 1, s7_t(sc));
952 if (s7_vector_ref(sc, p, 1) != s7_t(sc))
953 {fprintf(stderr, "%d: (%s 1) is not #t?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
954
955 s7_vector_fill(sc, p, TO_S7_INT(123));
956 if (s7_integer(s7_vector_ref(sc, p, 1)) != 123)
957 {fprintf(stderr, "%d: (%s 1) is not 123?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
958
959 s7_gc_unprotect_at(sc, gc_loc);
960
961 p = s7_make_and_fill_vector(sc, 3, TO_S7_INT(3));
962 gc_loc = s7_gc_protect(sc, p);
963
964 if (s7_integer(s7_vector_ref(sc, p, 1)) != 3)
965 {fprintf(stderr, "%d: (%s 1) is not 3?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
966
967 p1 = s7_vector_copy(sc, p);
968 if ((p == p1) ||
969 (!s7_is_vector(p1)))
970 {fprintf(stderr, "%d: copied vector: %s\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
971 s7_gc_unprotect_at(sc, gc_loc);
972
973
974 p = s7_make_string(sc, "1234");
975 gc_loc = s7_gc_protect(sc, p);
976
977 if (!s7_is_string(p))
978 {fprintf(stderr, "%d: %s is not a string?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
979
980 if (s7_string_length(p) != 4)
981 {fprintf(stderr, "%d: (length %s) is 4?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
982
983 if (strcmp(s7_string(p), "1234") != 0)
984 {fprintf(stderr, "%d: %s is \"1234\"?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
985
986 s7_gc_unprotect_at(sc, gc_loc);
987
988
989 p = s7_make_character(sc, 65);
990 if (!s7_is_character(p))
991 {fprintf(stderr, "%d: %s is not a character?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
992
993 if (s7_character(p) != 'A')
994 {fprintf(stderr, "%d: %s is not #\\A?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
995
996
997 p = s7_list(sc, 3, TO_S7_INT(1), TO_S7_INT(2), TO_S7_INT(3));
998 gc_loc = s7_gc_protect(sc, p);
999 if (s7_tree_memq(sc, s7_make_symbol(sc, "oops"), p))
1000 fprintf(stderr, "'oops is in the list?\n");
1001
1002 if (!s7_is_list(sc, p))
1003 {fprintf(stderr, "%d: %s is not a list?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1004
1005 if (s7_list_length(sc, p) != 3)
1006 {fprintf(stderr, "%d: (length %s) is not 3?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1007
1008 if (s7_integer(s7_list_ref(sc, p, 1)) != 2)
1009 {fprintf(stderr, "%d: (%s 1) is not 2?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1010
1011 if (s7_integer(s7_car(p)) != 1)
1012 {fprintf(stderr, "%d: (car %s) is not 1?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1013
1014 if (s7_integer(s7_cadr(p)) != 2)
1015 {fprintf(stderr, "%d: (cadr %s) is not 2?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1016
1017 if (s7_integer(s7_caddr(p)) != 3)
1018 {fprintf(stderr, "%d: (caddr %s) is not 2?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1019
1020 if (s7_integer(s7_car(s7_cddr(p))) != 3)
1021 {fprintf(stderr, "%d: (car (cddr %s)) is not 2?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1022
1023 s7_list_set(sc, p, 1, s7_f(sc));
1024 if (s7_list_ref(sc, p, 1) != s7_f(sc))
1025 {fprintf(stderr, "%d: (%s 1) is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1026
1027 s7_gc_unprotect_at(sc, gc_loc);
1028
1029 p = s7_list_nl(sc, 3, TO_S7_INT(1), TO_S7_INT(2), TO_S7_INT(3), NULL);
1030 gc_loc = s7_gc_protect(sc, p);
1031 if (!s7_is_list(sc, p))
1032 {fprintf(stderr, "%d: %s is not a list?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1033 if (s7_list_length(sc, p) != 3)
1034 {fprintf(stderr, "%d: (length %s) is not 3?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1035 if (s7_integer(s7_list_ref(sc, p, 1)) != 2)
1036 {fprintf(stderr, "%d: (%s 1) is not 2?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1037 s7_gc_unprotect_at(sc, gc_loc);
1038
1039 {
1040 s7_pointer c1, c2, c3, c12, c23, c123, c1234, c1d2, c2d3, c3d4, c12d3, c23d4, c123d4, c1234d5;
1041 s7_gc_on(sc, false);
1042 c1 = s7_list(sc, 1, TO_S7_INT(1)); /* (1) */
1043 c2 = s7_list(sc, 1, TO_S7_INT(2)); /* (2) */
1044 c3 = s7_list(sc, 1, TO_S7_INT(3)); /* (3) */
1045 c12 = s7_list(sc, 2, TO_S7_INT(1), TO_S7_INT(2)); /* (1 2) */
1046 c23 = s7_list(sc, 2, TO_S7_INT(2), TO_S7_INT(3)); /* (2 3) */
1047 c123 = s7_list(sc, 3, TO_S7_INT(1), TO_S7_INT(2), TO_S7_INT(3)); /* (1 2 3) */
1048 c1234 = s7_list(sc, 4, TO_S7_INT(1), TO_S7_INT(2), TO_S7_INT(3), TO_S7_INT(4)); /* (1 2 3 4) */
1049 c1d2 = s7_cons(sc, TO_S7_INT(1), TO_S7_INT(2)); /* (1 . 2) */
1050 c2d3 = s7_cons(sc, TO_S7_INT(2), TO_S7_INT(3)); /* (2 . 3) */
1051 c3d4 = s7_cons(sc, TO_S7_INT(3), TO_S7_INT(4)); /* (3 . 4) */
1052 c12d3 = s7_cons(sc, TO_S7_INT(1), s7_cons(sc, TO_S7_INT(2), TO_S7_INT(3))); /* (1 2 . 3) */
1053 c23d4 = s7_cons(sc, TO_S7_INT(2), s7_cons(sc, TO_S7_INT(3), TO_S7_INT(4))); /* (2 3 . 4) */
1054 c123d4 = s7_cons(sc, TO_S7_INT(1), s7_cons(sc, TO_S7_INT(2), s7_cons(sc, TO_S7_INT(3), TO_S7_INT(4)))); /* (1 2 3 . 4) */
1055 c1234d5 = s7_cons(sc, TO_S7_INT(1), s7_cons(sc, TO_S7_INT(2), s7_cons(sc, TO_S7_INT(3), s7_cons(sc, TO_S7_INT(4), TO_S7_INT(5))))); /* (1 2 3 4 . 5) */
1056
1057 if (s7_integer(p = s7_caar(s7_list(sc, 1, c1))) != 1)
1058 {fprintf(stderr, "%d: caar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1059
1060 if (s7_integer(p = s7_cadr(c12)) != 2)
1061 {fprintf(stderr, "%d: cadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1062
1063 if (s7_integer(p = s7_cdar(s7_list(sc, 1, c1d2))) != 2)
1064 {fprintf(stderr, "%d: cdar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1065
1066 if (s7_integer(p = s7_cddr(c12d3)) != 3)
1067 {fprintf(stderr, "%d: cddr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1068
1069 if (s7_integer(p = s7_caaar(s7_list(sc, 1, s7_list(sc, 1, c1)))) != 1)
1070 {fprintf(stderr, "%d: caaar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1071
1072 if (s7_integer(p = s7_caadr(s7_list(sc, 2, TO_S7_INT(1), c2))) != 2)
1073 {fprintf(stderr, "%d: caadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1074
1075 if (s7_integer(p = s7_cadar(s7_list(sc, 1, c12))) != 2)
1076 {fprintf(stderr, "%d: cadar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1077
1078 if (s7_integer(p = s7_cdaar(s7_list(sc, 1, s7_list(sc, 1, c1d2)))) != 2)
1079 {fprintf(stderr, "%d: cdaar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1080
1081 if (s7_integer(p = s7_caddr(c123)) != 3)
1082 {fprintf(stderr, "%d: caddr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1083
1084 if (s7_integer(p = s7_cdddr(c123d4)) != 4)
1085 {fprintf(stderr, "%d: cdddr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1086
1087 if (s7_integer(p = s7_cdadr(s7_list(sc, 2, TO_S7_INT(1), c2d3))) != 3)
1088 {fprintf(stderr, "%d: cdadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1089
1090 if (s7_integer(p = s7_cddar(s7_list(sc, 1, c12d3))) != 3)
1091 {fprintf(stderr, "%d: cddar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1092
1093 if (s7_integer(p = s7_caaaar(s7_list(sc, 1, s7_list(sc, 1, s7_list(sc, 1, c1))))) != 1)
1094 {fprintf(stderr, "%d: caaaar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1095
1096 if (s7_integer(p = s7_caaadr(s7_list(sc, 2, TO_S7_INT(1), s7_list(sc, 1, c2)))) != 2)
1097 {fprintf(stderr, "%d: caaadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1098
1099 if (s7_integer(p = s7_caadar(s7_list(sc, 1, s7_list(sc, 2, TO_S7_INT(1), c2)))) != 2)
1100 {fprintf(stderr, "%d: caadar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1101
1102 if (s7_integer(p = s7_cadaar(s7_list(sc, 1, s7_list(sc, 1, c12)))) != 2)
1103 {fprintf(stderr, "%d: cadaar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1104
1105 if (s7_integer(p = s7_caaddr(s7_list(sc, 3, TO_S7_INT(1), TO_S7_INT(2), c3))) != 3)
1106 {fprintf(stderr, "%d: caaddr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1107
1108 if (s7_integer(p = s7_cadddr(c1234)) != 4)
1109 {fprintf(stderr, "%d: cadddr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1110
1111 if (s7_integer(p = s7_cadadr(s7_list(sc, 2, TO_S7_INT(1), c23))) != 3)
1112 {fprintf(stderr, "%d: cadadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1113
1114 if (s7_integer(p = s7_caddar(s7_list(sc, 1, c123))) != 3)
1115 {fprintf(stderr, "%d: caddar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1116
1117 if (s7_integer(p = s7_cdaaar(s7_list(sc, 1, s7_list(sc, 1, s7_list(sc, 1, c1d2))))) != 2)
1118 {fprintf(stderr, "%d: cdaaar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1119
1120 if (s7_integer(p = s7_cdaadr(s7_list(sc, 2, TO_S7_INT(1), s7_list(sc, 1, c2d3)))) != 3)
1121 {fprintf(stderr, "%d: cdaadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1122
1123 if (s7_integer(p = s7_cdadar(s7_list(sc, 1, s7_list(sc, 2, TO_S7_INT(1), c2d3)))) != 3)
1124 {fprintf(stderr, "%d: cdadar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1125
1126 if (s7_integer(p = s7_cddaar(s7_list(sc, 1, s7_list(sc, 1, c12d3)))) != 3)
1127 {fprintf(stderr, "%d: cddaar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1128
1129 if (s7_integer(p = s7_cdaddr(s7_list(sc, 3, TO_S7_INT(1), TO_S7_INT(2), c3d4))) != 4)
1130 {fprintf(stderr, "%d: cdaddr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1131
1132 if (s7_integer(p = s7_cddddr(c1234d5)) != 5)
1133 {fprintf(stderr, "%d: cdddd is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1134
1135 if (s7_integer(p = s7_cddadr(s7_list(sc, 2, TO_S7_INT(1), c23d4))) != 4)
1136 {fprintf(stderr, "%d: cddadr is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1137
1138 if (s7_integer(p = s7_cdddar(s7_list(sc, 1, c123d4))) != 4)
1139 {fprintf(stderr, "%d: cdddar is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1140
1141 p = s7_reverse(sc, c123);
1142 s1 = TO_STR(p);
1143 if (strcmp(s1, "(3 2 1)") != 0)
1144 {fprintf(stderr, "%d: (reverse '(1 2 3)) is %s?\n", __LINE__, s1);}
1145 free(s1);
1146
1147 p = s7_append(sc, c1, c2);
1148 s1 = TO_STR(p);
1149 if (strcmp(s1, "(1 2)") != 0)
1150 {fprintf(stderr, "%d: (append '(1) '(2)) is %s?\n", __LINE__, s1);}
1151 free(s1);
1152
1153 p = s7_list(sc, 2, s7_cons(sc, s7_make_symbol(sc, "a"), TO_S7_INT(32)), s7_cons(sc, s7_make_symbol(sc, "b"), TO_S7_INT(1)));
1154 p1 = s7_assq(sc, s7_make_symbol(sc, "a"), p);
1155 s1 = TO_STR(p1);
1156 if (strcmp(s1, "(a . 32)") != 0)
1157 {fprintf(stderr, "%d: (assq 'a '((a . 32) (b . 1)))) is %s?\n", __LINE__, s1);}
1158 free(s1);
1159
1160 p1 = s7_assoc(sc, s7_make_symbol(sc, "b"), p);
1161 s1 = TO_STR(p1);
1162 if (strcmp(s1, "(b . 1)") != 0)
1163 {fprintf(stderr, "%d: (assoc 'b '((a . 32) (b . 1))) is %s?\n", __LINE__, s1);}
1164 free(s1);
1165
1166 p = s7_member(sc, TO_S7_INT(2), c1234);
1167 s1 = TO_STR(p);
1168 if (strcmp(s1, "(2 3 4)") != 0)
1169 {fprintf(stderr, "%d: (member 2 '(1 2 3 4)) is %s?\n", __LINE__, s1);}
1170 free(s1);
1171
1172 p = s7_list(sc, 2, s7_make_symbol(sc, "a"), s7_make_symbol(sc, "b"));
1173 p1 = s7_memq(sc, s7_make_symbol(sc, "b"), p);
1174 s1 = TO_STR(p1);
1175 if (strcmp(s1, "(b)") != 0)
1176 {fprintf(stderr, "%d: (memq 'b '(a b)) is %s?\n", __LINE__, s1);}
1177 free(s1);
1178
1179 s7_set_car(c1234, s7_make_symbol(sc, "+"));
1180 p = s7_eval(sc, c1234, s7_sublet(sc, s7_rootlet(sc), s7_nil(sc)));
1181 if (s7_integer(p) != 9)
1182 {fprintf(stderr, "%d: (eval '(+ 2 3 4)) is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1183 s7_gc_on(sc, true);
1184
1185 p = s7_eval(sc, s7_cons(sc, s7_make_symbol(sc, "+"), /* s7.html example */
1186 s7_cons(sc, s7_make_integer(sc, 1),
1187 s7_cons(sc, s7_make_integer(sc, 2), s7_nil(sc)))),
1188 s7_nil(sc));
1189 if (s7_integer(p) != 3)
1190 {fprintf(stderr, "%d: (eval '(+ 1 2)) is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1191 p = s7_eval(sc, s7_cons(sc, s7_make_symbol(sc, "+"), /* s7.html example */
1192 s7_cons(sc, s7_make_integer(sc, 1),
1193 s7_cons(sc, s7_make_integer(sc, 3), s7_nil(sc)))),
1194 s7_rootlet(sc));
1195 if (s7_integer(p) != 4)
1196 {fprintf(stderr, "%d: (eval '(+ 1 3)) is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1197 p = s7_eval_c_string(sc, "(+ 2 3)");
1198 if (s7_integer(p) != 5)
1199 {fprintf(stderr, "%d: (eval-string '(+ 2 3)) is %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1200 }
1201
1202 s7_for_each_symbol_name(sc, symbol_func, NULL);
1203 s7_for_each_symbol(sc, symbol_func_1, NULL);
1204 s7_symbol_name(s7_make_symbol(sc, "a_symbol"));
1205
1206 p = s7_make_hash_table(sc, 255);
1207 gc_loc = s7_gc_protect(sc, p);
1208
1209 if (!s7_is_hash_table(p))
1210 {fprintf(stderr, "%d: %s is not a hash-table?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1211
1212 if (s7_hash_table_ref(sc, p, s7_eof_object(sc)) != s7_f(sc))
1213 {fprintf(stderr, "%d: (hash-table-ref %s #<eof>) is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1214
1215 s7_hash_table_set(sc, p, s7_eof_object(sc), s7_unspecified(sc));
1216 if (s7_hash_table_ref(sc, p, s7_eof_object(sc)) != s7_unspecified(sc))
1217 {fprintf(stderr, "%d: (hash-table-ref %s #<eof>) is not #<unspecified>?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1218 s7_gc_unprotect_at(sc, gc_loc);
1219
1220 p = s7_current_input_port(sc);
1221 if (!s7_is_input_port(sc, p))
1222 {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1223 s7_port_line_number(sc, p);
1224 s7_add_to_history(sc, s7_nil(sc));
1225 s7_history(sc);
1226
1227 p = s7_current_output_port(sc);
1228 if (!s7_is_output_port(sc, p))
1229 {fprintf(stderr, "%d: %s is not an output port?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1230
1231 p = s7_name_to_value(sc, "abs");
1232 if (!s7_is_procedure(p))
1233 {fprintf(stderr, "%d: %s is not a procedure?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1234
1235 p = s7_make_symbol(sc, "abs");
1236 if (!s7_is_symbol(p))
1237 {fprintf(stderr, "%d: %s is not a symbol?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1238
1239 p = s7_gensym(sc, "abs");
1240 if (!s7_is_symbol(p))
1241 {fprintf(stderr, "%d: %s is not a symbol?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1242
1243 p = s7_make_keyword(sc, "key");
1244 if (!s7_is_keyword(p))
1245 {fprintf(stderr, "%d: %s is not a keyword?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1246 if (s7_keyword_to_symbol(sc, p) != s7_make_symbol(sc, "key"))
1247 fprintf(stderr, "%d: key->sym != sym?\n", __LINE__);
1248
1249 if (!s7_is_eq(p, p))
1250 {fprintf(stderr, "%d: %s is not a self-eq??\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1251
1252 p = s7_rootlet(sc);
1253 if (!s7_is_let(p))
1254 {fprintf(stderr, "%d: %s is not an environment?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1255
1256 p = s7_curlet(sc);
1257 if ((!s7_is_null(sc, p)) && (!s7_is_let(p)))
1258 {fprintf(stderr, "%d: %s is not an environment?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1259
1260 s7_define_constant(sc, "a_constant", s7_t(sc));
1261 if (!s7_is_immutable(s7_name_to_value(sc, "a_constant")))
1262 {fprintf(stderr, "%d: a_constant is not a constant?\n", __LINE__);}
1263 if (!s7_is_defined(sc, "a_constant"))
1264 {fprintf(stderr, "%d: a_constant is not defined?\n", __LINE__);}
1265
1266 s7_define_function(sc, "a_function", a_function, 1, 0, false, "a function");
1267 if (!s7_is_defined(sc, "a_function"))
1268 {fprintf(stderr, "%d: a_function is not defined?\n", __LINE__);}
1269 if (!s7_is_function(s7_name_to_value(sc, "a_function")))
1270 {fprintf(stderr, "%d: a_function is not a function?\n", __LINE__);}
1271
1272 p = s7_apply_function(sc, s7_name_to_value(sc, "a_function"), s7_cons(sc, TO_S7_INT(32), s7_nil(sc)));
1273 if (!s7_is_integer(p))
1274 {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1275 if (s7_integer(p) != 32)
1276 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1277
1278
1279 dax_type_tag = s7_make_c_type(sc, "dax");
1280 s7_c_type_set_free(sc, dax_type_tag, free_dax);
1281 s7_c_type_set_equal(sc, dax_type_tag, equal_dax);
1282 s7_c_type_set_is_equal(sc, dax_type_tag, equality_dax);
1283 s7_c_type_set_mark(sc, dax_type_tag, mark_dax);
1284 s7_c_type_set_to_string(sc, dax_type_tag, dax_to_string);
1285
1286 s7_define_function(sc, "make-dax", make_dax, 2, 0, false, "(make-dax x data) makes a new dax");
1287 s7_define_function(sc, "dax?", is_dax, 1, 0, false, "(dax? anything) returns #t if its argument is a dax object");
1288
1289 s7_define_variable(sc, "dax-x",
1290 s7_dilambda(sc, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field (a real)"));
1291
1292 s7_define_variable(sc, "dax-data",
1293 s7_dilambda(sc, "dax-data", dax_data, 1, 0, set_dax_data, 2, 0, "dax data field"));
1294
1295 if (!s7_is_dilambda(s7_name_to_value(sc, "dax-x")))
1296 {fprintf(stderr, "%d: dax-x is not a pws?\n", __LINE__);}
1297
1298 p = make_dax(sc, s7_cons(sc, s7_make_real(sc, 1.0), s7_cons(sc, TO_S7_INT(2), s7_nil(sc))));
1299 gc_loc = s7_gc_protect(sc, p);
1300
1301 if (!s7_is_c_object(p))
1302 {fprintf(stderr, "%d: %s is not a c_object?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1303
1304 p1 = s7_apply_function(sc, s7_name_to_value(sc, "dax?"), s7_cons(sc, p, s7_nil(sc)));
1305 if (p1 != s7_t(sc))
1306 {fprintf(stderr, "%d: %s is not a dax c_object?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1307
1308 s1 = TO_STR(p);
1309 if (strcmp(s1, "#<dax 1.000 2>") != 0)
1310 {fprintf(stderr, "%d: dax prints as %s?\n", __LINE__, s2 = TO_STR(p)); free(s2);}
1311 free(s1);
1312
1313 p1 = s7_apply_function(sc, s7_name_to_value(sc, "dax-data"), s7_cons(sc, p, s7_nil(sc)));
1314 if (!s7_is_integer(p1))
1315 {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1316 if (s7_integer(p1) != 2)
1317 {fprintf(stderr, "%d: %s is not 2?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1318
1319 s7_apply_function(sc, s7_setter(sc, s7_name_to_value(sc, "dax-data")), s7_cons(sc, p, s7_cons(sc, TO_S7_INT(32), s7_nil(sc))));
1320 p1 = s7_apply_function(sc, s7_name_to_value(sc, "dax-data"), s7_cons(sc, p, s7_nil(sc)));
1321 if (!s7_is_integer(p1))
1322 {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1323 if (s7_integer(p1) != 32)
1324 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1325
1326 s7_gc_unprotect_at(sc, gc_loc);
1327
1328
1329 s7_define_function_star(sc, "plus", plus, "(red 32) blue", "an example of define* from C");
1330 if (!s7_is_procedure(s7_name_to_value(sc, "plus")))
1331 {fprintf(stderr, "%d: plus is not a function?\n", __LINE__);}
1332
1333 p = s7_apply_function(sc, s7_name_to_value(sc, "plus"), s7_cons(sc, TO_S7_INT(1), s7_cons(sc, TO_S7_INT(2), s7_nil(sc))));
1334 if (!s7_is_integer(p))
1335 {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1336 if (s7_integer(p) != 4)
1337 {fprintf(stderr, "%d: %s is not 4?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1338
1339 s7_define_function_star(sc, "plus1", plus1, "a b c", "an example of define* from C");
1340 {
1341 s7_int val;
1342 val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus1"),
1343 s7_list(sc, 3,
1344 s7_make_integer(sc, 4),
1345 s7_make_integer(sc, 5),
1346 s7_make_integer(sc, 6))));
1347 if (val != 21)
1348 fprintf(stderr, "plus1: %" print_s7_int "\n", val);
1349 }
1350
1351 {
1352 s7_pointer old_port, val;
1353 old_port = s7_current_error_port(sc);
1354
1355 s7_define_function_star(sc, "fs1", fs1, "(opts (inlet 'f \"b\"))", NULL);
1356 s7_define_function_star(sc, "fs2", fs2, "", NULL);
1357 s7_set_current_error_port(sc, s7_f(sc));
1358 s7_define_function_star(sc, "fs3", fs3, ":allow-other-keys", NULL);
1359 s7_set_current_error_port(sc, old_port);
1360 s7_define_function_star(sc, "fs31", fs31, "(a 32) :allow-other-keys", NULL);
1361
1362 s7_define_safe_function_star(sc, "fs4", fs4, "(opts (inlet 'f \"b\"))", NULL);
1363 s7_define_safe_function_star(sc, "fs5", fs5, "", NULL);
1364 s7_set_current_error_port(sc, s7_f(sc));
1365 s7_define_safe_function_star(sc, "fs6", fs6, ":allow-other-keys", NULL);
1366 s7_set_current_error_port(sc, old_port);
1367 s7_define_safe_function_star(sc, "fs61", fs61, "(a #(0)) :allow-other-keys", NULL);
1368
1369 val = s7_eval_c_string(sc, "(fs1)");
1370 if (!s7_is_let(val)) fprintf(stderr, "(fs1): %s\n", s7_object_to_c_string(sc, val));
1371 val = s7_eval_c_string(sc, "(fs1 #f)");
1372 if (!s7_is_eq(val, s7_f(sc))) fprintf(stderr, "(fs1 #f): %s\n", s7_object_to_c_string(sc, val));
1373 val = s7_eval_c_string(sc, "(fs2)");
1374 if (!s7_is_null(sc, val)) fprintf(stderr, "(fs2): %s\n", s7_object_to_c_string(sc, val));
1375
1376 val = s7_eval_c_string(sc, "(fs31)");
1377 if (s7_integer(val) != 32) fprintf(stderr, "(fs31): %s\n", s7_object_to_c_string(sc, val));
1378 val = s7_eval_c_string(sc, "(fs31 32)");
1379 if (s7_integer(val) != 32) fprintf(stderr, "(fs31 32): %s\n", s7_object_to_c_string(sc, val));
1380 val = s7_eval_c_string(sc, "(fs31 :a 31)");
1381 if (s7_integer(val) != 31) fprintf(stderr, "(fs31 :a 31): %s\n", s7_object_to_c_string(sc, val));
1382 val = s7_eval_c_string(sc, "(fs31 :ignored #f)");
1383 if (s7_integer(val) != 32) fprintf(stderr, "(fs31 :ignored #f): %s\n", s7_object_to_c_string(sc, val));
1384 val = s7_eval_c_string(sc, "(fs31 :a 30 :ignored #f)");
1385 if (s7_integer(val) != 30) fprintf(stderr, "(fs31 :a 30 :ignored #f): %s\n", s7_object_to_c_string(sc, val));
1386 val = s7_eval_c_string(sc, "(fs31 :ignored #f :a 29)");
1387 if (s7_integer(val) != 29) fprintf(stderr, "(fs31 :ignored #f :a 29): %s\n", s7_object_to_c_string(sc, val));
1388
1389 val = s7_eval_c_string(sc, "(fs4)");
1390 if (!s7_is_let(val)) fprintf(stderr, "(fs4): %s\n", s7_object_to_c_string(sc, val));
1391 val = s7_eval_c_string(sc, "(fs4 #f)");
1392 if (!s7_is_eq(val, s7_f(sc))) fprintf(stderr, "(fs4 #f): %s\n", s7_object_to_c_string(sc, val));
1393 val = s7_eval_c_string(sc, "(fs5)");
1394 if (!s7_is_null(sc, val)) fprintf(stderr, "(fs5): %s\n", s7_object_to_c_string(sc, val));
1395
1396 val = s7_eval_c_string(sc, "(fs61)");
1397 if (!s7_is_vector(val)) fprintf(stderr, "(fs61): %s\n", s7_object_to_c_string(sc, val));
1398 val = s7_eval_c_string(sc, "(fs61 32)");
1399 if (s7_integer(val) != 32) fprintf(stderr, "(fs61 32): %s\n", s7_object_to_c_string(sc, val));
1400 val = s7_eval_c_string(sc, "(fs61 :a 31)");
1401 if (s7_integer(val) != 31) fprintf(stderr, "(fs61 :a 31): %s\n", s7_object_to_c_string(sc, val));
1402 val = s7_eval_c_string(sc, "(fs61 :ignored #f)");
1403 if (!s7_is_vector(val)) fprintf(stderr, "(fs61 :ignored #f): %s\n", s7_object_to_c_string(sc, val));
1404 val = s7_eval_c_string(sc, "(fs61 :a 30 :ignored #f)");
1405 if (s7_integer(val) != 30) fprintf(stderr, "(fs61 :a 30 :ignored #f): %s\n", s7_object_to_c_string(sc, val));
1406 val = s7_eval_c_string(sc, "(fs61 :ignored #f :a 29)");
1407 if (s7_integer(val) != 29) fprintf(stderr, "(fs61 :ignored #f :a 29): %s\n", s7_object_to_c_string(sc, val));
1408 }
1409
1410 p = s7_apply_function(sc, s7_name_to_value(sc, "plus"), s7_cons(sc, s7_make_keyword(sc, "blue"), s7_cons(sc, TO_S7_INT(2), s7_nil(sc))));
1411 if (!s7_is_integer(p))
1412 {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1413 if (s7_integer(p) != 66)
1414 {fprintf(stderr, "%d: %s is not 66?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1415
1416 s7_define_variable(sc, "my-1", s7_make_integer(sc, 1));
1417 p = s7_name_to_value(sc, "my-1");
1418 if (!s7_is_integer(p))
1419 {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1420
1421 if (s7_integer(p) != 1)
1422 {fprintf(stderr, "%d: %s is not 1?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1423
1424 s7_symbol_set_value(sc, s7_make_symbol(sc, "my-1"), s7_make_integer(sc, 32));
1425 p = s7_name_to_value(sc, "my-1");
1426 if (s7_integer(p) != 32)
1427 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1428
1429
1430 s7_define_macro(sc, "mac-plus", mac_plus, 2, 0, false, "plus adds its two arguments");
1431 p = s7_eval_c_string(sc, "(mac-plus 2 3)");
1432 if (s7_integer(p) != 5)
1433 {fprintf(stderr, "%d: %s is not 5?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1434 p1 = s7_apply_function(sc,
1435 s7_name_to_value(sc, "mac-plus"),
1436 s7_list(sc, 2, s7_make_integer(sc, 3), s7_make_integer(sc, 4)));
1437 p = s7_eval(sc, p1, s7_rootlet(sc));
1438 if ((!s7_is_integer(p)) ||
1439 (s7_integer(p) != 7))
1440 {char *s2; fprintf(stderr, "%d: %s -> %s is not 7?\n", __LINE__, s1 = TO_STR(p1), s2 = TO_STR(p)); free(s1); free(s2);}
1441
1442 s7_define_macro(sc, "mac-plus-mv", mac_plus_mv, 2, 0, false, "macro values test");
1443 p = s7_eval_c_string(sc, "(let () (+ (mac-plus-mv 2 3)))");
1444 if (s7_integer(p) != 5)
1445 {fprintf(stderr, "%d: %s is not 5?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1446
1447
1448 s7_define_function(sc, "open-plus", open_plus, 1, 0, true, plus_help);
1449 p = s7_sublet(sc, s7_nil(sc), s7_cons(sc, s7_cons(sc, s7_make_symbol(sc, "plus"), s7_name_to_value(sc, "plus")), s7_nil(sc)));
1450 s7_openlet(sc, p);
1451 p1 = s7_apply_function(sc, s7_name_to_value(sc, "open-plus"), s7_list(sc, 3, p, s7_make_integer(sc, 2), s7_make_integer(sc, 3)));
1452 if ((!s7_is_integer(p1)) ||
1453 (s7_integer(p1) != 7))
1454 {fprintf(stderr, "%d: %s is not 7?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1455
1456
1457 s7_eval_c_string(sc, "(define my-vect (make-vector '(2 3 4) 0))");
1458 s7_eval_c_string(sc, "(set! (my-vect 1 1 1) 32)");
1459 p1 = s7_name_to_value(sc, "my-vect");
1460
1461 p = s7_vector_ref_n(sc, p1, 3, 0LL, 0LL, 0LL);
1462 if (s7_integer(p) != 0)
1463 {fprintf(stderr, "%d: %s is not 0?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1464
1465 p = s7_vector_ref_n(sc, p1, 3, 0LL, 0LL, 0LL);
1466 if (s7_integer(p) != 0)
1467 {fprintf(stderr, "%d: %s is not 0?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1468
1469 p = s7_vector_ref_n(sc, p1, 3, 1LL, 1LL, 1LL);
1470 if (s7_integer(p) != 32)
1471 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1472
1473 p = s7_vector_ref_n(sc, p1, 3, 1LL, 1LL, 1LL);
1474 if (s7_integer(p) != 32)
1475 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1476
1477 s7_vector_set_n(sc, p1, TO_S7_INT(12), 3, 1LL, 1LL, 2LL);
1478 p = s7_vector_ref_n(sc, p1, 3, 1LL, 1LL, 2LL);
1479 if (s7_integer(p) != 12)
1480 {fprintf(stderr, "%d: %s is not 12?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1481
1482 if (s7_vector_length(p1) != 24)
1483 {fprintf(stderr, "%d: (length %s) is not 24?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1484 if (s7_vector_rank(p1) != 3)
1485 {fprintf(stderr, "%d: (vector-dimensions %s) is not 3?\n", __LINE__, s1 = TO_STR(p1)); free(s1);}
1486
1487 {
1488 s7_int *dims, *offs;
1489 s7_pointer *els;
1490 s7_int ndims;
1491
1492 ndims = s7_vector_rank(p1);
1493 dims = (s7_int *)malloc(ndims * sizeof(s7_int));
1494 offs = (s7_int *)malloc(ndims * sizeof(s7_int));
1495 s7_vector_dimensions(p1, dims, ndims);
1496 s7_vector_offsets(p1, offs, ndims);
1497 els = s7_vector_elements(p1);
1498
1499 if (dims[0] != 2) fprintf(stderr, "%d: dims[0]: %" print_s7_int "?\n", __LINE__, dims[0]);
1500 if (dims[1] != 3) fprintf(stderr, "%d: dims[1]: %" print_s7_int "?\n", __LINE__, dims[1]);
1501 if (dims[2] != 4) fprintf(stderr, "%d: dims[2]: %" print_s7_int "?\n", __LINE__, dims[2]);
1502 if (offs[0] != 12) fprintf(stderr, "%d: offs[0]: %" print_s7_int "?\n", __LINE__, offs[0]);
1503 if (offs[1] != 4) fprintf(stderr, "%d: offs[1]: %" print_s7_int "?\n", __LINE__, offs[1]);
1504 if (s7_integer(p = els[12 + 4 + 1]) != 32)
1505 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1506
1507 free(dims);
1508 free(offs);
1509 }
1510
1511 s7_vector_fill(sc, p1, s7_t(sc));
1512 p = s7_vector_ref_n(sc, p1, 3, 1LL, 1LL, 1LL);
1513 if (p != s7_t(sc))
1514 {fprintf(stderr, "%d: %s is not #t?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1515
1516
1517 {
1518 s7_pointer new_env, old_env;
1519 new_env = s7_sublet(sc, old_env = s7_curlet(sc), s7_nil(sc));
1520 gc_loc = s7_gc_protect(sc, new_env);
1521
1522 s7_define(sc, new_env, s7_make_symbol(sc, "var1"), s7_make_integer(sc, 32));
1523
1524 if (new_env == s7_curlet(sc))
1525 {fprintf(stderr, "%d: %s is the current env?\n", __LINE__, s1 = TO_STR(new_env)); free(s1);}
1526
1527 s1 = TO_STR(s7_let_to_list(sc, new_env));
1528 if (strcmp(s1, "((var1 . 32))") != 0)
1529 {fprintf(stderr, "%d: new-env is %s?\n", __LINE__, s1);}
1530 free(s1);
1531
1532 p = s7_let_ref(sc, new_env, s7_make_symbol(sc, "var1"));
1533 if (s7_integer(p) != 32)
1534 {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1535
1536 s7_let_set(sc, new_env, s7_make_symbol(sc, "var1"), TO_S7_INT(3));
1537 p = s7_let_ref(sc, new_env, s7_make_symbol(sc, "var1"));
1538 if (s7_integer(p) != 3)
1539 {fprintf(stderr, "%d: %s is not 3?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1540
1541 s7_set_curlet(sc, new_env);
1542 p = s7_slot(sc, s7_make_symbol(sc, "var1"));
1543 if (s7_integer(s7_slot_value(p)) != 3)
1544 {fprintf(stderr, "%d: slot-value %s is not 3?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1545
1546 s7_slot_set_value(sc, p, s7_f(sc));
1547 p = s7_let_ref(sc, new_env, s7_make_symbol(sc, "var1"));
1548 if (p != s7_f(sc))
1549 {fprintf(stderr, "%d: set slot-value %s is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1550
1551 if (s7_outlet(sc, new_env) != old_env)
1552 {fprintf(stderr, "%d: outer-env %s?\n", __LINE__, s1 = TO_STR(old_env)); free(s1);}
1553
1554 s7_make_slot(sc, new_env, s7_make_symbol(sc, "var2"), TO_S7_INT(-1));
1555 p = s7_let_ref(sc, new_env, s7_make_symbol(sc, "var2"));
1556 if (s7_integer(p) != -1)
1557 {fprintf(stderr, "%d: make_slot %s is not -1?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1558
1559 s7_symbol_set_value(sc, s7_make_symbol(sc, "var2"), s7_t(sc));
1560 p = s7_symbol_local_value(sc, s7_make_symbol(sc, "var2"), new_env);
1561 if (p != s7_t(sc))
1562 {fprintf(stderr, "%d: set symbol-value %s is not #t?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1563
1564 p = s7_let_to_list(sc, new_env);
1565 {
1566 int gloc;
1567 gloc = s7_gc_protect(sc, p);
1568 s1 = TO_STR(p);
1569 if (strcmp(s1, "((var1 . #f) (var2 . #t))") != 0)
1570 {fprintf(stderr, "%d: env->list: %s\n", __LINE__, s1);}
1571 free(s1);
1572 s7_gc_unprotect_at(sc, gloc);
1573 }
1574 s7_set_curlet(sc, old_env);
1575 s7_gc_unprotect_at(sc, gc_loc);
1576 }
1577
1578 if (!s7_is_list(sc, p = s7_load_path(sc)))
1579 {fprintf(stderr, "%d: %s is not a list?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1580
1581
1582 {
1583 s7_pointer port;
1584 port = s7_open_output_file(sc, "ffitest.scm", "w");
1585
1586 if (!s7_is_output_port(sc, port))
1587 {fprintf(stderr, "%d: %s is not an output port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
1588 else
1589 {
1590 /* (define loaded_var 321) hopefully */
1591 gc_loc = s7_gc_protect(sc, port);
1592 s7_write_char(sc, s7_make_character(sc, (uint8_t)'('), port);
1593 s7_write(sc, s7_make_symbol(sc, "define"), port);
1594 s7_write_char(sc, s7_make_character(sc, (uint8_t)' '), port);
1595 s7_display(sc, s7_make_symbol(sc, "loaded_var"), port);
1596 s7_write_char(sc, s7_make_character(sc, (uint8_t)' '), port);
1597 s7_format(sc, s7_list(sc, 3, port, s7_make_string(sc, "~A)"), TO_S7_INT(321)));
1598 s7_newline(sc, port);
1599 s7_flush_output_port(sc, port);
1600 s7_close_output_port(sc, port);
1601 s7_gc_unprotect_at(sc, gc_loc);
1602
1603 s7_load(sc, "ffitest.scm");
1604 if (!s7_is_defined(sc, "loaded_var"))
1605 {fprintf(stderr, "%d: load ffitest.scm unhappy?\n", __LINE__);}
1606 else
1607 {
1608 if (s7_integer(p = s7_name_to_value(sc, "loaded_var")) != 321)
1609 {fprintf(stderr, "%d: %s is not 321?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1610
1611 port = s7_open_input_file(sc, "ffitest.scm", "r");
1612 if (!s7_is_input_port(sc, port))
1613 {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
1614 else
1615 {
1616 uint8_t c;
1617 gc_loc = s7_gc_protect(sc, port);
1618 c = s7_character(s7_peek_char(sc, port));
1619 if (c != (int)'(')
1620 {fprintf(stderr, "%d: peek-char sees %c?\n", __LINE__, (unsigned char)c);}
1621
1622 c = s7_character(s7_read_char(sc, port));
1623 if (c != (uint8_t)'(')
1624 {fprintf(stderr, "%d: read-char sees %c?\n", __LINE__, (unsigned char)c);}
1625
1626 s7_close_input_port(sc, port);
1627 s7_gc_unprotect_at(sc, gc_loc);
1628
1629 port = s7_open_input_file(sc, "ffitest.scm", "r");
1630 gc_loc = s7_gc_protect(sc, port);
1631
1632 p = s7_read(sc, port);
1633 s1 = TO_STR(p);
1634 if (strcmp(s1, "(define loaded_var 321)") != 0)
1635 {fprintf(stderr, "%d: read file sees %s?\n", __LINE__, s1);}
1636 free(s1);
1637
1638 s7_close_input_port(sc, port);
1639 s7_gc_unprotect_at(sc, gc_loc);
1640 }
1641 }
1642 }
1643
1644 {
1645 s7_pointer e, val;
1646 e = s7_inlet(sc, s7_nil(sc));
1647 gc_loc = s7_gc_protect(sc, e);
1648 val = s7_load_with_environment(sc, "~/ffitest.scm", e);
1649 if (val)
1650 fprintf(stderr, "%d: load ~/ffitest.scm found!?\n", __LINE__);
1651 val = s7_load_with_environment(sc, "~/cl/ffitest.scm", e);
1652 if (!val)
1653 fprintf(stderr, "%d: load ~/cl/ffitest.scm not found\n", __LINE__);
1654 else
1655 {
1656 if (s7_symbol_local_value(sc, s7_make_symbol(sc, "loaded_var"), e) == s7_undefined(sc))
1657 {fprintf(stderr, "%d: load ~/ffitest.scm unhappy? %s\n", __LINE__, s1 = TO_STR(e)); free(s1);}
1658 }
1659 val = s7_load(sc, "/home/bil/snd-motif/");
1660 if (val)
1661 fprintf(stderr, "s7_load(directory) did not fail?\n");
1662 s7_gc_unprotect_at(sc, gc_loc);
1663 }
1664
1665 port = s7_open_input_string(sc, "(+ 1 2)");
1666 if (!s7_is_input_port(sc, port))
1667 {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
1668 gc_loc = s7_gc_protect(sc, port);
1669 p = s7_read(sc, port);
1670 s1 = TO_STR(p);
1671 if (strcmp(s1, "(+ 1 2)") != 0)
1672 {fprintf(stderr, "%d: read string sees %s?\n", __LINE__, s1);}
1673 free(s1);
1674 s7_close_input_port(sc, port);
1675 s7_gc_unprotect_at(sc, gc_loc);
1676
1677 /* make sure s7_read does not ignore #<eof> */
1678 port = s7_open_input_string(sc, "(define aaa 32)\n(define bbb 33)\n");
1679 if (!s7_is_input_port(sc, port))
1680 {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
1681 gc_loc = s7_gc_protect(sc, port);
1682 while(true)
1683 {
1684 s7_pointer code;
1685 code = s7_read(sc, port);
1686 if (code == s7_eof_object(sc)) break;
1687 s7_eval(sc, code, s7_nil(sc));
1688 }
1689 s7_close_input_port(sc, port);
1690 s7_gc_unprotect_at(sc, gc_loc);
1691
1692 port = s7_open_input_string(sc, "(define ccc 34)\n(define ddd 35)");
1693 if (!s7_is_input_port(sc, port))
1694 {fprintf(stderr, "%d: %s is not an input port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
1695 gc_loc = s7_gc_protect(sc, port);
1696 while(true)
1697 {
1698 s7_pointer code;
1699 code = s7_read(sc, port);
1700 if (code == s7_eof_object(sc)) break;
1701 s7_eval(sc, code, s7_nil(sc));
1702 }
1703 s7_close_input_port(sc, port);
1704 s7_gc_unprotect_at(sc, gc_loc);
1705 {
1706 s7_pointer val;
1707 val = s7_name_to_value(sc, "aaa");
1708 if ((!s7_is_integer(val)) || (s7_integer(val) != 32))
1709 fprintf(stderr, "aaa: %s\n", s7_object_to_c_string(sc, val));
1710 val = s7_name_to_value(sc, "bbb");
1711 if ((!s7_is_integer(val)) || (s7_integer(val) != 33))
1712 fprintf(stderr, "bbb: %s\n", s7_object_to_c_string(sc, val));
1713 val = s7_name_to_value(sc, "ccc");
1714 if ((!s7_is_integer(val)) || (s7_integer(val) != 34))
1715 fprintf(stderr, "ccc: %s\n", s7_object_to_c_string(sc, val));
1716 val = s7_name_to_value(sc, "ddd");
1717 if ((!s7_is_integer(val)) || (s7_integer(val) != 35))
1718 fprintf(stderr, "ddd: %s\n", s7_object_to_c_string(sc, val));
1719 }
1720
1721 port = s7_open_output_string(sc);
1722 if (!s7_is_output_port(sc, port))
1723 {fprintf(stderr, "%d: %s is not an output port?\n", __LINE__, s1 = TO_STR(port)); free(s1);}
1724 gc_loc = s7_gc_protect(sc, port);
1725 s7_display(sc, s7_make_string(sc, "(+ 2 3)"), port);
1726 {
1727 const char *s2;
1728 s2 = s7_get_output_string(sc, port);
1729 if (strcmp(s2, "(+ 2 3)") != 0)
1730 {fprintf(stderr, "%d: read output string sees %s?\n", __LINE__, s2);}
1731 }
1732 s7_close_output_port(sc, port);
1733 s7_gc_unprotect_at(sc, gc_loc);
1734
1735 p = s7_set_current_output_port(sc, s7_open_output_function(sc, my_print));
1736 p1 = s7_open_input_function(sc, my_read);
1737 gc_loc = s7_gc_protect(sc, p1);
1738
1739 s7_display(sc, s7_make_character(sc, '3'), s7_current_output_port(sc));
1740 if (last_c != '3')
1741 {fprintf(stderr, "%d: last_c: %c, c: %c\n", __LINE__, last_c, '3');}
1742 last_c = s7_character(s7_read_char(sc, p1));
1743 if (last_c != '0')
1744 {fprintf(stderr, "%d: last_c: %c\n", __LINE__, last_c);}
1745 s7_set_current_output_port(sc, p);
1746 s7_gc_unprotect_at(sc, gc_loc);
1747 }
1748
1749 {
1750 s7_pointer port, val;
1751 s7_autoload(sc, s7_make_symbol(sc, "auto_var"), s7_make_string(sc, "ffitest.scm"));
1752 port = s7_open_output_file(sc, "ffitest.scm", "w");
1753 gc_loc = s7_gc_protect(sc, port);
1754 s7_display(sc, s7_make_string(sc, "(define auto_var 123)"), port);
1755 s7_newline(sc, port);
1756 s7_close_output_port(sc, port);
1757 s7_gc_unprotect_at(sc, gc_loc);
1758 val = s7_eval_c_string(sc, "(+ auto_var 1)");
1759 if ((!s7_is_integer(val)) ||
1760 (s7_integer(val) != 124))
1761 {fprintf(stderr, "%d: auto_var+1 = %s?\n", __LINE__, s1 = TO_STR(val)); free(s1);}
1762 }
1763
1764 {
1765 s7_pointer test_hook;
1766 test_hook = s7_eval_c_string(sc, "(make-hook 'a 'b)");
1767 s7_define_constant(sc, "test-hook", test_hook);
1768 s7_hook_set_functions(sc, test_hook,
1769 s7_cons(sc, s7_make_function(sc, "test-hook-function", test_hook_function, 1, 0, false, "a test-hook function"),
1770 s7_hook_functions(sc, test_hook)));
1771 s7_call(sc, test_hook, s7_list(sc, 2, TO_S7_INT(1), TO_S7_INT(2)));
1772 s7_call_with_location(sc, test_hook, s7_list(sc, 2, TO_S7_INT(1), TO_S7_INT(2)), "ffitest", "ffitest.c", __LINE__);
1773 }
1774
1775 {
1776 s7_pointer x, y, funcs;
1777 funcs = s7_eval_c_string(sc, "(let ((x 0)) (list (lambda () (set! x 1)) (lambda () (set! x (+ x 1))) (lambda () (set! x (+ x 1))) (lambda () x)))");
1778 gc_loc = s7_gc_protect(sc, funcs);
1779 y = s7_dynamic_wind(sc, s7_car(funcs), s7_cadr(funcs), s7_caddr(funcs));
1780 x = s7_call(sc, s7_cadddr(funcs), s7_nil(sc));
1781 if ((!s7_is_integer(x)) ||
1782 (!s7_is_integer(y)) ||
1783 (s7_integer(x) != 3) ||
1784 (s7_integer(y) != 2))
1785 fprintf(stderr, "s7_dynamic_wind: x: %s, y: %s\n", s7_object_to_c_string(sc, x), s7_object_to_c_string(sc, y));
1786 y = s7_dynamic_wind(sc, s7_f(sc), s7_car(funcs), s7_cadr(funcs));
1787 x = s7_call(sc, s7_cadddr(funcs), s7_nil(sc));
1788 if ((!s7_is_integer(x)) ||
1789 (!s7_is_integer(y)) ||
1790 (s7_integer(x) != 2) ||
1791 (s7_integer(y) != 1))
1792 fprintf(stderr, "s7_dynamic_wind (init #f): x: %s, y: %s\n", s7_object_to_c_string(sc, x), s7_object_to_c_string(sc, y));
1793 y = s7_dynamic_wind(sc, s7_f(sc), s7_cadr(funcs), s7_f(sc));
1794 x = s7_call(sc, s7_cadddr(funcs), s7_nil(sc));
1795 if ((!s7_is_integer(x)) ||
1796 (!s7_is_integer(y)) ||
1797 (s7_integer(x) != 3) ||
1798 (s7_integer(y) != 3))
1799 fprintf(stderr, "s7_dynamic_wind (init #f, finish #f): x: %s, y: %s\n", s7_object_to_c_string(sc, x), s7_object_to_c_string(sc, y));
1800 y = s7_dynamic_wind(sc, s7_cadr(funcs), s7_cadr(funcs), s7_f(sc));
1801 x = s7_call(sc, s7_cadddr(funcs), s7_nil(sc));
1802 if ((!s7_is_integer(x)) ||
1803 (!s7_is_integer(y)) ||
1804 (s7_integer(x) != 5) ||
1805 (s7_integer(y) != 5))
1806 fprintf(stderr, "s7_dynamic_wind (finish #f): x: %s, y: %s\n", s7_object_to_c_string(sc, x), s7_object_to_c_string(sc, y));
1807 s7_gc_unprotect_at(sc, gc_loc);
1808 }
1809
1810 if (s7_begin_hook(sc))
1811 {fprintf(stderr, "%d: begin_hook is not null?\n", __LINE__);}
1812 tested_begin_hook = false;
1813 s7_set_begin_hook(sc, test_begin_hook);
1814 s7_eval_c_string(sc, "(begin #f (+ 1 2))");
1815 if (!tested_begin_hook)
1816 {fprintf(stderr, "%d: begin_hook not called?\n", __LINE__);}
1817 if (s7_begin_hook(sc) != test_begin_hook)
1818 {fprintf(stderr, "%d: begin_hook was not set?\n", __LINE__);}
1819 s7_set_begin_hook(sc, NULL);
1820
1821
1822 p1 = s7_name_to_value(sc, "abs");
1823 if (!s7_is_procedure(p1))
1824 {fprintf(stderr, "%d: (procedure? abs) = #f?\n", __LINE__);}
1825 if (s7_is_macro(sc, p1))
1826 {fprintf(stderr, "%d: (macro? abs) = #t?\n", __LINE__);}
1827
1828 if (!s7_is_aritable(sc, p1, 1))
1829 {fprintf(stderr, "%d: (aritable? abs 1) = #f?\n", __LINE__);}
1830 if (s7_is_aritable(sc, p1, 2))
1831 {fprintf(stderr, "%d: (aritable? abs 2) = #t?\n", __LINE__);}
1832
1833 p = s7_funclet(sc, p1);
1834 if (p != s7_rootlet(sc))
1835 {fprintf(stderr, "%d: (funclet abs) = %s?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1836
1837 {
1838 const char *s3;
1839 s3 = s7_documentation(sc, p1);
1840 if (strcmp(s3, "(abs x) returns the absolute value of the real number x") != 0)
1841 {fprintf(stderr, "%d: (documentation abs) = %s?\n", __LINE__, s3);}
1842
1843 s3 = s7_help(sc, p1);
1844 if (strcmp(s3, "(abs x) returns the absolute value of the real number x") != 0)
1845 {fprintf(stderr, "%d: (help abs) = %s?\n", __LINE__, s3);}
1846
1847 s3 = s7_documentation(sc, s7_make_symbol(sc, "abs"));
1848 if (strcmp(s3, "(abs x) returns the absolute value of the real number x") != 0)
1849 {fprintf(stderr, "%d: (documentation 'abs) = %s?\n", __LINE__, s3);}
1850 }
1851
1852 p = s7_eval_c_string(sc, "(lambda (a b . c) (+ a b (apply * c)))");
1853 gc_loc = s7_gc_protect(sc, p);
1854
1855 if (!s7_is_procedure(p))
1856 {fprintf(stderr, "%d: %s is not a procedure?\n", __LINE__, s1 = TO_STR(p)); free(s1);}
1857
1858 s1 = TO_STR(s7_closure_body(sc, p));
1859 if (strcmp(s1, "((+ a b (apply * c)))") != 0)
1860 {fprintf(stderr, "%d: s7_closure_body is %s?\n", __LINE__, s1);}
1861 free(s1);
1862
1863 s1 = TO_STR(s7_closure_args(sc, p));
1864 if (strcmp(s1, "(a b . c)") != 0)
1865 {fprintf(stderr, "%d: s7_closure_args is %s?\n", __LINE__, s1);}
1866 free(s1);
1867
1868 s1 = TO_STR(s7_closure_let(sc, p));
1869 if (strcmp(s1, "()") != 0)
1870 {fprintf(stderr, "%d: s7_closure_let is %s?\n", __LINE__, s1);}
1871 free(s1);
1872
1873 if (s7_closure_body(sc, s7_name_to_value(sc, "abs")) != s7_nil(sc))
1874 fprintf(stderr, "closure_body(abs) is not nil?\n");
1875 if (s7_closure_args(sc, s7_name_to_value(sc, "abs")) != s7_nil(sc))
1876 fprintf(stderr, "closure_args(abs) is not nil?\n");
1877 if (s7_closure_let(sc, s7_name_to_value(sc, "abs")) != s7_nil(sc))
1878 fprintf(stderr, "closure_let(abs) is not nil?\n");
1879
1880 if (!s7_is_aritable(sc, p, 2))
1881 {fprintf(stderr, "%d: aritable? lambda 2 = #f?\n", __LINE__);}
1882 if (s7_is_aritable(sc, p, 1))
1883 {fprintf(stderr, "%d: aritable? lambda 1 = #t?\n", __LINE__);}
1884
1885 s7_gc_unprotect_at(sc, gc_loc);
1886
1887 {
1888 /* iterators */
1889 s7_pointer iter, hash, x;
1890 s7_int gc1, gc2;
1891
1892 /* iterate over list */
1893 iter = s7_make_iterator(sc, s7_list(sc, 3, TO_S7_INT(1), TO_S7_INT(2), TO_S7_INT(3)));
1894 if (!s7_is_iterator(iter))
1895 fprintf(stderr, "%d: %s is not an iterator\n", __LINE__, TO_STR(iter));
1896 if (s7_iterator_is_at_end(sc, iter))
1897 fprintf(stderr, "%d: %s is prematurely done\n", __LINE__, TO_STR(iter));
1898 x = s7_iterate(sc, iter);
1899 if ((!s7_is_integer(x)) || (s7_integer(x) != 1))
1900 fprintf(stderr, "%d: %s should be 1\n", __LINE__, TO_STR(x));
1901 x = s7_iterate(sc, iter);
1902 if ((!s7_is_integer(x)) || (s7_integer(x) != 2))
1903 fprintf(stderr, "%d: %s should be 2\n", __LINE__, TO_STR(x));
1904 x = s7_iterate(sc, iter);
1905 if ((!s7_is_integer(x)) || (s7_integer(x) != 3))
1906 fprintf(stderr, "%d: %s should be 3\n", __LINE__, TO_STR(x));
1907 x = s7_iterate(sc, iter);
1908 if ((x != s7_eof_object(sc)) || (!s7_iterator_is_at_end(sc, iter)))
1909 fprintf(stderr, "%d: %s should be #<eof> and iter should be done\n", __LINE__, TO_STR(x));
1910
1911 /* iterate over hash table */
1912 hash = s7_make_hash_table(sc, 8);
1913 gc1 = s7_gc_protect(sc, hash);
1914 s7_hash_table_set(sc, hash, s7_make_symbol(sc, "a"), s7_make_integer(sc, 1));
1915 s7_hash_table_set(sc, hash, s7_make_symbol(sc, "b"), s7_make_integer(sc, 2));
1916 iter = s7_make_iterator(sc, hash);
1917 gc2 = s7_gc_protect(sc, iter);
1918 x = s7_iterate(sc, iter);
1919 if (!s7_is_pair(x))
1920 fprintf(stderr, "x: %s\n", s7_object_to_c_string(sc, x));
1921 x = s7_iterate(sc, iter);
1922 if (!s7_is_pair(x))
1923 fprintf(stderr, "x: %s\n", s7_object_to_c_string(sc, x));
1924 x = s7_iterate(sc, iter);
1925 if (!s7_is_eq(s7_eof_object(sc), x))
1926 fprintf(stderr, "x: %s\n", s7_object_to_c_string(sc, x));
1927 s7_gc_unprotect_at(sc, gc1);
1928 s7_gc_unprotect_at(sc, gc2);
1929 }
1930
1931 g_block_type = s7_make_c_type(sc, "<block>");
1932 s7_c_type_set_free(sc, g_block_type, g_block_free);
1933 s7_c_type_set_equal(sc, g_block_type, g_blocks_are_eql);
1934 s7_c_type_set_is_equal(sc, g_block_type, g_blocks_are_equal);
1935 s7_c_type_set_is_equivalent(sc, g_block_type, g_blocks_are_equivalent);
1936 s7_c_type_set_mark(sc, g_block_type, g_block_mark);
1937 s7_c_type_set_ref(sc, g_block_type, g_block_ref);
1938 s7_c_type_set_set(sc, g_block_type, g_block_set);
1939 s7_c_type_set_length(sc, g_block_type, g_block_length);
1940 s7_c_type_set_copy(sc, g_block_type, g_block_copy);
1941 s7_c_type_set_reverse(sc, g_block_type, g_block_reverse);
1942 s7_c_type_set_fill(sc, g_block_type, g_block_fill);
1943 s7_c_type_set_to_string(sc, g_block_type, g_block_to_string);
1944
1945 s7_define_function(sc, "make-block", g_make_block, 1, 0, false, g_make_block_help);
1946 s7_define_function(sc, "block", g_to_block, 0, 0, true, g_block_help);
1947
1948 g_block_methods = s7_eval_c_string(sc, "(inlet (cons 'vector? (lambda (p) #t)))");
1949 s7_gc_protect(sc, g_block_methods);
1950
1951 {
1952 g_block *g;
1953 s7_pointer gp;
1954
1955 gp = g_make_block(sc, s7_list(sc, 1, TO_S7_INT(32)));
1956 gc_loc = s7_gc_protect(sc, gp);
1957 if (!s7_is_c_object(gp))
1958 {fprintf(stderr, "%d: g_block %s is not a c_object?\n", __LINE__, s1 = TO_STR(gp)); free(s1);}
1959 g = (g_block *)s7_c_object_value(gp);
1960 if (s7_c_object_type(gp) != g_block_type)
1961 {fprintf(stderr, "%d: g_block types: %" print_s7_int " %" print_s7_int "\n", __LINE__, g_block_type, s7_c_object_type(gp));}
1962 if (s7_c_object_value_checked(gp, g_block_type) != g)
1963 {fprintf(stderr, "%d: checked g_block types: %" print_s7_int " %" print_s7_int "\n", __LINE__, g_block_type, s7_c_object_type(gp));}
1964
1965 s7_gc_unprotect_at(sc, gc_loc);
1966 }
1967
1968 {
1969 s7_pointer old_port;
1970 const char *errmsg = NULL;
1971
1972 old_port = s7_set_current_error_port(sc, s7_open_output_string(sc));
1973 gc_loc = s7_gc_protect(sc, old_port);
1974
1975 s7_eval_c_string(sc, "(+ 1 #\\c)");
1976 errmsg = s7_get_output_string(sc, s7_current_error_port(sc));
1977 if (!errmsg)
1978 fprintf(stderr, "%d: no error!\n", __LINE__);
1979
1980 s7_close_output_port(sc, s7_current_error_port(sc));
1981 s7_set_current_error_port(sc, old_port);
1982 s7_gc_unprotect_at(sc, gc_loc);
1983 }
1984
1985 {
1986 int gc_loc1;
1987 s7_pointer old_port, result, func;
1988 const char *errmsg = NULL;
1989
1990 s7_define_function(sc, "error-handler", test_error_handler, 1, 0, false, "our error handler");
1991
1992 s7_eval_c_string(sc, "(set! (hook-functions *error-hook*) \n\
1993 (list (lambda (hook) \n\
1994 (error-handler \n\
1995 (string-append \"hook: \" (apply format #f (hook 'data)))) \n\
1996 (set! (hook 'result) 'our-error))))");
1997
1998 old_port = s7_set_current_error_port(sc, s7_open_output_string(sc));
1999 gc_loc = s7_gc_protect(sc, old_port);
2000
2001 result = s7_eval_c_string(sc, "(+ 1 #\\c)");
2002 if (result != s7_make_symbol(sc, "our-error"))
2003 {fprintf(stderr, "%d: error hook result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
2004 errmsg = s7_get_output_string(sc, s7_current_error_port(sc));
2005 if ((errmsg) && (*errmsg))
2006 {
2007 if (strcmp(errmsg, "error!") != 0)
2008 fprintf(stderr, "%d: error: %s\n", __LINE__, errmsg);
2009 }
2010 else fprintf(stderr, "%d: no error!\n", __LINE__);
2011
2012 s7_close_output_port(sc, s7_current_error_port(sc));
2013 s7_set_current_error_port(sc, old_port);
2014 s7_gc_unprotect_at(sc, gc_loc);
2015
2016
2017 old_port = s7_set_current_error_port(sc, s7_open_output_string(sc));
2018 gc_loc = s7_gc_protect(sc, old_port);
2019
2020 func = s7_eval_c_string(sc, "(lambda (x) (+ x 1))");
2021 result = s7_call(sc, func, s7_list(sc, 1, s7_make_integer(sc, 2)));
2022 if ((!s7_is_integer(result)) || (s7_integer(result) != 3))
2023 {fprintf(stderr, "%d: s7_call (x+1) result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
2024
2025 result = s7_call(sc, func, s7_list(sc, 1, s7_make_vector(sc, 0)));
2026 if (result != s7_make_symbol(sc, "our-error"))
2027 {fprintf(stderr, "%d: s7_call error hook result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
2028 errmsg = s7_get_output_string(sc, s7_current_error_port(sc));
2029 if ((errmsg) && (*errmsg))
2030 {
2031 if (strcmp(errmsg, "error!") != 0)
2032 fprintf(stderr, "%d: error: %s\n", __LINE__, errmsg);
2033 }
2034 else fprintf(stderr, "%d: no error!\n", __LINE__);
2035
2036 s7_close_output_port(sc, s7_current_error_port(sc));
2037 s7_set_current_error_port(sc, old_port);
2038 s7_gc_unprotect_at(sc, gc_loc);
2039
2040
2041 old_port = s7_set_current_error_port(sc, s7_open_output_string(sc));
2042 gc_loc = s7_gc_protect(sc, old_port);
2043
2044 func = s7_eval_c_string(sc, "(let ((x 0)) (list (lambda () (set! x 1)) (lambda () (set! x (+ x #()))) (lambda () (set! x (+ x 1))) (lambda () x)))");
2045 gc_loc1 = s7_gc_protect(sc, func);
2046 result = s7_dynamic_wind(sc, s7_car(func), s7_cadr(func), s7_caddr(func));
2047
2048 if (result != s7_make_symbol(sc, "our-error"))
2049 {fprintf(stderr, "%d: s7_dynamic_wind error hook result: %s\n", __LINE__, s1 = TO_STR(result)); free(s1);}
2050 errmsg = s7_get_output_string(sc, s7_current_error_port(sc));
2051 if ((errmsg) && (*errmsg))
2052 {
2053 if (strcmp(errmsg, "error!") != 0)
2054 fprintf(stderr, "%d: error: %s\n", __LINE__, errmsg);
2055 }
2056 else fprintf(stderr, "%d: no error!\n", __LINE__);
2057
2058 s7_close_output_port(sc, s7_current_error_port(sc));
2059 s7_set_current_error_port(sc, old_port);
2060 s7_gc_unprotect_at(sc, gc_loc);
2061 s7_gc_unprotect_at(sc, gc_loc1);
2062
2063
2064 s7_eval_c_string(sc, "(set! (hook-functions *error-hook*) ())");
2065 }
2066
2067 #if WITH_GMP
2068 s7_define_function(sc, "add-1", big_add_1, 1, 0, false, "(add-1 num) adds 1 to num");
2069 p = s7_eval_c_string(sc, "(add-1 (*s7* 'most-positive-fixnum))");
2070 if ((!s7_is_bignum(p)) || (!s7_is_big_integer(p))) {fprintf(stderr, "add-1: %s\n", s1 = TO_STR(p)); free(s1);}
2071 {
2072 mpz_t val, val1;
2073 mpz_init_set(val, *s7_big_integer(p));
2074 mpz_init(val1);
2075 mpz_set_si(val1, s7_integer(s7_let_field_ref(sc, s7_make_symbol(sc, "most-positive-fixnum"))));
2076 mpz_add_ui(val1, val1, 1);
2077 if (mpz_cmp(val, val1) != 0) {fprintf(stderr, "add-1: %s\n", s1 = TO_STR(p)); free(s1);}
2078 mpz_clear(val);
2079 mpz_clear(val1);
2080 }
2081 #endif
2082
2083 s7_define_function(sc, "notify-C", scheme_set_notification, 2, 0, false, "called if notified-var is set!");
2084 s7_define_variable(sc, "notified-var", s7_make_integer(sc, 0));
2085 s7_set_setter(sc, s7_make_symbol(sc, "notified-var"), s7_name_to_value(sc, "notify-C"));
2086 s7_eval_c_string(sc, "(set! notified-var 32)");
2087 p = s7_name_to_value(sc, "notified-var");
2088 if (s7_integer(p) != 32)
2089 {fprintf(stderr, "%d: sym set: %s\n", __LINE__, s1 = TO_STR(p)); free(s1);}
2090 if (s7_integer(set_val) != 32)
2091 {fprintf(stderr, "%d: sym val: %s\n", __LINE__, s1 = TO_STR(set_val)); free(s1);}
2092 if (set_sym != s7_make_symbol(sc, "notified-var"))
2093 {fprintf(stderr, "%d: sym: %s\n", __LINE__, s1 = TO_STR(set_sym)); free(s1);}
2094
2095 {
2096 s7_pointer e, val;
2097 e = s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "init_func"), s7_make_symbol(sc, "block_init")));
2098 gc_loc = s7_gc_protect(sc, e);
2099 val = s7_load_with_environment(sc, "s7test-block.so", e);
2100 if (!val)
2101 fprintf(stderr, "can't load s7test-block.so\n");
2102 s7_gc_unprotect_at(sc, gc_loc);
2103 }
2104
2105 {
2106 s7_pointer body, err, result;
2107 body = s7_eval_c_string(sc, "(lambda () (+ 1 2))");
2108 err = s7_eval_c_string(sc, "(lambda (type info) 'oops)");
2109 result = s7_call_with_catch(sc, s7_t(sc), body, err);
2110 if ((!s7_is_integer(result)) || (s7_integer(result) != 3))
2111 {fprintf(stderr, "catch (3): %s\n", s1 = TO_STR(result)); free(s1);}
2112
2113 body = s7_eval_c_string(sc, "(lambda () (+ #f 2))");
2114 err = s7_eval_c_string(sc, "(lambda (type info) 'oops)");
2115 result = s7_call_with_catch(sc, s7_t(sc), body, err);
2116 if (result != s7_make_symbol(sc, "oops"))
2117 {fprintf(stderr, "catch (oops): %s\n", s1 = TO_STR(result)); free(s1);}
2118 }
2119
2120 {
2121 const char *str;
2122 s7_pointer obj;
2123 obj = s7_eval_c_string(sc, "'(* 3 (+ 1 2))");
2124 gc_loc = s7_gc_protect(sc, obj);
2125 str = pretty_print(sc, obj);
2126 s7_gc_unprotect_at(sc, gc_loc);
2127 if ((!str) || (strcmp(str, "(* 3 (+ 1 2))") != 0))
2128 fprintf(stderr, "pretty_print: \"%s\"\n", str);
2129 }
2130
2131 {
2132 s7_int size = 256, gc_loc, loc, code;
2133 s7_pointer hasher, key, result;
2134 hasher = s7_make_and_fill_vector(sc, size, s7_nil(sc));
2135 gc_loc = s7_gc_protect(sc, hasher);
2136 key = s7_make_integer(sc, 3);
2137 code = s7_hash_code(sc, key, s7_f(sc));
2138 loc = code % size;
2139 s7_vector_set(sc, hasher, loc, s7_cons(sc, s7_cons(sc, key, s7_make_symbol(sc, "abc")), s7_vector_ref(sc, hasher, loc)));
2140 result = s7_cdr(s7_assoc(sc, key, s7_vector_ref(sc, hasher, loc)));
2141 if (result != s7_make_symbol(sc, "abc"))
2142 fprintf(stderr, "hash-code: %s\n", s7_object_to_c_string(sc, result));
2143 s7_gc_unprotect_at(sc, gc_loc);
2144 }
2145
2146 s7_free(sc);
2147
2148 return(0);
2149 }
2150
2151