native implmentation of map

This commit is contained in:
Yuichi Nishiwaki 2014-01-22 22:18:25 +09:00
parent e417439f4a
commit 85a5745716
2 changed files with 34 additions and 34 deletions

View File

@ -39,13 +39,7 @@
(define (caddr p) (car (cddr p)))
(define (cdddr p) (cdr (cddr p)))
(define (map f list)
(if (null? list)
list
(cons (f (car list))
(map f (cdr list)))))
(export map cadar caddr cdddr))
(export cadar caddr cdddr))
;;; core syntaces
(define-library (picrin core-syntax)
@ -374,9 +368,6 @@
s
(fold f (f (car xs) s) (cdr xs))))
;;; FIXME forward declaration
(define map #f)
;;; 6.2. Numbers
(define (zero? n)
@ -757,22 +748,6 @@
;;; 6.10 control features
(set! map
(lambda (f list . lists)
(define (single-map f list)
(if (null? list)
'()
(cons (f (car list))
(map f (cdr list)))))
(define (multiple-map f lists)
(if (any null? lists)
'()
(cons (apply f (single-map car lists))
(multiple-map f (single-map cdr lists)))))
(if (null? lists)
(single-map f list)
(multiple-map f (cons list lists)))))
(define (for-each f list . lists)
(define (single-for-each f list)
(if (null? list)
@ -828,7 +803,7 @@
(map (lambda (v) (vector-ref v n)) vs))
(loop (+ n 1))))))
(export map for-each
(export for-each
string-map string-for-each
vector-map vector-for-each)

View File

@ -85,21 +85,45 @@ static pic_value
pic_proc_apply(pic_state *pic)
{
struct pic_proc *proc;
pic_value *args, v;
pic_value *args;
size_t argc;
int i;
pic_get_args(pic, "l*", &proc, &argc, &args);
if (argc == 0) {
pic_error(pic, "apply: wrong number of arguments");
}
v = args[argc - 1];
for (i = argc - 2; i >= 0; --i) {
v = pic_cons(pic, args[i], v);
}
return pic_apply(pic, proc, v);
return pic_apply(pic, proc, pic_list_from_array(pic, argc, args));
}
static pic_value
pic_proc_map(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *args;
int i;
pic_value cars, ret;
pic_get_args(pic, "l*", &proc, &argc, &args);
ret = pic_nil_value();
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;
ret = pic_cons(pic, pic_apply(pic, proc, cars), ret);
} while (1);
return pic_reverse(pic, ret);
}
void
@ -107,4 +131,5 @@ pic_init_proc(pic_state *pic)
{
pic_defun(pic, "procedure?", pic_proc_proc_p);
pic_defun(pic, "apply", pic_proc_apply);
pic_defun(pic, "map", pic_proc_map);
}