1 /* xen support procedures */
2
3 #include "mus-config.h"
4 #include <ctype.h>
5 #include <string.h>
6 #include <stdio.h>
7 #include <stdlib.h>
8 #include <sys/types.h>
9 #include <math.h>
10 #include <time.h>
11
12 #ifdef _MSC_VER
13 #include <io.h>
14 #include <process.h>
15 #pragma warning(disable: 4244)
16 #endif
17
18 #include "xen.h"
19
20 #define S_gc_off "gc-off"
21 #define S_gc_on "gc-on"
22
23
xen_strdup(const char * str)24 char *xen_strdup(const char *str)
25 {
26 char *newstr = NULL;
27 if ((!str) || (!(*str))) return(NULL);
28 newstr = (char *)malloc(strlen(str) + 1);
29 if (newstr) strcpy(newstr, str);
30 return(newstr);
31 }
32
33
34
35 /* ------------------------------ RUBY ------------------------------ */
36
37 #if HAVE_RUBY
38
39 #define HAVE_RB_PROC_NEW 1
40 /* As the README says, only versions of ruby 1.8 or later will work */
41
42 #if USE_SND
43 void snd_rb_raise(Xen type, Xen info); /* XEN_ERROR */
44 #endif
45
46 #define S_add_help "add_help"
47 #define S_get_help "get_help"
48
rb_documentation(Xen name)49 Xen rb_documentation(Xen name)
50 {
51 Xen_check_type((Xen_is_string(name) || Xen_is_symbol(name)), name, 1, S_get_help, "a char* or symbol");
52 if (Xen_is_symbol(name))
53 return(rb_property(XEN_SYMBOL_TO_STRING(name), Xen_documentation_symbol));
54 else
55 return(rb_property(name, Xen_documentation_symbol));
56 }
57
58
rb_set_documentation(Xen name,Xen help)59 Xen rb_set_documentation(Xen name, Xen help)
60 {
61 Xen_check_type((Xen_is_string(name) || Xen_is_symbol(name)), name, 1, S_add_help, "a char* or symbol");
62 Xen_check_type(Xen_is_string(help), help, 2, S_add_help, "a char*");
63 if (Xen_is_symbol(name))
64 rb_set_property(XEN_SYMBOL_TO_STRING(name), Xen_documentation_symbol, help);
65 else
66 rb_set_property(name, Xen_documentation_symbol, help);
67 return(name);
68 }
69
70
g_add_help(Xen name,Xen help)71 static Xen g_add_help(Xen name, Xen help)
72 {
73 #define H_add_help S_add_help "(name, help) add help to topic or function name (String or Symbol)"
74 return(rb_set_documentation(name, help));
75 }
76
77
g_get_help(Xen name)78 static Xen g_get_help(Xen name)
79 {
80 #define H_get_help S_get_help "([name=:" S_get_help "]) \
81 return help associated with name (String or Symbol) or false"
82 if (!Xen_is_bound(name))
83 return(C_string_to_Xen_string(H_get_help));
84 else
85 return(rb_documentation(name));
86 }
87
88
xen_initialize(void)89 void xen_initialize(void)
90 {
91 int argc = 4;
92 const char *argv[] = {"xen", "--disable-gems", "-e", ";"};
93
94 #ifdef RUBY_INIT_STACK
95 RUBY_INIT_STACK;
96 #endif
97
98 ruby_init();
99 ruby_options(argc, (char **)argv);
100 Init_Hook();
101 }
102
103
xen_gc_mark(Xen val)104 void xen_gc_mark(Xen val)
105 {
106 rb_gc_mark(val);
107 }
108
109
xen_rb_cdr(Xen val)110 Xen xen_rb_cdr(Xen val)
111 {
112 if (Xen_is_cons(val))
113 {
114 Xen new_list;
115 new_list = Xen_copy_arg(val);
116 rb_ary_delete_at(new_list, 0);
117 return(new_list);
118 }
119 return(val);
120 }
121
122
xen_rb_cons(Xen arg1,Xen arg2)123 Xen xen_rb_cons(Xen arg1, Xen arg2)
124 {
125 if (Xen_is_null(arg2))
126 return(rb_ary_new3(1, arg1));
127 if (!(Xen_is_cons(arg2)))
128 return(rb_ary_new3(2, arg1, arg2));
129 return(rb_ary_unshift(arg2, arg1)); /* arg2 assumed to be array here in Ruby */
130 }
131
132
xen_rb_cons2(Xen arg1,Xen arg2,Xen arg3)133 Xen xen_rb_cons2(Xen arg1, Xen arg2, Xen arg3)
134 {
135 return(rb_ary_unshift(xen_rb_cons(arg2, arg3), arg1));
136 }
137
138
xen_rb_ary_new_with_initial_element(long num,Xen element)139 Xen xen_rb_ary_new_with_initial_element(long num, Xen element)
140 {
141 Xen arr;
142 int i;
143 arr = rb_ary_new2(num);
144 for (i = 0; i < num; i++)
145 rb_ary_store(arr, i, element);
146 return(arr);
147 }
148
149
xen_set_assoc(Xen key,Xen val,Xen alist)150 Xen xen_set_assoc(Xen key, Xen val, Xen alist)
151 {
152 /* assoc key val in alist so later rb_ary_assoc will find val given key in alist */
153 /*
154 if array?(alist)
155 if array?(item = alist.assoc(key))
156 item[1] = val
157 else
158 alist.push([key, val])
159 end
160 else
161 [[key, val]]
162 end
163 */
164 if (Xen_is_cons(alist))
165 {
166 Xen pair;
167 pair = rb_ary_assoc(alist, key);
168 if (Xen_is_cons(pair))
169 rb_ary_store(pair, 1, val);
170 else rb_ary_push(alist, rb_assoc_new(key, val));
171 return(alist);
172 }
173 return(rb_ary_new3(1, rb_assoc_new(key, val)));
174 }
175
176
xen_assoc(Xen key,Xen alist)177 Xen xen_assoc(Xen key, Xen alist)
178 {
179 if (Xen_is_cons(alist))
180 {
181 Xen val;
182 val = rb_ary_assoc(alist, key);
183 if (val != Qnil)
184 return(rb_ary_entry(val, 1));
185 }
186 return(Qfalse);
187 }
188
189
scheme_to_ruby(const char * name)190 static char *scheme_to_ruby(const char *name)
191 {
192 /* replace any non-alphanumeric except "?" with "_". "?" -> "_p". '->" -> "2" drop "!" */
193 char *new_name = NULL;
194 int len;
195 len = strlen(name);
196 if (len > 0)
197 {
198 int i, j;
199 new_name = (char *)calloc(len + 3, sizeof(char)); /* +1 for possible _p, +1 for possible $ */
200 for (i = 0, j = 0; i < len; i++)
201 {
202 if (isalnum(name[i]))
203 new_name[j++] = name[i];
204 else
205 {
206 if (name[i] != '!')
207 {
208 if ((name[i] == '-') &&
209 (name[i + 1] == '>'))
210 {
211 new_name[j++] = '2';
212 i++;
213 }
214 else
215 {
216 new_name[j++] = '_';
217 if (name[i] == '?')
218 new_name[j++] = 'p';
219 }
220 }
221 }
222 }
223 }
224 return(new_name);
225 }
226
227
xen_scheme_constant_to_ruby(const char * name)228 char *xen_scheme_constant_to_ruby(const char *name)
229 {
230 /* upcase first char */
231 char *new_name;
232 new_name = scheme_to_ruby(name);
233 new_name[0] = toupper(new_name[0]);
234 return(new_name);
235 }
236
237
xen_scheme_procedure_to_ruby(const char * name)238 char *xen_scheme_procedure_to_ruby(const char *name)
239 {
240 char *new_name = NULL;
241 int len;
242 len = name ? strlen(name) : 0;
243 if (len > 0)
244 {
245 int i, j;
246 new_name = (char *)calloc(len + 1, sizeof(char));
247 for (i = 0, j = 0; i < len; i++)
248 {
249 if ((isalnum(name[i])) || (name[i] == '!') || (name[i] == '?'))
250 new_name[j++] = name[i];
251 else
252 {
253 if ((name[i] == '-') &&
254 (name[i + 1] == '>'))
255 {
256 new_name[j++] = '2';
257 i++;
258 }
259 else new_name[j++] = '_';
260 }
261 }
262 }
263 return(new_name);
264 }
265
266
xen_scheme_global_variable_to_ruby(const char * name)267 char *xen_scheme_global_variable_to_ruby(const char *name)
268 {
269 /* prepend $ */
270 char *new_name;
271 new_name = scheme_to_ruby(name);
272 if (new_name[0] == '_')
273 new_name[0] = '$';
274 else
275 {
276 int i, len;
277 len = strlen(new_name);
278 for (i = len; i > 0; i--)
279 new_name[i] = new_name[i - 1];
280 new_name[0] = '$';
281 }
282 return(new_name);
283 }
284
285
286 /* looks for global variables and constants (functions too?) */
287
xen_rb_defined_p(const char * name)288 bool xen_rb_defined_p(const char *name)
289 {
290 char *var_name = scheme_to_ruby(name);
291 char buf[128];
292
293 if (var_name[0] == '$')
294 snprintf(buf, 128, "defined? %s", var_name);
295 else snprintf(buf, 128, "defined? $%s", var_name);
296
297 if (Xen_eval_C_string(buf) != Qnil)
298 {
299 free(var_name);
300 return(true);
301 }
302 else
303 {
304 bool val;
305 var_name[0] = toupper(var_name[0]);
306 val = rb_const_defined(rb_cObject, rb_intern(var_name));
307 free(var_name);
308 return(val);
309 }
310 }
311
312
xen_rb_gv_get(const char * name)313 Xen xen_rb_gv_get(const char *name)
314 {
315 char *temp;
316 Xen val;
317 temp = xen_scheme_global_variable_to_ruby(name);
318 val = rb_gv_get(temp);
319 if (temp) free(temp);
320 return(val);
321 }
322
323
xen_rb_gv_set(const char * name,Xen new_val)324 Xen xen_rb_gv_set(const char *name, Xen new_val)
325 {
326 char *temp;
327 Xen val;
328 temp = xen_scheme_global_variable_to_ruby(name);
329 val = rb_gv_set(temp, new_val);
330 if (temp) free(temp);
331 return(val);
332 }
333
334
xen_rb_intern(const char * name)335 Xen xen_rb_intern(const char *name)
336 {
337 char *temp;
338 Xen val;
339 temp = xen_scheme_constant_to_ruby(name);
340 val = rb_intern(temp);
341 if (temp) free(temp);
342 return(val);
343 }
344
345
xen_rb_make_keyword(const char * name)346 Xen xen_rb_make_keyword(const char *name)
347 {
348 char *temp;
349 Xen val;
350 temp = xen_scheme_procedure_to_ruby(name);
351 val = C_string_to_Xen_symbol(temp);
352 if (temp) free(temp);
353 return(val);
354 }
355
356
xen_rb_define(const char * name,Xen value)357 void xen_rb_define(const char *name, Xen value)
358 {
359 char *temp;
360 temp = xen_scheme_constant_to_ruby(name);
361 rb_define_global_const(temp, value);
362 if (temp) free(temp);
363 }
364
365
xen_rb_define_class(const char * name)366 Xen xen_rb_define_class(const char *name)
367 {
368 char *temp;
369 Xen val;
370 temp = xen_scheme_constant_to_ruby(name);
371 val = rb_define_class(temp, rb_cObject);
372 if (temp) free(temp);
373 return(val);
374 }
375
376
377
378
379 #ifndef RARRAY_PTR
380 #define RB_ARRAY_PTR(Ary) RARRAY(Ary)->ptr
381 #define RB_ARRAY_LEN(Ary) RARRAY(Ary)->len
382 #else
383 #define RB_ARRAY_PTR(Ary) RARRAY_PTR(Ary)
384 #define RB_ARRAY_LEN(Ary) RARRAY_LEN(Ary)
385 #endif
386
387
xen_rb_list_length(Xen obj)388 int xen_rb_list_length(Xen obj)
389 {
390 if (Xen_is_vector(obj))
391 return((int)RB_ARRAY_LEN(obj));
392 if (obj == Xen_empty_list)
393 return(0);
394 return(-1);
395 }
396
397
xen_rb_list_ref(Xen obj,int index)398 Xen xen_rb_list_ref(Xen obj, int index)
399 {
400 if (Xen_is_vector(obj))
401 return(rb_ary_entry(obj, (long)index));
402 return(Xen_empty_list);
403 }
404
405
xen_rb_list_set(Xen obj,int index,Xen value)406 Xen xen_rb_list_set(Xen obj, int index, Xen value)
407 {
408 if (Xen_is_vector(obj))
409 rb_ary_store(obj, (long)index, value);
410 return(value);
411 }
412
413
xen_version(void)414 char *xen_version(void)
415 {
416 /* there is no macro we can depend on for the version number (its name changes unpredictably),
417 * and ruby/version.h tries to be funny about how unreliable their semi-functional access is.
418 * Maybe use <ruby/version.h> and ruby_version here (a const char*).
419 * No, even that doesn't work because there's no way to tell whether version.h exists.
420 * Humph!
421 */
422 char *buf;
423 buf = (char *)calloc(128, sizeof(char));
424 snprintf(buf, 128, "%s", "Ruby");
425 return(buf);
426 }
427
428
xen_rb_report_error(Xen nada,Xen err_info)429 static Xen xen_rb_report_error(Xen nada, Xen err_info)
430 {
431 /* backtrace info: */
432 /* return rb_funcall(err_info, rb_intern("backtrace"), 0); */
433 /* which can be an array of strings */
434
435 fprintf(stderr,"error: %s\n", Xen_object_to_C_string(err_info));
436 return(Xen_false);
437 }
438
439
440 static char *rb_prompt = NULL;
441
xen_rb_rep(Xen ig)442 static Xen xen_rb_rep(Xen ig)
443 {
444 Xen val;
445 char *str, *res;
446 size_t size = 512;
447 char **buffer;
448 buffer = (char **)calloc(1, sizeof(char *));
449 buffer[0] = (char *)calloc(size, sizeof(char));
450 fprintf(stdout, "%s", rb_prompt);
451 res = fgets(buffer[0], size, stdin); /* check result to make compiler happy */
452 if (!res) fprintf(stderr, "fgets returns null\n");
453 val = xen_rb_eval_string_with_error(buffer[0]);
454 str = Xen_object_to_C_string(val);
455 fprintf(stdout, "%s\n", (str) ? str : "nil");
456 free(buffer[0]);
457 free(buffer);
458 return(ig);
459 }
460
461
xen_rb_repl_set_prompt(const char * prompt)462 void xen_rb_repl_set_prompt(const char *prompt)
463 {
464 if (rb_prompt) free(rb_prompt);
465 rb_prompt = xen_strdup(prompt);
466 }
467
468
xen_rb_rescue(Xen val)469 static Xen xen_rb_rescue(Xen val)
470 {
471 if (!rb_prompt) rb_prompt = xen_strdup(">");
472 return(rb_rescue(Xen_procedure_cast xen_rb_rep,
473 Xen_false,
474 Xen_procedure_cast xen_rb_report_error,
475 Xen_false));
476 }
477
478
xen_repl(int argc,char ** argv)479 void xen_repl(int argc, char **argv)
480 {
481 while (true)
482 {
483 int status = 0;
484 rb_protect(XEN_VALUE_ARG_PROCEDURE_CAST xen_rb_rescue,
485 Xen_false,
486 &status);
487 if (status != 0)
488 {
489 fprintf(stderr, "%s\n", Xen_object_to_C_string(rb_gv_get("$!")));
490 status = 0;
491 }
492 }
493 }
494
495
xen_rb_eval_string_with_error(const char * str)496 Xen xen_rb_eval_string_with_error(const char *str)
497 {
498 int status = 0;
499 Xen res;
500 res = rb_eval_string_protect(str, &status);
501 if (status != 0)
502 return(xen_rb_obj_as_string(rb_gv_get("$!")));
503 return(res);
504 }
505
506
xen_rb_load_file_with_error(const char * file)507 void xen_rb_load_file_with_error(const char *file)
508 {
509 int status = 0, i;
510 Xen err, info;
511 rb_load_protect(C_string_to_Xen_string(file), 0, &status);
512 if (status == 0)
513 return;
514 fprintf(stderr, "Can't load %s", file);
515 err = rb_gv_get("$!");
516 if (err != Qnil)
517 fprintf(stderr, ": %s", Xen_object_to_C_string(err));
518 fprintf(stderr, "\n");
519 info = rb_gv_get("$@");
520 if (info == Qnil)
521 return;
522 for (i = 0; i < Xen_vector_length(info); i++)
523 fprintf(stderr, "%s\n", Xen_string_to_C_string(Xen_vector_ref(info, i)));
524 }
525
526
xen_rb_add_to_load_path(char * path)527 Xen xen_rb_add_to_load_path(char *path)
528 {
529 Xen rpath, load_path;
530 rpath = rb_str_new2(path);
531 load_path = rb_gv_get("$:");
532 if (Xen_is_false(rb_ary_includes(load_path, rpath)))
533 rb_ary_unshift(load_path, rpath);
534 return(Xen_false);
535 }
536
537
538 static char *lstbuf = NULL;
539
xen_rb_list_to_s(Xen lst)540 static char *xen_rb_list_to_s(Xen lst)
541 {
542 int i, len;
543 if (!lstbuf)
544 lstbuf = (char *)calloc(512, sizeof(char));
545 else lstbuf[0] = '\0';
546 len = Xen_list_length(lst);
547 for (i = 0; i < len; i++)
548 {
549 strcat(lstbuf, Xen_object_to_C_string(Xen_list_ref(lst, i)));
550 strcat(lstbuf, " ");
551 }
552 return(lstbuf);
553 }
554
555
xen_rb_raise(Xen type,Xen info)556 void xen_rb_raise(Xen type, Xen info)
557 {
558 rb_raise(rb_eStandardError, "%s: %s\n",
559 rb_id2name(type),
560 xen_rb_list_to_s(info));
561 }
562
563
xen_rb_required_args(Xen val)564 int xen_rb_required_args(Xen val)
565 {
566 int args;
567 args = Xen_integer_to_C_int(val);
568 if (args == -1) return(1);
569 if (args < 0) return(abs(args + 1));
570 return(args);
571 }
572
573
xen_rb_obj_as_string(Xen obj)574 Xen xen_rb_obj_as_string(Xen obj)
575 {
576 int status = 0;
577 Xen result;
578 result = rb_protect(XEN_VALUE_ARG_PROCEDURE_CAST rb_obj_as_string,
579 obj,
580 &status);
581 if (status != 0)
582 return(C_string_to_Xen_string("<invalid object>"));
583 return(result);
584 }
585
586
587 #if HAVE_RB_PROC_NEW
588
xen_rb_apply_1(Xen args)589 static Xen xen_rb_apply_1(Xen args)
590 {
591 return(rb_apply(Xen_car(args), rb_intern("call"), Xen_cadr(args)));
592 }
593
594 #else
595
xen_rb_apply_1(Xen args)596 static Xen xen_rb_apply_1(Xen args)
597 {
598 if (Xen_is_procedure(Xen_car(args)))
599 return(rb_apply(Xen_car(args), rb_intern("call"), Xen_cadr(args)));
600 return(rb_apply(rb_mKernel, Xen_car(args), Xen_cadr(args)));
601 }
602
603 #endif
604
605
xen_rb_apply(Xen func,Xen args)606 Xen xen_rb_apply(Xen func, Xen args)
607 {
608 Xen val;
609 int status = 0;
610 val = rb_protect(XEN_VALUE_ARG_PROCEDURE_CAST xen_rb_apply_1,
611 Xen_list_2(func, args),
612 &status);
613 if (status != 0)
614 return(xen_rb_obj_as_string(rb_gv_get("$!")));
615 return(val);
616 }
617
618
xen_rb_funcall_0_inner(Xen args)619 static Xen xen_rb_funcall_0_inner(Xen args)
620 {
621 return(rb_funcall(args, rb_intern("call"), 0));
622 }
623
624
xen_rb_funcall_0(Xen func)625 Xen xen_rb_funcall_0(Xen func)
626 {
627 Xen val;
628 int status = 0;
629 val = rb_protect(XEN_VALUE_ARG_PROCEDURE_CAST xen_rb_funcall_0_inner,
630 func,
631 &status);
632 if (status != 0)
633 return(xen_rb_obj_as_string(rb_gv_get("$!")));
634 return(val);
635 }
636
637
xen_rb_copy_list(Xen val)638 Xen xen_rb_copy_list(Xen val)
639 {
640 if ((val == Xen_empty_list) || (!Xen_is_cons(val)))
641 return Xen_empty_list;
642 return rb_ary_dup(val);
643 }
644
645
xen_rb_str_new2(char * arg)646 Xen xen_rb_str_new2(char *arg)
647 {
648 return(rb_str_new2((arg) ? arg : ""));
649 }
650
651
652 /* class Hook */
653
654 static Xen xen_rb_cHook;
655
hook_alloc(Xen klass)656 static Xen hook_alloc(Xen klass)
657 {
658 return(Data_Wrap_Struct(klass, 0, 0, 0));
659 }
660
661
662 #define Xen_is_class_hook(Arg) rb_obj_is_kind_of(Arg, xen_rb_cHook)
663
xen_rb_hook_p(Xen obj)664 bool xen_rb_hook_p(Xen obj)
665 {
666 return(Xen_is_class_hook(obj));
667 }
668
669
xen_rb_hook_empty_p(Xen obj)670 bool xen_rb_hook_empty_p(Xen obj)
671 {
672 if (Xen_is_class_hook(obj))
673 return(RB_ARRAY_LEN(rb_iv_get(obj, "@procs")) == 0);
674 return(true);
675 }
676
677
678 /*
679 * @name = "$name_of_hook"
680 * @arity = arity of procedure(s), default 0
681 * @procs = [["named proc1", proc1], ...]
682 */
683
xen_rb_hook_initialize(int argc,Xen * argv,Xen hook)684 static Xen xen_rb_hook_initialize(int argc, Xen *argv, Xen hook)
685 {
686 Xen name, arity, help;
687 rb_scan_args(argc, argv, "12", &name, &arity, &help);
688 Xen_check_type(Xen_is_string(name) || Xen_is_symbol(name), name, 1, __func__, "a char* or symbol");
689 if (Xen_is_symbol(name))
690 name = XEN_SYMBOL_TO_STRING(name);
691 if (arity != Qnil)
692 {
693 Xen_check_type(Xen_is_integer(arity), arity, 2, __func__, "an integer");
694 }
695 else arity = INT2NUM(0);
696 if (help != Qnil)
697 {
698 Xen_check_type(Xen_is_string(help), help, 3, __func__, "a char*");
699 XEN_SET_OBJECT_HELP(name, help);
700 }
701 rb_iv_set(hook, "@name", name);
702 rb_iv_set(hook, "@arity", arity);
703 rb_iv_set(hook, "@procs", rb_ary_new());
704 return(hook);
705 }
706
707
708 /*
709 * To create a simple hook in C, see xen.h, XEN_DEFINE_SIMPLE_HOOK.
710 * To create a global hook variables, see xen_rb_create_hook() below.
711 */
712
xen_rb_hook_c_new(char * name,int arity,char * help)713 Xen xen_rb_hook_c_new(char *name, int arity, char *help)
714 {
715 Xen args[3];
716 args[0] = C_string_to_Xen_string(name);
717 args[1] = C_int_to_Xen_integer(arity);
718 args[2] = C_string_to_Xen_string(help);
719 return(xen_rb_hook_initialize(3, args, hook_alloc(xen_rb_cHook)));
720 }
721
722
723 /*
724 RUBY_RELEASE_DATE < "2004-03-18" ? old : new
725
726 lambda do end.arity -1 0 !!!
727 lambda do || end.arity 0 0
728 lambda do |a| end.arity -1 1 !!!
729 lambda do |*a| end.arity -1 -1
730 lambda do |a, b| end.arity 2 2
731 lambda do |a, *b| end.arity -2 -2
732 etc.
733 */
734
735 #ifdef RUBY_VERSION
736 #define XEN_RUBY_RELEASE_DATE RUBY_RELEASE_DATE
737 #else
738 #define XEN_RUBY_RELEASE_DATE Xen_string_to_C_string(Xen_eval_C_string("RUBY_RELEASE_DATE"))
739 #endif
740
741 #define RUBY_NEW_ARITY_DATE "2004-03-18"
742 #define OLD_RUBY_ARITY() (strcmp(XEN_RUBY_RELEASE_DATE, RUBY_NEW_ARITY_DATE) < 0)
743 /* #define NEW_RUBY_ARITY() (strcmp(XEN_RUBY_RELEASE_DATE, RUBY_NEW_ARITY_DATE) >= 0) */
744
xen_rb_arity_ok(int rargs,int args)745 bool xen_rb_arity_ok(int rargs, int args)
746 {
747 if (OLD_RUBY_ARITY())
748 {
749 if ((rargs >= 2) || (rargs == 0))
750 return(rargs == args);
751 else if (rargs <= -2)
752 return(abs(rargs) <= args);
753 else /* rargs -1 remains (no 1 exists) */
754 return((args == 1) || (args == 0) || (args == -1));
755 }
756 else /* NEW_RUBY_ARITY */
757 return((rargs >= 0) ? (rargs == args) : (abs(rargs) <= args));
758 }
759
760
xen_rb_hook_add_hook(int argc,Xen * argv,Xen hook)761 static Xen xen_rb_hook_add_hook(int argc, Xen *argv, Xen hook)
762 {
763 Xen name, func;
764 int args;
765 args = Xen_integer_to_C_int(rb_iv_get(hook, "@arity"));
766 rb_scan_args(argc, argv, "1&", &name, &func);
767 Xen_check_type(Xen_is_string(name), name, 1, __func__, "a char*");
768 Xen_check_type(Xen_is_procedure(func) && xen_rb_arity_ok(Xen_integer_to_C_int(Xen_arity(func)), args),
769 func, 2, __func__, "a procedure");
770 rb_ary_push(rb_iv_get(hook, "@procs"), rb_ary_new3(2, name, func));
771 return(hook);
772 }
773
774
775 #if HAVE_RB_PROC_NEW
776
xen_proc_call(Xen args,Xen id)777 static Xen xen_proc_call(Xen args, Xen id)
778 {
779 return(rb_apply(rb_mKernel, (ID)id, Xen_is_cons(args) ? args : Xen_list_1(args)));
780 }
781
782 #if 0
783 VALUE rb_proc_new((VALUE (*)(ANYARGS/* VALUE yieldarg[, VALUE procarg] */), VALUE));
784 void rb_define_module_function(VALUE,const char*,VALUE(*)(ANYARGS),int);
785 #endif
786
xen_rb_proc_new(const char * name,VALUE (* func)(ANYARGS),int arity,const char * doc)787 static Xen xen_rb_proc_new(const char *name, VALUE (*func)(ANYARGS), int arity, const char* doc)
788 {
789 switch (arity) /* g++ 10 insists that arity arg must be a constant! */
790 {
791 case 0: rb_define_module_function(rb_mKernel, name, func, 0); break;
792 case 1: rb_define_module_function(rb_mKernel, name, func, 1); break;
793 case 2: rb_define_module_function(rb_mKernel, name, func, 2); break;
794 case 3: rb_define_module_function(rb_mKernel, name, func, 3); break;
795 case 4: rb_define_module_function(rb_mKernel, name, func, 4); break;
796 case 5: rb_define_module_function(rb_mKernel, name, func, 5); break;
797 case 6: rb_define_module_function(rb_mKernel, name, func, 6); break;
798 case 7: rb_define_module_function(rb_mKernel, name, func, 7); break;
799 case 8: rb_define_module_function(rb_mKernel, name, func, 8); break;
800 default: fprintf(stderr, "arity: %d\n", arity);
801 }
802 if (doc) C_SET_OBJECT_HELP(name, doc);
803 return(rb_proc_new(Xen_procedure_cast xen_proc_call, rb_intern(name)));
804 }
805
806
807 static Xen xen_rb_hook_arity(Xen hook);
808
xen_rb_add_hook(Xen hook,VALUE (* func)(ANYARGS),const char * name,const char * doc)809 Xen xen_rb_add_hook(Xen hook, VALUE (*func)(ANYARGS), const char *name, const char* doc)
810 {
811 /* called from C, not Ruby, to add a function to a Ruby-side hook */
812 char *temp;
813 temp = xen_scheme_procedure_to_ruby(name);
814 rb_ary_push(rb_iv_get(hook, "@procs"), rb_ary_new3(2, C_string_to_Xen_string(temp), xen_rb_proc_new(temp, func, Xen_integer_to_C_int(xen_rb_hook_arity(hook)), doc)));
815 if (temp) free(temp);
816 return(hook);
817 }
818
819 #else
820
xen_rb_add_hook(Xen hook,VALUE (* func)(),const char * name,const char * doc)821 Xen xen_rb_add_hook(Xen hook, VALUE (*func)(), const char *name, const char* doc)
822 {
823 /* called from C, not Ruby, to add a function to a Ruby-side hook
824 * this doesn't work in g++ because it thinks the funcs are invalid:
825 * "error: invalid conversion from 'VALUE (*)(VALUE, VALUE)' to 'VALUE (*)(...)'" (snd-file.c etc)
826 */
827 Xen var, avar;
828 char *temp;
829 temp = xen_scheme_procedure_to_ruby(name);
830 avar = rb_iv_get(hook, "@arity");
831 rb_define_module_function(rb_mKernel, temp, Xen_procedure_cast func, (Xen_is_integer(avar)) ? Xen_integer_to_C_int(avar) : 0);
832 if (doc) C_SET_OBJECT_HELP(temp, doc);
833 var = rb_intern(temp);
834 rb_ary_push(rb_iv_get(hook, "@procs"), rb_ary_new3(2, C_string_to_Xen_string(temp), var));
835 if (temp) free(temp);
836 return(hook);
837 }
838
839 #endif
840
841
xen_rb_hook_remove_hook(Xen hook,Xen name)842 static Xen xen_rb_hook_remove_hook(Xen hook, Xen name)
843 {
844 Xen ary;
845 ary = rb_iv_get(hook, "@procs");
846 return(rb_ary_delete(ary, rb_ary_assoc(ary, name)));
847 }
848
849
xen_rb_hook_reset_hook(Xen hook)850 Xen xen_rb_hook_reset_hook(Xen hook)
851 {
852 if (Xen_is_class_hook(hook))
853 rb_ary_clear(rb_iv_get(hook, "@procs"));
854 return(hook);
855 }
856
857
xen_rb_hook_names(Xen hook)858 static Xen xen_rb_hook_names(Xen hook)
859 {
860 Xen ary, ret = Qnil;
861 long len;
862 ary = rb_iv_get(hook, "@procs");
863 len = RB_ARRAY_LEN(ary);
864 if (len > 0)
865 {
866 long i;
867 ret = rb_ary_new2(len);
868 for (i = 0; i < len; i++)
869 rb_ary_store(ret, i, Xen_vector_ref(Xen_vector_ref(ary, i), 0));
870 }
871 return(ret);
872 }
873
874
xen_rb_hook_to_a(Xen hook)875 Xen xen_rb_hook_to_a(Xen hook)
876 {
877 Xen ret = Qnil;
878 if (Xen_is_class_hook(hook))
879 {
880 Xen ary;
881 long len;
882 ary = rb_iv_get(hook, "@procs");
883 len = Xen_list_length(ary);
884 if (len > 0)
885 {
886 long i;
887 ret = rb_ary_new2(len);
888 for (i = 0; i < len; i++)
889 rb_ary_store(ret, i, Xen_vector_ref(Xen_vector_ref(ary, i), 1));
890 }
891 }
892 return(ret);
893 }
894
895
xen_rb_hook_run_hook(Xen hook)896 static Xen xen_rb_hook_run_hook(Xen hook)
897 {
898 if (RB_ARRAY_LEN(rb_iv_get(hook, "@procs")))
899 rb_ary_each(xen_rb_hook_to_a(hook));
900 return(hook);
901 }
902
903
904 /*
905 * Calls all hook-procedures but returns only the last result; use
906 * $var_hook.run_hook { |prc| ret << prc.call(*args) } for collecting
907 * results.
908 */
909
xen_rb_hook_call(int argc,Xen * argv,Xen hook)910 static Xen xen_rb_hook_call(int argc, Xen *argv, Xen hook)
911 {
912 Xen result = Qnil, rest, procs;
913 rb_scan_args(argc, argv, "*", &rest);
914 procs = xen_rb_hook_to_a(hook);
915 if (procs != Qnil)
916 {
917 long i;
918 for (i = 0; i < RB_ARRAY_LEN(procs); i++)
919 result = xen_rb_apply(rb_ary_entry(procs, i), rest);
920 }
921 return(result);
922 }
923
924
xen_rb_hook_is_empty_p(Xen hook)925 static Xen xen_rb_hook_is_empty_p(Xen hook)
926 {
927 return(C_bool_to_Xen_boolean(RB_ARRAY_LEN(rb_iv_get(hook, "@procs")) == 0));
928 }
929
930
xen_rb_hook_length(Xen hook)931 static Xen xen_rb_hook_length(Xen hook)
932 {
933 return(C_int_to_Xen_integer(RB_ARRAY_LEN(rb_iv_get(hook, "@procs"))));
934 }
935
936
xen_rb_hook_name(Xen hook)937 static Xen xen_rb_hook_name(Xen hook)
938 {
939 return(rb_iv_get(hook, "@name"));
940 }
941
942
xen_rb_hook_describe(Xen hook)943 static Xen xen_rb_hook_describe(Xen hook)
944 {
945 return(Xen_documentation(xen_rb_hook_name(hook)));
946 }
947
948
xen_rb_hook_arity(Xen hook)949 static Xen xen_rb_hook_arity(Xen hook)
950 {
951 return(rb_iv_get(hook, "@arity"));
952 }
953
954
xen_rb_hook_inspect(Xen hook)955 static Xen xen_rb_hook_inspect(Xen hook)
956 {
957 Xen str = rb_str_new2("#<Hook name: ");
958 rb_str_append(str, rb_inspect(rb_iv_get(hook, "@name")));
959 rb_str_cat2(str, ", arity: ");
960 rb_str_append(str, rb_inspect(rb_iv_get(hook, "@arity")));
961 rb_str_cat2(str, ", procs[");
962 rb_str_append(str, rb_inspect(xen_rb_hook_length(hook)));
963 rb_str_cat2(str, "]: ");
964 rb_str_append(str, rb_inspect(xen_rb_hook_names(hook)));
965 rb_str_cat2(str, ">");
966 return(str);
967 }
968
969
970 /* bil -- added xen_rb_create_hook for Xen_define_hook in xen.h, 13-Jun-05 --
971 * seems to work, but I'm guessing, especially the rb_gv_set line.
972 * I can't use rb_define_variable here, as in the old version, because it takes a pointer
973 * to the new variable, which in this case is a local variable => segfault.
974 */
975
xen_rb_create_hook(char * name,int arity,char * help)976 Xen xen_rb_create_hook(char *name, int arity, char *help)
977 {
978 Xen var, hook_name;
979 char *temp;
980 var = xen_rb_hook_c_new(temp = xen_scheme_global_variable_to_ruby(name), arity, help);
981 hook_name = xen_rb_hook_name(var);
982 rb_gv_set(Xen_string_to_C_string(hook_name), var);
983 if (temp) free(temp);
984 return(var);
985 }
986
987 static int simple_hook_number = 0;
988
989
xen_rb_create_simple_hook(int arity)990 Xen xen_rb_create_simple_hook(int arity)
991 {
992 char *name;
993 Xen hook;
994 name = (char *)calloc(20, sizeof(char));
995 snprintf(name, 20, "simple_%02d_hook", simple_hook_number++);
996 hook = xen_rb_create_hook(name, arity, NULL);
997 free(name);
998 return(hook);
999 }
1000
1001
1002 /*
1003 * make_hook(name, arity = 0, help = "", hook_name = nil, &func)
1004 *
1005 * make_hook("var_hook")
1006 * == $var_hook = Hook.new("var_hook")
1007 * make_hook("var_hook", 1)
1008 * == $var_hook = Hook.new("var_hook", 1)
1009 * make_hook("var_hook", 1, "help $var_hook")
1010 * == $var_hook = Hook.new("var_hook", 1, "help $var_hook")
1011 *
1012 * make_hook("var_hook", 1, "help $var_hook", "1st proc") do |a| ... end
1013 * == $var_hook = Hook.new("var_hook", 1, "help $var_hook")
1014 * $var_hook.add_hook!("1st proc") do |a| ... end
1015 */
1016
1017 #ifndef RSTRING_LEN
1018 #define RB_STR_LEN(str) RSTRING(str)->len
1019 #else
1020 #define RB_STR_LEN(str) RSTRING_LEN(str)
1021 #endif
1022
xen_rb_make_hook(int argc,Xen * argv,Xen klass)1023 static Xen xen_rb_make_hook(int argc, Xen *argv, Xen klass)
1024 {
1025 Xen hook = Xen_false, name;
1026 if (argc > 0 && argc < 4)
1027 {
1028 hook = xen_rb_hook_initialize(argc, argv, hook_alloc(xen_rb_cHook));
1029 if (rb_block_given_p())
1030 {
1031 argv[0] = rb_str_new2("");
1032 xen_rb_hook_add_hook(1, argv, hook);
1033 }
1034 }
1035 else if (argc == 4 && rb_block_given_p())
1036 {
1037 hook = xen_rb_hook_initialize(3, argv, hook_alloc(xen_rb_cHook));
1038 argv[0] = argv[3];
1039 xen_rb_hook_add_hook(1, argv, hook);
1040 }
1041 else Xen_error(Xen_make_error_type("wrong-number-of-args"),
1042 Xen_list_1(C_string_to_Xen_string("make_hook(name, arity=0, help=\"\", hook_name=\"\", &func)")));
1043 name = xen_rb_hook_name(hook);
1044 if (Xen_char_to_C_char(name) != '$')
1045 {
1046 char *temp;
1047 temp = xen_scheme_global_variable_to_ruby(Xen_string_to_C_string(name));
1048 name = C_string_to_Xen_string(temp);
1049 if (temp) free(temp);
1050 }
1051 Xen_check_type(RB_STR_LEN(name) >= 2, name, 1, __func__, "a char*, len >= 2");
1052 return(rb_gv_set(Xen_string_to_C_string(name), hook));
1053 }
1054
1055
xen_rb_is_hook_p(Xen klass,Xen obj)1056 static Xen xen_rb_is_hook_p(Xen klass, Xen obj)
1057 {
1058 return(C_bool_to_Xen_boolean(Xen_is_class_hook(obj)));
1059 }
1060
1061
1062 /*
1063 * Hook.new(name, arity = 0, help = "")
1064 *
1065 * $my_hook = Hook.new("my_hook", 2, "info of my_hook")
1066 * $my_hook.add_hook!("1st proc") do |a, b| ... end
1067 * or make_hook("my_hook", 2, "info of my_hook", "1st proc") do |a, b| ... end
1068 *
1069 * $my_hook.add_hook!("2nd proc") do |a, b| ... end
1070 * $my_hook.inspect --> #<Hook name: "$my_hook", arity: 2, procs[2]: ["1st proc", "2nd proc"]>
1071 *
1072 * ret = 0
1073 * $my_hook.run_hook do |prc| ret = prc.call(ret, 2) end
1074 *
1075 * $my_hook.help --> info of my_hook
1076 * $my_hook.remove_hook!("1st proc")
1077 * $my_hook.inspect --> #<Hook name: "$my_hook", arity: 2, procs[1]: ["2nd proc"]>
1078 *
1079 * $my_hook.remove_hook!("2nd proc")
1080 * $my_hook.inspect --> #<Hook name: "$my_hook", arity: 2, procs[0]: nil>
1081 */
1082
1083 #if (!HAVE_RB_DEFINE_ALLOC_FUNC)
xen_rb_new(int argc,Xen * argv,Xen klass)1084 static Xen xen_rb_new(int argc, Xen *argv, Xen klass)
1085 {
1086 Xen hook = hook_alloc(klass);
1087 rb_obj_call_init(hook, argc, argv);
1088 return(hook);
1089 }
1090 #endif
1091
1092
1093 static Xen rb_object_properties = Xen_false;
1094
1095 #define S_property "property"
1096 #define S_set_property "set_property"
1097 #define S_properties "properties"
1098
1099
rb_property(Xen obj,Xen key)1100 Xen rb_property(Xen obj, Xen key)
1101 {
1102 #define H_property S_property "(obj, key) \
1103 if key exists, return obj's value (maybe nil) associated with key otherwise false"
1104 Xen props = Xen_false;
1105
1106 if (Xen_is_false(rb_object_properties))
1107 return(Xen_false);
1108
1109 props = rb_hash_aref(rb_object_properties, obj);
1110
1111 if (Xen_is_false(props) || props == Qnil)
1112 return(Xen_false);
1113 else
1114 return(rb_hash_aref(props, key));
1115 }
1116
1117
rb_set_property(Xen obj,Xen key,Xen value)1118 Xen rb_set_property(Xen obj, Xen key, Xen value)
1119 {
1120 #define H_set_property S_set_property "(obj, key, value) \
1121 set key-value pair for obj and return value"
1122 Xen props = Xen_false;
1123
1124 if (Xen_is_false(rb_object_properties))
1125 {
1126 rb_object_properties = rb_hash_new();
1127 Xen_GC_protect(rb_object_properties);
1128 }
1129 else
1130 props = rb_hash_aref(rb_object_properties, obj);
1131
1132 if (Xen_is_false(props) || props == Qnil)
1133 props = rb_hash_new();
1134
1135 rb_hash_aset(props, key, value);
1136 rb_hash_aset(rb_object_properties, obj, props);
1137 return(value);
1138 }
1139
1140
rb_properties(void)1141 Xen rb_properties(void)
1142 {
1143 #define H_properties S_properties "() return all properties of rb_object_properties (a hash)"
1144 return(rb_object_properties);
1145 }
1146
1147
g_gc_off(void)1148 static Xen g_gc_off(void)
1149 {
1150 #define H_gc_off "(" S_gc_off ") turns off garbage collection"
1151 rb_gc_disable();
1152 return(Xen_false);
1153 }
1154
1155
g_gc_on(void)1156 static Xen g_gc_on(void)
1157 {
1158 #define H_gc_on "(" S_gc_on ") turns on garbage collection"
1159 rb_gc_enable();
1160 return(Xen_false);
1161 }
1162
1163
1164 Xen_wrap_1_optional_arg(g_get_help_w, g_get_help);
1165 Xen_wrap_2_args(g_add_help_w, g_add_help);
1166 Xen_wrap_3_args(g_set_property_w, rb_set_property);
1167 Xen_wrap_2_args(g_property_w, rb_property);
1168 Xen_wrap_no_args(g_properties_w, rb_properties);
1169
1170 Xen_wrap_no_args(g_gc_off_w, g_gc_off)
1171 Xen_wrap_no_args(g_gc_on_w, g_gc_on)
1172
1173
1174 static bool hook_inited = false;
1175
Init_Hook(void)1176 void Init_Hook(void)
1177 {
1178 if (hook_inited) return;
1179 hook_inited = true;
1180
1181 xen_rb_cHook = rb_define_class("Hook", rb_cObject);
1182 rb_include_module(xen_rb_cHook, rb_mEnumerable);
1183 #if HAVE_RB_DEFINE_ALLOC_FUNC
1184 rb_define_alloc_func(xen_rb_cHook, hook_alloc);
1185 #else
1186 rb_define_singleton_method(xen_rb_cHook, "new", Xen_procedure_cast xen_rb_new, -1);
1187 #endif
1188
1189 rb_define_method(xen_rb_cHook, "initialize", Xen_procedure_cast xen_rb_hook_initialize, -1);
1190 rb_define_method(xen_rb_cHook, "add_hook!", Xen_procedure_cast xen_rb_hook_add_hook, -1);
1191 rb_define_method(xen_rb_cHook, "remove_hook!", Xen_procedure_cast xen_rb_hook_remove_hook, 1);
1192 rb_define_method(xen_rb_cHook, "reset_hook!", Xen_procedure_cast xen_rb_hook_reset_hook, 0);
1193 rb_define_alias(xen_rb_cHook, "clear", "reset_hook!");
1194 rb_define_method(xen_rb_cHook, "to_a", Xen_procedure_cast xen_rb_hook_to_a, 0);
1195 rb_define_method(xen_rb_cHook, "run_hook", Xen_procedure_cast xen_rb_hook_run_hook, 0);
1196 rb_define_alias(xen_rb_cHook, "each", "run_hook");
1197 rb_define_method(xen_rb_cHook, "call", Xen_procedure_cast xen_rb_hook_call, -1);
1198 rb_define_method(xen_rb_cHook, "length", Xen_procedure_cast xen_rb_hook_length, 0);
1199 rb_define_alias(xen_rb_cHook, "size", "length");
1200 rb_define_method(xen_rb_cHook, "empty?", Xen_procedure_cast xen_rb_hook_is_empty_p, 0);
1201 rb_define_method(xen_rb_cHook, "name", Xen_procedure_cast xen_rb_hook_name, 0);
1202 rb_define_method(xen_rb_cHook, "arity", Xen_procedure_cast xen_rb_hook_arity, 0);
1203 rb_define_method(xen_rb_cHook, "describe", Xen_procedure_cast xen_rb_hook_describe, 0);
1204 rb_define_alias(xen_rb_cHook, "help", "describe");
1205 rb_define_alias(xen_rb_cHook, "documentation", "describe");
1206 rb_define_method(xen_rb_cHook, "inspect", Xen_procedure_cast xen_rb_hook_inspect, 0);
1207
1208 rb_define_global_function("make_hook", Xen_procedure_cast xen_rb_make_hook, -1);
1209 rb_define_global_function("hook?", Xen_procedure_cast xen_rb_is_hook_p, 1);
1210
1211 Xen_define_procedure(S_get_help, g_get_help_w, 0, 1, 0, H_get_help);
1212 Xen_define_procedure(S_add_help, g_add_help_w, 2, 0, 0, H_add_help);
1213
1214 Xen_define_procedure(S_set_property, g_set_property_w, 3, 0, 0, H_set_property);
1215 Xen_define_procedure(S_property, g_property_w, 2, 0, 0, H_property);
1216 Xen_define_procedure(S_properties, g_properties_w, 0, 0, 0, H_properties);
1217
1218 Xen_define_procedure(S_gc_off, g_gc_off_w, 0, 0, 0, H_gc_off);
1219 Xen_define_procedure(S_gc_on, g_gc_on_w, 0, 0, 0, H_gc_on);
1220 }
1221
1222 /* end of class Hook */
1223
1224 #endif
1225
1226
1227
1228 /* ------------------------------ FORTH ------------------------------ */
1229
1230 #if HAVE_FORTH
1231
xen_version(void)1232 char *xen_version(void)
1233 {
1234 return(fth_format("Fth: %s, Xen: " XEN_VERSION, FTH_VERSION));
1235 }
1236
1237
xen_gc_mark(Xen val)1238 void xen_gc_mark(Xen val)
1239 {
1240 fth_gc_mark(val);
1241 }
1242
1243
1244 /*
1245 * A simple interpreter:
1246 *
1247 * #include <xen.h>
1248 *
1249 * int main(int argc, char **argv)
1250 * {
1251 * xen_repl(argc, argv);
1252 * return(0);
1253 * }
1254 *
1255 * linking requires xen.o and -lfth -lm
1256 */
1257
xen_repl(int argc,char ** argv)1258 void xen_repl(int argc, char **argv)
1259 {
1260 fth_repl(argc, argv);
1261 }
1262
1263
1264 static ficlWord *snd_exit_xt;
1265
fth_snd_exit(int n)1266 static void fth_snd_exit(int n)
1267 {
1268 if (!snd_exit_xt)
1269 snd_exit_xt = ficlSystemLookup(FTH_FICL_SYSTEM(), (char *)"snd-exit");
1270 ficlStackPushInteger(FTH_FICL_STACK(), n);
1271 ficlVmExecuteXT(FTH_FICL_VM(), snd_exit_xt);
1272 ficlStackDrop(FTH_FICL_STACK(), 1);
1273 }
1274
1275
g_gc_off(void)1276 static Xen g_gc_off(void)
1277 {
1278 #define H_gc_off "(" S_gc_off ") turns off garbage collection"
1279 fth_gc_on();
1280 return(Xen_false);
1281 }
1282
1283
g_gc_on(void)1284 static Xen g_gc_on(void)
1285 {
1286 #define H_gc_on "(" S_gc_on ") turns on garbage collection"
1287 fth_gc_on();
1288 return(Xen_false);
1289 }
1290
1291
xen_initialize(void)1292 void xen_initialize(void)
1293 {
1294 fth_init();
1295 fth_exit_hook = fth_snd_exit;
1296
1297 Xen_define_procedure(S_gc_off, g_gc_off, 0, 0, 0, H_gc_off);
1298 Xen_define_procedure(S_gc_on, g_gc_on, 0, 0, 0, H_gc_on);
1299 }
1300
1301 #endif /* HAVE_FORTH */
1302
1303
1304
1305 /* ------------------------------ s7 ------------------------------ */
1306
1307 #if HAVE_SCHEME
1308 #include "s7.h"
1309
1310 #if ENABLE_WEBSERVER
1311 #include "s7webserver/s7webserver.h"
1312 #endif
1313
1314 s7_scheme *s7;
1315 Xen xen_false, xen_true, xen_nil, xen_undefined, xen_zero;
1316
xen_version(void)1317 char *xen_version(void)
1318 {
1319 char *buf;
1320 buf = (char *)calloc(64, sizeof(char));
1321 snprintf(buf, 64, "s7: %s (%s), Xen: %s", S7_VERSION, S7_DATE, XEN_VERSION);
1322 return(buf);
1323 }
1324
1325
1326 static char *xen_s7_repl_prompt = NULL;
1327
xen_s7_set_repl_prompt(const char * new_prompt)1328 void xen_s7_set_repl_prompt(const char *new_prompt)
1329 {
1330 if (xen_s7_repl_prompt) free(xen_s7_repl_prompt);
1331 xen_s7_repl_prompt = xen_strdup(new_prompt);
1332 }
1333
1334
1335 #if USE_SND
1336 char *stdin_check_for_full_expression(const char *newstr);
1337 void stdin_free_str(void);
1338 #endif
1339
xen_repl(int argc,char ** argv)1340 void xen_repl(int argc, char **argv)
1341 {
1342 int size = 512;
1343 bool expr_ok = true;
1344 char *buffer;
1345 buffer = (char *)calloc(size, sizeof(char));
1346
1347 while (true)
1348 {
1349 if (expr_ok)
1350 {
1351 fprintf(stdout, "\n%s", xen_s7_repl_prompt);
1352 expr_ok = false; /* don't get into an infinite loop if running in the background! */
1353 }
1354 if (fgets(buffer, size, stdin))
1355 {
1356 /* also, it's possible to get a string of spaces or nulls (? -- not sure what is coming in) if stdin is /dev/null */
1357 /* then if (as in condor) stdout is being saved in a file, we get in an infinite loop storing "snd>" until the disk fills up */
1358 int i, len;
1359
1360 expr_ok = false;
1361 len = strlen(buffer);
1362 for (i = 0; i < len; i++)
1363 {
1364 if (buffer[i] == 0)
1365 break;
1366 if (!isspace((int)buffer[i]))
1367 {
1368 expr_ok = true;
1369 break;
1370 }
1371 }
1372 if (expr_ok)
1373 {
1374 char *temp;
1375 #if USE_SND
1376 char *str;
1377 str = stdin_check_for_full_expression(buffer); /* "str" here is actually stdin_str, so we need to clear it explicitly */
1378 if (!str) {expr_ok = false; continue;}
1379 len = strlen(str) + 16;
1380 temp = (char *)malloc(len * sizeof(char));
1381 snprintf(temp, len, "(write %s)", str);
1382 Xen_eval_C_string(temp);
1383 free(temp);
1384 stdin_free_str();
1385 #else
1386 temp = (char *)malloc(len + 16);
1387 snprintf(temp, len + 16, "(write %s)", buffer); /* use write, not display so that strings are in double quotes */
1388 Xen_eval_C_string(temp);
1389 free(temp);
1390 #endif
1391 }
1392 }
1393 }
1394 /* unreachable */
1395 free(buffer);
1396 }
1397
1398
xen_gc_mark(Xen val)1399 void xen_gc_mark(Xen val)
1400 {
1401 s7_mark(val);
1402 }
1403
1404
xen_set_assoc(s7_scheme * sc,s7_pointer key,s7_pointer val,s7_pointer alist)1405 Xen xen_set_assoc(s7_scheme *sc, s7_pointer key, s7_pointer val, s7_pointer alist)
1406 {
1407 /* fixup alist, return it (caller has to make sure it is reflected in its object) */
1408 /*
1409 (let ((old-val (assoc key alist)))
1410 (if old-val
1411 (progn
1412 (set-cdr! old-val new-val)
1413 alist)
1414 (cons (cons key new-val) alist)))
1415 */
1416 Xen old_val;
1417 old_val = s7_assoc(sc, key, alist); /* returns #f if nothing found */
1418 if (old_val == s7_f(sc))
1419 return(s7_cons(sc, s7_cons(sc, key, val), alist));
1420 s7_set_cdr(old_val, val);
1421 return(alist);
1422 }
1423
1424
xen_assoc(s7_scheme * sc,Xen key,Xen alist)1425 Xen xen_assoc(s7_scheme *sc, Xen key, Xen alist)
1426 {
1427 Xen val;
1428 val = s7_assoc(sc, key, alist);
1429 if (val != s7_f(sc))
1430 return(s7_cdr(val));
1431 return(s7_f(sc));
1432 }
1433
1434
1435 /* add various file functions that everyone else implements */
1436
1437 #ifndef _MSC_VER
1438 #include <unistd.h>
1439 #include <sys/time.h>
1440 #endif
1441
1442 #include <sys/stat.h>
1443 #include <fcntl.h>
1444
1445
g_getpid(void)1446 static Xen g_getpid(void)
1447 {
1448 #define H_getpid "(getpid) returns the current job's process id"
1449 return(C_int_to_Xen_integer((int)getpid()));
1450 }
1451
1452
1453 #if (!WITH_SYSTEM_EXTRAS)
file_probe(const char * arg)1454 static bool file_probe(const char *arg)
1455 {
1456 #ifndef _MSC_VER
1457 return(access(arg, F_OK) == 0);
1458 #else
1459 int fd;
1460 #ifdef O_NONBLOCK
1461 fd = open(arg, O_RDONLY, O_NONBLOCK);
1462 #else
1463 fd = open(arg, O_RDONLY, 0);
1464 #endif
1465 if (fd == -1) return(false);
1466 close(fd);
1467 return(true);
1468 #endif
1469 }
1470
1471
g_file_exists_p(Xen name)1472 static Xen g_file_exists_p(Xen name)
1473 {
1474 #define H_file_exists_p "(file-exists? filename): #t if the file exists"
1475 Xen_check_type(Xen_is_string(name), name, 1, "file-exists?", "a string");
1476 return(C_bool_to_Xen_boolean(file_probe(Xen_string_to_C_string(name))));
1477 }
1478
1479
is_directory(const char * filename)1480 static bool is_directory(const char *filename)
1481 {
1482 #if (defined(_MSC_VER) || __CYGWIN__)
1483 return(false);
1484 #else
1485 #ifdef S_ISDIR
1486 struct stat statbuf;
1487 return((stat(filename, &statbuf) >= 0) &&
1488 (S_ISDIR(statbuf.st_mode)));
1489 return(false);
1490 #endif
1491 #endif
1492 }
1493
g_is_directory(Xen name)1494 static Xen g_is_directory(Xen name)
1495 {
1496 #define H_is_directory "(directory? filename): #t if filename names a directory"
1497 Xen_check_type(Xen_is_string(name), name, 1, "directory?", "a string");
1498 return(C_bool_to_Xen_boolean(is_directory(Xen_string_to_C_string(name)))); /* snd-file.c l 84 */
1499 }
1500
g_delete_file(Xen name)1501 static Xen g_delete_file(Xen name)
1502 {
1503 #define H_delete_file "(delete-file filename): deletes the file"
1504 Xen_check_type(Xen_is_string(name), name, 1, "delete-file", "a string");
1505 return(C_bool_to_Xen_boolean(unlink(Xen_string_to_C_string(name))));
1506 }
1507
1508
g_system(Xen command)1509 static Xen g_system(Xen command)
1510 {
1511 #define H_system "(system command): execute command"
1512 Xen_check_type(Xen_is_string(command), command, 1, "system", "a string");
1513 return(C_int_to_Xen_integer(system(Xen_string_to_C_string(command))));
1514 }
1515
1516
g_s7_getenv(Xen var)1517 static Xen g_s7_getenv(Xen var) /* "g_getenv" is in use in glib! */
1518 {
1519 #define H_getenv "(getenv var): return value of environment variable var"
1520 Xen_check_type(Xen_is_string(var), var, 1, "getenv", "a string");
1521 return(C_string_to_Xen_string(getenv(Xen_string_to_C_string(var))));
1522 }
1523 #endif
1524
1525
1526
1527 #ifdef _MSC_VER
1528 #include <direct.h>
1529 #endif
1530
g_getcwd(void)1531 static Xen g_getcwd(void)
1532 {
1533 #define H_getcwd "(getcwd) returns the name of the current working directory"
1534 char *buf;
1535 Xen result = Xen_false;
1536 buf = (char *)calloc(1024, sizeof(char));
1537 #ifdef _MSC_VER
1538 if (_getcwd(buf, 1024))
1539 #else
1540 if (getcwd(buf, 1024))
1541 #endif
1542 result = C_string_to_Xen_string(buf);
1543 free(buf);
1544 return(result);
1545 }
1546
1547
g_strftime(Xen format,Xen tm)1548 static Xen g_strftime(Xen format, Xen tm)
1549 {
1550 #define H_strftime "(strftime format time) returns a string describing the time: (strftime \"%d-%b %H:%M %Z\" (localtime (current-time)))"
1551 char *buf;
1552 Xen result;
1553 const struct tm *p;
1554
1555 Xen_check_type(Xen_is_string(format), format, 1, "strftime", "a string");
1556 Xen_check_type(Xen_is_wrapped_c_pointer(tm), tm, 2, "strftime", "a localtime struct");
1557
1558 p = (const struct tm *)Xen_unwrap_C_pointer(tm);
1559 Xen_check_type(p, tm, 2, "strftime", "a localtime struct");
1560
1561 buf = (char *)calloc(1024, sizeof(char));
1562 strftime(buf, 1024, Xen_string_to_C_string(format), p);
1563 result = C_string_to_Xen_string(buf);
1564 free(buf);
1565
1566 return(result);
1567 }
1568
1569
1570 /* (format #f ";~A~%" (strftime "%d-%b %H:%M %Z" (localtime (current-time)))) */
1571 /* these two need to be compatible with g_file_write_date in snd-file.c */
1572
g_localtime(Xen tm)1573 static Xen g_localtime(Xen tm)
1574 {
1575 #define H_localtime "(localtime tm) breaks up tm into something suitable for strftime"
1576 time_t rtime;
1577 Xen_check_type(Xen_is_integer(tm), tm, 1, "localtime", "an integer");
1578 rtime = (time_t)Xen_ulong_to_C_ulong(tm);
1579 return(Xen_wrap_C_pointer(localtime((time_t *)(&rtime))));
1580 }
1581
1582
g_current_time(void)1583 static Xen g_current_time(void)
1584 {
1585 time_t curtime;
1586 #define H_current_time "(current-time) returns the current time (for localtime and strftime)"
1587 curtime = time(NULL);
1588 return(C_ulong_to_Xen_ulong(curtime));
1589 }
1590
1591
g_ftell(Xen fd)1592 static Xen g_ftell(Xen fd)
1593 {
1594 Xen_check_type(Xen_is_integer(fd), fd, 1, "ftell", "an integer");
1595 return(C_int_to_Xen_integer(lseek(Xen_integer_to_C_int(fd), 0, SEEK_CUR)));
1596 }
1597
1598
g_gc_off(void)1599 static Xen g_gc_off(void)
1600 {
1601 #define H_gc_off "(" S_gc_off ") turns off garbage collection"
1602 s7_gc_on(s7, false);
1603 return(Xen_false);
1604 }
1605
1606
g_gc_on(void)1607 static Xen g_gc_on(void)
1608 {
1609 #define H_gc_on "(" S_gc_on ") turns on garbage collection"
1610 s7_gc_on(s7, true);
1611 return(Xen_false);
1612 }
1613
1614
1615
Xen_wrap_no_args(g_getpid_w,g_getpid)1616 Xen_wrap_no_args(g_getpid_w, g_getpid)
1617 #if (!WITH_SYSTEM_EXTRAS)
1618 Xen_wrap_1_arg(g_file_exists_p_w, g_file_exists_p)
1619 Xen_wrap_1_arg(g_is_directory_w, g_is_directory)
1620 Xen_wrap_1_arg(g_delete_file_w, g_delete_file)
1621 Xen_wrap_1_arg(g_s7_getenv_w, g_s7_getenv)
1622 Xen_wrap_1_arg(g_system_w, g_system)
1623 #endif
1624 Xen_wrap_no_args(g_getcwd_w, g_getcwd)
1625 Xen_wrap_2_args(g_strftime_w, g_strftime)
1626 Xen_wrap_1_arg(g_localtime_w, g_localtime)
1627 Xen_wrap_no_args(g_current_time_w, g_current_time)
1628 Xen_wrap_1_arg(g_ftell_w, g_ftell)
1629 Xen_wrap_no_args(g_gc_off_w, g_gc_off)
1630 Xen_wrap_no_args(g_gc_on_w, g_gc_on)
1631
1632 #if ENABLE_WEBSERVER
1633 #if USE_MOTIF
1634 #include "snd.h"
1635 static idle_func_t called_periodically(any_pointer_t pet)
1636 {
1637 s7webserver_call_very_often();
1638 return(BACKGROUND_CONTINUE);
1639 }
1640 #endif
1641 #endif
1642
1643
s7_xen_initialize(s7_scheme * sc)1644 s7_scheme *s7_xen_initialize(s7_scheme *sc)
1645 {
1646 s7_pointer i, b, p, s;
1647
1648 xen_s7_repl_prompt = xen_strdup("> ");
1649 if (!sc)
1650 {
1651 s7 = s7_init();
1652 if (!s7)
1653 {
1654 fprintf(stderr, "Can't initialize s7!\n");
1655 return(NULL);
1656 }
1657 #if ENABLE_WEBSERVER
1658 {
1659 s7webserver_t *s7webserver;
1660 s7webserver = s7webserver_create(s7, 6080, true);
1661 if (!s7webserver)
1662 fprintf(stderr, "Unable to start web server. Port 6080 may be in use\n");
1663 else fprintf(stdout, "Started s7 webserver at port %d\n", s7webserver_get_portnumber(s7webserver));
1664 #if USE_MOTIF
1665 BACKGROUND_ADD(called_periodically, NULL);
1666 #endif
1667 }
1668 #endif
1669 }
1670 else s7 = sc;
1671
1672 i = s7_make_symbol(s7, "integer?");
1673 b = s7_make_symbol(s7, "boolean?");
1674 p = s7_make_symbol(s7, "pair?");
1675 s = s7_make_symbol(s7, "string?");
1676
1677 xen_false = s7_f(s7);
1678 xen_true = s7_t(s7);
1679 xen_nil = s7_nil(s7);
1680 xen_undefined = s7_undefined(s7);
1681 xen_zero = s7_make_integer(s7, 0);
1682 s7_gc_protect(s7, xen_zero);
1683
1684 Xen_define_typed_procedure("getpid", g_getpid_w, 0, 0, 0, H_getpid, s7_make_signature(s7, 1, i));
1685 #if (!WITH_SYSTEM_EXTRAS)
1686 Xen_define_typed_procedure("file-exists?", g_file_exists_p_w, 1, 0, 0, H_file_exists_p, s7_make_signature(s7, 2, b, s));
1687 Xen_define_typed_procedure("directory?", g_is_directory_w, 1, 0, 0, H_is_directory, s7_make_signature(s7, 2, b, s));
1688 Xen_define_typed_procedure("delete-file", g_delete_file_w, 1, 0, 0, H_delete_file, s7_make_signature(s7, 2, b, s));
1689 Xen_define_typed_procedure("getenv", g_s7_getenv_w, 1, 0, 0, H_getenv, s7_make_signature(s7, 2, s, s));
1690 Xen_define_typed_procedure("system", g_system_w, 1, 0, 0, H_system, s7_make_signature(s7, 2, i, s));
1691 #endif
1692 Xen_define_typed_procedure("getcwd", g_getcwd_w, 0, 0, 0, H_getcwd, s7_make_signature(s7, 1, s));
1693 Xen_define_typed_procedure("strftime", g_strftime_w, 2, 0, 0, H_strftime, s7_make_signature(s7, 3, s, s, p));
1694 Xen_define_typed_procedure("localtime", g_localtime_w, 1, 0, 0, H_localtime, s7_make_signature(s7, 2, p, i));
1695 Xen_define_typed_procedure("current-time", g_current_time_w, 0, 0, 0, H_current_time, s7_make_signature(s7, 1, i));
1696 Xen_define_typed_procedure("ftell", g_ftell_w, 1, 0, 0, "(ftell fd): lseek", s7_make_signature(s7, 2, i, i));
1697 Xen_define_typed_procedure(S_gc_off, g_gc_off_w, 0, 0, 0, H_gc_off, s7_make_signature(s7, 1, b));
1698 Xen_define_typed_procedure(S_gc_on, g_gc_on_w, 0, 0, 0, H_gc_on, s7_make_signature(s7, 1, b));
1699
1700 Xen_eval_C_string("(define (hook-push hook func) \n\
1701 \"(hook-push hook func) adds func to hook's function list\" \n\
1702 (if (not (member func (hook-functions hook) eq?)) (set! (hook-functions hook) (cons func (hook-functions hook)))))");
1703 Xen_eval_C_string("(define (hook-append hook func) \n\
1704 \"(hook-append hook func) adds func to the end of hook's function list\" \n\
1705 (set! (hook-functions hook) (append (hook-functions hook) (list func))))");
1706 Xen_eval_C_string("(define (hook-clear hook) (set! (hook-functions hook) ()))");
1707 Xen_eval_C_string("(define (hook-remove hook func) \n\
1708 (set! (hook-functions hook)\n\
1709 (let loop ((l (hook-functions hook))\n\
1710 (result ()))\n\
1711 (cond ((null? l) (reverse! result))\n\
1712 ((eq? func (car l)) (loop (cdr l) result))\n\
1713 (else (loop (cdr l) (cons (car l) result)))))))");
1714
1715 Xen_eval_C_string("(define-macro (while whether . body) `(do () ((not ,whether)) ,@body))");
1716 Xen_eval_C_string("(define (identity x) \"return arg\" x)");
1717
1718 return(s7);
1719 }
1720
1721
xen_initialize(void)1722 void xen_initialize(void)
1723 {
1724 s7_xen_initialize(NULL);
1725 }
1726 #endif
1727
1728
1729
1730
1731 /* ------------------------------ NONE OF THE ABOVE ------------------------------ */
1732
1733 #if (!HAVE_EXTENSION_LANGUAGE)
1734
xen_version(void)1735 char *xen_version(void)
1736 {
1737 char *buf;
1738 buf = (char *)calloc(64, sizeof(char));
1739 snprintf(buf, 64, "no extension language");
1740 return(buf);
1741 }
1742
1743
xen_repl(int argc,char ** argv)1744 void xen_repl(int argc, char **argv)
1745 {
1746 }
1747
1748
xen_initialize(void)1749 void xen_initialize(void)
1750 {
1751 }
1752
1753
xen_gc_mark(Xen val)1754 void xen_gc_mark(Xen val)
1755 {
1756 }
1757
1758
xen_no_ext_lang_check_args(const char * name,int args,int req_args,int opt_args,int rst_args)1759 void xen_no_ext_lang_check_args(const char *name, int args, int req_args, int opt_args, int rst_args)
1760 {
1761 if (args > 0) /* nargify -- all are required */
1762 {
1763 if (req_args != args)
1764 fprintf(stderr, "%s: %d required args, but req: %d (opt: %d, rst: %d)\n", name, args, req_args, opt_args, rst_args);
1765 if (opt_args != 0)
1766 fprintf(stderr, "%s: all args required, but opt: %d (rst: %d)\n", name, opt_args, rst_args);
1767 if (rst_args != 0)
1768 fprintf(stderr, "%s: all args required, but rst: %d\n", name, rst_args);
1769 }
1770 else
1771 {
1772 if (args != -100) /* vargify -- any ok */
1773 {
1774 args = -args;
1775 if (rst_args == 0)
1776 {
1777 if (req_args + opt_args != args)
1778 fprintf(stderr, "%s: total args: %d, but req: %d and opt: %d\n", name, args, req_args, opt_args);
1779 }
1780 else
1781 {
1782 if (req_args + opt_args > args)
1783 fprintf(stderr, "%s: has :rest, but req: %d and opt: %d , whereas total: %d\n", name, req_args, opt_args, args);
1784 }
1785 }
1786 }
1787 }
1788
1789 #endif
1790