conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into analyzer 

Conflicts:
	include/picrin/pair.h
	src/pair.c
This commit is contained in:
Yuichi Nishiwaki 2014-01-23 16:21:10 +09:00
parent c7811f0c39 95c5361197
commit 2e28f604a6
7 changed files with 503 additions and 211 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -6,3 +6,6 @@ src/y.tab.h
lib/libpicrin.so lib/libpicrin.so
lib/libpicrin.so.dSYM lib/libpicrin.so.dSYM
.dir-locals.el .dir-locals.el
GPATH
GRTAGS
GTAGS

10
include/picrin/gc.h
View File

@ -9,18 +9,16 @@
extern "C" { extern "C" {
#endif #endif
enum pic_gc_mark { #define PIC_GC_UNMARK 0
PIC_GC_UNMARK = 0, #define PIC_GC_MARK 1
PIC_GC_MARK
};
union header { union header {
struct { struct {
union header *ptr; union header *ptr;
size_t size; size_t size;
enum pic_gc_mark mark : 1; unsigned int mark : 1;
} s; } s;
long alignment[2]; long alignment[4];
}; };
struct heap_page { struct heap_page {

5
include/picrin/pair.h
View File

@ -16,9 +16,11 @@ pic_value pic_cdr(pic_state *, pic_value);
bool pic_list_p(pic_state *, pic_value); bool pic_list_p(pic_state *, pic_value);
pic_value pic_list(pic_state *, size_t, ...); pic_value pic_list(pic_state *, size_t, ...);
pic_value pic_list_from_array(pic_state *, size_t, pic_value *); pic_value pic_list_from_array(pic_state *, size_t, pic_value *);
pic_value pic_make_list(pic_state *, int, pic_value);
int pic_length(pic_state *, pic_value); int pic_length(pic_state *, pic_value);
pic_value pic_reverse(pic_state *, pic_value); pic_value pic_reverse(pic_state *, pic_value);
pic_value pic_append(pic_state *, pic_value, pic_value);
pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc); pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc);
@ -29,7 +31,10 @@ pic_value pic_cadr(pic_state *, pic_value);
pic_value pic_cdar(pic_state *, pic_value); pic_value pic_cdar(pic_state *, pic_value);
pic_value pic_cddr(pic_state *, pic_value); pic_value pic_cddr(pic_state *, pic_value);
pic_value pic_list_tail(pic_state *, pic_value ,int);
pic_value pic_list_ref(pic_state *, pic_value, int); pic_value pic_list_ref(pic_state *, pic_value, int);
void pic_list_set(pic_state *, pic_value, int, pic_value);
pic_value pic_list_copy(pic_state *, pic_value);
#if defined(__cplusplus) #if defined(__cplusplus)
} }

192
piclib/built-in.scm
View File

@ -35,31 +35,11 @@
(define-library (picrin bootstrap-tools) (define-library (picrin bootstrap-tools)
(import (scheme base)) (import (scheme base))
(define (list . args) args)
(define (caar p) (car (car p)))
(define (cadr p) (car (cdr p)))
(define (cdar p) (cdr (car p)))
(define (cddr p) (cdr (cdr p)))
(define (cadar p) (car (cdar p))) (define (cadar p) (car (cdar p)))
(define (caddr p) (car (cddr p))) (define (caddr p) (car (cddr p)))
(define (cdddr p) (cdr (cddr p))) (define (cdddr p) (cdr (cddr p)))
(define (map f list) (export cadar caddr cdddr))
(if (null? list)
list
(cons (f (car list))
(map f (cdr list)))))
(define (append xs ys)
(if (null? xs)
ys
(cons (car xs)
(append (cdr xs) ys))))
(export list map append
caar cadr cdar cddr
cadar caddr cdddr))
;;; core syntaces ;;; core syntaces
(define-library (picrin core-syntax) (define-library (picrin core-syntax)
@ -367,15 +347,6 @@
(export make-parameter (export make-parameter
parameterize) parameterize)
(define (any pred list)
(if (null? list)
#f
((lambda (it)
(if it
it
(any pred (cdr list))))
(pred (car list)))))
(define (every pred list) (define (every pred list)
(if (null? list) (if (null? list)
#t #t
@ -388,38 +359,8 @@
s s
(fold f (f (car xs) s) (cdr xs)))) (fold f (f (car xs) s) (cdr xs))))
;;; FIXME forward declaration
(define map #f)
;;; 6.2. Numbers ;;; 6.2. Numbers
(define (zero? n)
(= n 0))
(define (positive? x)
(> x 0))
(define (negative? x)
(< x 0))
(define (odd? n)
(= 0 (floor-remainder n 2)))
(define (even? n)
(= 1 (floor-remainder n 2)))
(define (min x . args)
(let loop ((pivot x) (rest args))
(if (null? rest)
pivot
(loop (if (< pivot (car rest)) pivot (car rest)) (cdr rest)))))
(define (max x . args)
(let loop ((pivot x) (rest args))
(if (null? rest)
pivot
(loop (if (> pivot (car rest)) pivot (car rest)) (cdr rest)))))
(define (floor/ n m) (define (floor/ n m)
(values (floor-quotient n m) (values (floor-quotient n m)
(floor-remainder n m))) (floor-remainder n m)))
@ -435,28 +376,8 @@
(let ((n (exact (floor (sqrt k))))) (let ((n (exact (floor (sqrt k)))))
(values n (- k (square n))))) (values n (- k (square n)))))
(define (gcd n m) (export floor/ truncate/
(if (negative? n) exact-integer-sqrt)
(set! n (- n)))
(if (negative? m)
(set! m (- m)))
(if (> n m)
((lambda (tmp)
(set! n m)
(set! m tmp))
n))
(if (zero? n)
m
(gcd (floor-remainder m n) n)))
(define (lcm n m)
(/ (* n m) (gcd n m)))
(export zero? positive? negative?
odd? even? min max
floor/ truncate/
exact-integer-sqrt
gcd lcm)
;;; 6.3 Booleans ;;; 6.3 Booleans
@ -468,72 +389,6 @@
;;; 6.4 Pairs and lists ;;; 6.4 Pairs and lists
(define (list? obj)
(if (null? obj)
#t
(if (pair? obj)
(list? (cdr obj))
#f)))
(define (list . args)
args)
(define (caar p)
(car (car p)))
(define (cadr p)
(car (cdr p)))
(define (cdar p)
(cdr (car p)))
(define (cddr p)
(cdr (cdr p)))
(define (make-list k . args)
(if (null? args)
(make-list k #f)
(if (zero? k)
'()
(cons (car args)
(make-list (- k 1) (car args))))))
(define (length list)
(if (null? list)
0
(+ 1 (length (cdr list)))))
(define (append xs ys)
(if (null? xs)
ys
(cons (car xs)
(append (cdr xs) ys))))
(define (reverse list . args)
(if (null? args)
(reverse list '())
(if (null? list)
(car args)
(reverse (cdr list)
(cons (car list) (car args))))))
(define (list-tail list k)
(if (zero? k)
list
(list-tail (cdr list) (- k 1))))
(define (list-ref list k)
(car (list-tail list k)))
(define (list-set! list k obj)
(set-car! (list-tail list k) obj))
(define (list-copy obj)
(if (null? obj)
obj
(cons (car obj)
(list-copy (cdr obj)))))
(define (memq obj list) (define (memq obj list)
(if (null? list) (if (null? list)
#f #f
@ -578,10 +433,7 @@
(car list) (car list)
(assoc obj (cdr list) compare))))) (assoc obj (cdr list) compare)))))
(export list? list caar cadr cdar cddr (export memq memv member
make-list length append reverse
list-tail list-ref list-set! list-copy
memq memv member
assq assv assoc) assq assv assoc)
;;; 6.5. Symbols ;;; 6.5. Symbols
@ -825,39 +677,6 @@
;;; 6.10 control features ;;; 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)
#f
(begin
(f (car list))
(single-for-each f (cdr list)))))
(define (multiple-for-each f lists)
(if (any null? lists)
#f
(begin
(apply f (map car lists))
(multiple-for-each f (map cdr lists)))))
(if (null? lists)
(single-for-each f list)
(multiple-for-each f (cons list lists))))
(define (string-map f v . vs) (define (string-map f v . vs)
(let* ((len (fold min (string-length v) (map string-length vs))) (let* ((len (fold min (string-length v) (map string-length vs)))
(vec (make-string len))) (vec (make-string len)))
@ -896,8 +715,7 @@
(map (lambda (v) (vector-ref v n)) vs)) (map (lambda (v) (vector-ref v n)) vs))
(loop (+ n 1)))))) (loop (+ n 1))))))
(export map for-each (export string-map string-for-each
string-map string-for-each
vector-map vector-for-each) vector-map vector-for-each)
;;; 6.13. Input and output ;;; 6.13. Input and output

192
src/number.c
View File

@ -4,9 +4,28 @@
#include <math.h> #include <math.h>
#include <limits.h> #include <limits.h>
#include <stdlib.h>
#include "picrin.h" #include "picrin.h"
static int
gcd(int a, int b)
{
if (a > b)
return gcd(b, a);
if (a < 0)
return gcd(-a, b);
if (a > 0)
return gcd(b % a, a);
return b;
}
static int
lcm(int a, int b)
{
return abs(a * b) / gcd(a, b);
}
static pic_value static pic_value
pic_number_real_p(pic_state *pic) pic_number_real_p(pic_state *pic)
{ {
@ -133,6 +152,112 @@ DEFINE_ARITH_CMP(>, gt)
DEFINE_ARITH_CMP(<=, le) DEFINE_ARITH_CMP(<=, le)
DEFINE_ARITH_CMP(>=, ge) DEFINE_ARITH_CMP(>=, ge)
static pic_value
pic_number_zero_p(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_bool_value(f == 0);
}
static pic_value
pic_number_positive_p(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_bool_value(f > 0);
}
static pic_value
pic_number_negative_p(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_bool_value(f < 0);
}
static pic_value
pic_number_odd_p(pic_state *pic)
{
int i;
pic_get_args(pic, "i", &i);
return pic_bool_value(i % 2 != 0);
}
static pic_value
pic_number_even_p(pic_state *pic)
{
int i;
pic_get_args(pic, "i", &i);
return pic_bool_value(i % 2 == 0);
}
static pic_value
pic_number_max(pic_state *pic)
{
size_t argc;
pic_value *argv;
int i;
double f;
bool e = true;
pic_get_args(pic, "*", &argc, &argv);
f = -INFINITY;
for (i = 0; i < argc; ++i) {
if (pic_int_p(argv[i])) {
f = fmax(f, pic_int(argv[i]));
}
else if (pic_float_p(argv[i])) {
e = false;
f = fmax(f, pic_float(argv[i]));
}
else {
pic_error(pic, "min: number required");
}
}
return e ? pic_int_value(f) : pic_float_value(f);
}
static pic_value
pic_number_min(pic_state *pic)
{
size_t argc;
pic_value *argv;
int i;
double f;
bool e = true;
pic_get_args(pic, "*", &argc, &argv);
f = INFINITY;
for (i = 0; i < argc; ++i) {
if (pic_int_p(argv[i])) {
f = fmin(f, pic_int(argv[i]));
}
else if (pic_float_p(argv[i])) {
e = false;
f = fmin(f, pic_float(argv[i]));
}
else {
pic_error(pic, "min: number required");
}
}
return e ? pic_int_value(f) : pic_float_value(f);
}
#define DEFINE_ARITH_OP(op, name, unit) \ #define DEFINE_ARITH_OP(op, name, unit) \
static pic_value \ static pic_value \
pic_number_##name(pic_state *pic) \ pic_number_##name(pic_state *pic) \
@ -283,6 +408,58 @@ pic_number_trunc_remainder(pic_state *pic)
} }
} }
static pic_value
pic_number_gcd(pic_state *pic)
{
size_t argc;
pic_value *args;
int r;
bool e = true;
pic_get_args(pic, "*", &argc, &args);
r = 0;
while (argc-- > 0) {
if (pic_int_p(args[argc])) {
r = gcd(r, pic_int(args[argc]));
}
else if (pic_float_p(args[argc])) {
e = false;
r = gcd(r, pic_float(args[argc]));
}
else {
pic_error(pic, "gcd: number required");
}
}
return e ? pic_int_value(r) : pic_float_value(r);
}
static pic_value
pic_number_lcm(pic_state *pic)
{
size_t argc;
pic_value *args;
int r;
bool e = true;
pic_get_args(pic, "*", &argc, &args);
r = 1;
while (argc-- > 0) {
if (pic_int_p(args[argc])) {
r = lcm(r, pic_int(args[argc]));
}
else if (pic_float_p(args[argc])) {
e = false;
r = lcm(r, pic_float(args[argc]));
}
else {
pic_error(pic, "lcm: number required");
}
}
return e ? pic_int_value(r) : pic_float_value(r);
}
static pic_value static pic_value
pic_number_floor(pic_state *pic) pic_number_floor(pic_state *pic)
{ {
@ -526,6 +703,17 @@ pic_init_number(pic_state *pic)
pic_defun(pic, ">=", pic_number_ge); pic_defun(pic, ">=", pic_number_ge);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
pic_defun(pic, "zero?", pic_number_zero_p);
pic_defun(pic, "positive?", pic_number_positive_p);
pic_defun(pic, "negative?", pic_number_negative_p);
pic_defun(pic, "odd?", pic_number_odd_p);
pic_defun(pic, "even?", pic_number_even_p);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "min", pic_number_min);
pic_defun(pic, "max", pic_number_max);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "+", pic_number_add); pic_defun(pic, "+", pic_number_add);
pic_defun(pic, "-", pic_number_sub); pic_defun(pic, "-", pic_number_sub);
pic_defun(pic, "*", pic_number_mul); pic_defun(pic, "*", pic_number_mul);
@ -539,6 +727,10 @@ pic_init_number(pic_state *pic)
pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
pic_defun(pic, "gcd", pic_number_gcd);
pic_defun(pic, "lcm", pic_number_lcm);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "floor", pic_number_floor); pic_defun(pic, "floor", pic_number_floor);
pic_defun(pic, "ceiling", pic_number_ceil); pic_defun(pic, "ceiling", pic_number_ceil);
pic_defun(pic, "truncate", pic_number_trunc); pic_defun(pic, "truncate", pic_number_trunc);

244
src/pair.c
View File

@ -48,8 +48,9 @@ pic_cdr(pic_state *pic, pic_value obj)
bool bool
pic_list_p(pic_state *pic, pic_value obj) pic_list_p(pic_state *pic, pic_value obj)
{ {
while (pic_pair_p(obj)) while (pic_pair_p(obj)) {
obj = pic_pair_ptr(obj)->cdr; obj = pic_pair_ptr(obj)->cdr;
}
return pic_nil_p(obj); return pic_nil_p(obj);
} }
@ -84,6 +85,20 @@ pic_list_from_array(pic_state *pic, size_t c, pic_value *vs)
return pic_reverse(pic, v); return pic_reverse(pic, v);
} }
pic_value
pic_make_list(pic_state *pic, int k, pic_value fill)
{
pic_value list;
int i;
list = pic_nil_value();
for (i = 0; i < k; ++i) {
list = pic_cons(pic, fill, list);
}
return list;
}
int int
pic_length(pic_state *pic, pic_value obj) pic_length(pic_state *pic, pic_value obj)
{ {
@ -114,6 +129,23 @@ pic_reverse(pic_state *pic, pic_value list)
return acc; return acc;
} }
pic_value
pic_append(pic_state *pic, pic_value xs, pic_value ys)
{
int ai = pic_gc_arena_preserve(pic);
if (pic_nil_p(xs)) {
return ys;
}
else {
xs = pic_cons(pic, pic_car(pic, xs), pic_append(pic, pic_cdr(pic, xs), ys));
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, xs);
return xs;
}
pic_value pic_value
pic_assq(pic_state *pic, pic_value key, pic_value assoc) pic_assq(pic_state *pic, pic_value key, pic_value assoc)
{ {
@ -181,12 +213,35 @@ pic_cddr(pic_state *pic, pic_value v)
} }
pic_value pic_value
pic_list_ref(pic_state *pic, pic_value list, int i) pic_list_tail(pic_state *pic, pic_value list, int i)
{ {
while (i-- > 0) { while (i-- > 0) {
list = pic_cdr(pic, list); list = pic_cdr(pic, list);
} }
return pic_car(pic, list); return list;
}
pic_value
pic_list_ref(pic_state *pic, pic_value list, int i)
{
return pic_car(pic, pic_list_tail(pic, list, i));
}
void
pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj)
{
pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj;
}
pic_value
pic_list_copy(pic_state *pic, pic_value obj)
{
if (pic_pair_p(obj)) {
return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj)));
}
else {
return obj;
}
} }
static pic_value static pic_value
@ -199,6 +254,16 @@ pic_pair_pair_p(pic_state *pic)
return pic_bool_value(pic_pair_p(v)); return pic_bool_value(pic_pair_p(v));
} }
static pic_value
pic_pair_cons(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
return pic_cons(pic, v, w);
}
static pic_value static pic_value
pic_pair_car(pic_state *pic) pic_pair_car(pic_state *pic)
{ {
@ -220,23 +285,43 @@ pic_pair_cdr(pic_state *pic)
} }
static pic_value static pic_value
pic_pair_null_p(pic_state *pic) pic_pair_caar(pic_state *pic)
{ {
pic_value v; pic_value v;
pic_get_args(pic, "o", &v); pic_get_args(pic, "o", &v);
return pic_bool_value(pic_nil_p(v)); return pic_caar(pic, v);
} }
static pic_value static pic_value
pic_pair_cons(pic_state *pic) pic_pair_cadr(pic_state *pic)
{ {
pic_value v,w; pic_value v;
pic_get_args(pic, "oo", &v, &w); pic_get_args(pic, "o", &v);
return pic_cons(pic, v, w); return pic_cadr(pic, v);
}
static pic_value
pic_pair_cdar(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cdar(pic, v);
}
static pic_value
pic_pair_cddr(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cddr(pic, v);
} }
static pic_value static pic_value
@ -267,14 +352,151 @@ pic_pair_set_cdr(pic_state *pic)
return pic_none_value(); return pic_none_value();
} }
static pic_value
pic_pair_null_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_nil_p(v));
}
static pic_value
pic_pair_list_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_list_p(pic, v));
}
static pic_value
pic_pair_make_list(pic_state *pic)
{
int i;
pic_value fill = pic_none_value();
pic_get_args(pic, "i|o", &i, &fill);
return pic_make_list(pic, i, fill);
}
static pic_value
pic_pair_list(pic_state *pic)
{
size_t argc;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
return pic_list_from_array(pic, argc, argv);
}
static pic_value
pic_pair_length(pic_state *pic)
{
pic_value list;
pic_get_args(pic, "o", &list);
return pic_int_value(pic_length(pic, list));
}
static pic_value
pic_pair_append(pic_state *pic)
{
size_t argc;
pic_value *args, list;
pic_get_args(pic, "*", &argc, &args);
list = args[--argc];
while (argc-- > 0) {
list = pic_append(pic, args[argc], list);
}
return list;
}
static pic_value
pic_pair_reverse(pic_state *pic)
{
pic_value list;
pic_get_args(pic, "o", &list);
return pic_reverse(pic, list);
}
static pic_value
pic_pair_list_tail(pic_state *pic)
{
pic_value list;
int i;
pic_get_args(pic, "oi", &list, &i);
return pic_list_tail(pic, list, i);
}
static pic_value
pic_pair_list_ref(pic_state *pic)
{
pic_value list;
int i;
pic_get_args(pic, "oi", &list, &i);
return pic_list_ref(pic, list, i);
}
static pic_value
pic_pair_list_set(pic_state *pic)
{
pic_value list, obj;
int i;
pic_get_args(pic, "oio", &list, &i, &obj);
pic_list_set(pic, list, i, obj);
return pic_none_value();
}
static pic_value
pic_pair_list_copy(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_list_copy(pic, obj);
}
void void
pic_init_pair(pic_state *pic) pic_init_pair(pic_state *pic)
{ {
pic_defun(pic, "pair?", pic_pair_pair_p); pic_defun(pic, "pair?", pic_pair_pair_p);
pic_defun(pic, "cons", pic_pair_cons);
pic_defun(pic, "car", pic_pair_car); pic_defun(pic, "car", pic_pair_car);
pic_defun(pic, "cdr", pic_pair_cdr); pic_defun(pic, "cdr", pic_pair_cdr);
pic_defun(pic, "null?", pic_pair_null_p);
pic_defun(pic, "cons", pic_pair_cons);
pic_defun(pic, "set-car!", pic_pair_set_car); pic_defun(pic, "set-car!", pic_pair_set_car);
pic_defun(pic, "set-cdr!", pic_pair_set_cdr); pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
pic_defun(pic, "caar", pic_pair_caar);
pic_defun(pic, "cadr", pic_pair_cadr);
pic_defun(pic, "cdar", pic_pair_cdar);
pic_defun(pic, "cddr", pic_pair_cddr);
pic_defun(pic, "null?", pic_pair_null_p);
pic_defun(pic, "list?", pic_pair_list_p);
pic_defun(pic, "make-list", pic_pair_make_list);
pic_defun(pic, "list", pic_pair_list);
pic_defun(pic, "length", pic_pair_length);
pic_defun(pic, "append", pic_pair_append);
pic_defun(pic, "reverse", pic_pair_reverse);
pic_defun(pic, "list-tail", pic_pair_list_tail);
pic_defun(pic, "list-ref", pic_pair_list_ref);
pic_defun(pic, "list-set!", pic_pair_list_set);
pic_defun(pic, "list-copy", pic_pair_list_copy);
} }

66
src/proc.c
View File

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