static pic_value pic_proc_for_each(pic_state *pic) { struct pic_proc *proc; size_t argc; pic_value *args; int i; pic_value cars; pic_get_args(pic, "l*", &proc, &argc, &args); do { cars = pic_nil_value(); for (i = argc - 1; i >= 0; --i) { if (! pic_pair_p(args[i])) { break; } cars = pic_cons(pic, pic_car(pic, args[i]), cars); args[i] = pic_cdr(pic, args[i]); } if (i >= 0) break; pic_apply(pic, proc, cars); } while (1); return pic_none_value(); }
static pic_value pic_str_string_for_each(pic_state *pic) { struct pic_proc *proc; size_t argc, len, i, j; pic_value *argv, vals; pic_get_args(pic, "l*", &proc, &argc, &argv); if (argc == 0) { pic_errorf(pic, "string-map: one or more strings expected, but got zero"); } else { pic_assert_type(pic, argv[0], str); len = pic_str_len(pic_str_ptr(argv[0])); } for (i = 1; i < argc; ++i) { pic_assert_type(pic, argv[i], str); len = len < pic_str_len(pic_str_ptr(argv[i])) ? len : pic_str_len(pic_str_ptr(argv[i])); } for (i = 0; i < len; ++i) { vals = pic_nil_value(); for (j = 0; j < argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } pic_apply(pic, proc, vals); } return pic_undef_value(); }
static pic_value pic_cont_call_with_values(pic_state *pic) { struct pic_proc *producer, *consumer; size_t argc; pic_value args[256]; pic_get_args(pic, "ll", &producer, &consumer); pic_apply(pic, producer, pic_nil_value()); argc = pic_receive(pic, 256, args); return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args)); }
static pic_value pic_proc_apply(pic_state *pic) { struct pic_proc *proc; pic_value *args; size_t argc; pic_get_args(pic, "l*", &proc, &argc, &args); if (argc == 0) { pic_error(pic, "apply: wrong number of arguments"); } return pic_apply(pic, proc, pic_list_from_array(pic, argc, args)); }
static pic_value pic_str_string_map(pic_state *pic) { struct pic_proc *proc; pic_value *argv, vals, val; size_t argc, i, len, j; pic_str *str; char *buf; pic_get_args(pic, "l*", &proc, &argc, &argv); if (argc == 0) { pic_errorf(pic, "string-map: one or more strings expected, but got zero"); } else { pic_assert_type(pic, argv[0], str); len = pic_str_len(pic_str_ptr(argv[0])); } for (i = 1; i < argc; ++i) { pic_assert_type(pic, argv[i], str); len = len < pic_str_len(pic_str_ptr(argv[i])) ? len : pic_str_len(pic_str_ptr(argv[i])); } buf = pic_malloc(pic, len); pic_try { for (i = 0; i < len; ++i) { vals = pic_nil_value(); for (j = 0; j < argc; ++j) { pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals); } val = pic_apply(pic, proc, vals); pic_assert_type(pic, val, char); buf[i] = pic_char(val); } str = pic_make_str(pic, buf, len); } pic_catch { pic_free(pic, buf); pic_raise(pic, pic->err); } pic_free(pic, buf); return pic_obj_value(str); }
void pic_load_stdlib(pic_state *pic) { static const char *fn = "piclib/built-in.scm"; FILE *file; int n, i; pic_value v, vs; struct pic_proc *proc; file = fopen(fn, "r"); if (file == NULL) { fputs("fatal error: could not read built-in.scm", stderr); abort(); } n = pic_parse_file(pic, file, &vs); if (n <= 0) { fputs("fatal error: built-in.scm broken", stderr); abort(); } for (i = 0; i < n; ++i, vs = pic_cdr(pic, vs)) { v = pic_car(pic, vs); proc = pic_codegen(pic, v); if (proc == NULL) { fputs(pic->errmsg, stderr); fputs("fatal error: built-in.scm compilation failure", stderr); abort(); } v = pic_apply(pic, proc, pic_nil_value()); if (pic_undef_p(v)) { fputs(pic->errmsg, stderr); fputs("fatal error: built-in.scm evaluation failure", stderr); abort(); } } #if DEBUG puts("successfully loaded stdlib"); #endif }