Merge branch 'master' into analyzer
Conflicts: include/picrin/pair.h src/pair.c
This commit is contained in:
Yuichi Nishiwaki
commit
2e28f604a6
|
|
@ -6,3 +6,6 @@ src/y.tab.h
|
|||
lib/libpicrin.so
|
||||
lib/libpicrin.so.dSYM
|
||||
.dir-locals.el
|
||||
GPATH
|
||||
GRTAGS
|
||||
GTAGS
|
||||
|
|
|
|||
|
|
@ -9,18 +9,16 @@
|
|||
extern "C" {
|
||||
#endif
|
||||
|
||||
enum pic_gc_mark {
|
||||
PIC_GC_UNMARK = 0,
|
||||
PIC_GC_MARK
|
||||
};
|
||||
#define PIC_GC_UNMARK 0
|
||||
#define PIC_GC_MARK 1
|
||||
|
||||
union header {
|
||||
struct {
|
||||
union header *ptr;
|
||||
size_t size;
|
||||
enum pic_gc_mark mark : 1;
|
||||
unsigned int mark : 1;
|
||||
} s;
|
||||
long alignment[2];
|
||||
long alignment[4];
|
||||
};
|
||||
|
||||
struct heap_page {
|
||||
|
|
|
|||
|
|
@ -16,9 +16,11 @@ pic_value pic_cdr(pic_state *, pic_value);
|
|||
bool pic_list_p(pic_state *, pic_value);
|
||||
pic_value pic_list(pic_state *, size_t, ...);
|
||||
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);
|
||||
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_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_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);
|
||||
void pic_list_set(pic_state *, pic_value, int, pic_value);
|
||||
pic_value pic_list_copy(pic_state *, pic_value);
|
||||
|
||||
#if defined(__cplusplus)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -35,31 +35,11 @@
|
|||
(define-library (picrin bootstrap-tools)
|
||||
(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 (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)))))
|
||||
|
||||
(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))
|
||||
(export cadar caddr cdddr))
|
||||
|
||||
;;; core syntaces
|
||||
(define-library (picrin core-syntax)
|
||||
|
|
@ -367,15 +347,6 @@
|
|||
(export make-parameter
|
||||
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)
|
||||
(if (null? list)
|
||||
#t
|
||||
|
|
@ -388,38 +359,8 @@
|
|||
s
|
||||
(fold f (f (car xs) s) (cdr xs))))
|
||||
|
||||
;;; FIXME forward declaration
|
||||
(define map #f)
|
||||
|
||||
;;; 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)
|
||||
(values (floor-quotient n m)
|
||||
(floor-remainder n m)))
|
||||
|
|
@ -435,28 +376,8 @@
|
|||
(let ((n (exact (floor (sqrt k)))))
|
||||
(values n (- k (square n)))))
|
||||
|
||||
(define (gcd n m)
|
||||
(if (negative? n)
|
||||
(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)
|
||||
(export floor/ truncate/
|
||||
exact-integer-sqrt)
|
||||
|
||||
;;; 6.3 Booleans
|
||||
|
||||
|
|
@ -468,72 +389,6 @@
|
|||
|
||||
;;; 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)
|
||||
(if (null? list)
|
||||
#f
|
||||
|
|
@ -578,10 +433,7 @@
|
|||
(car list)
|
||||
(assoc obj (cdr list) compare)))))
|
||||
|
||||
(export list? list caar cadr cdar cddr
|
||||
make-list length append reverse
|
||||
list-tail list-ref list-set! list-copy
|
||||
memq memv member
|
||||
(export memq memv member
|
||||
assq assv assoc)
|
||||
|
||||
;;; 6.5. Symbols
|
||||
|
|
@ -825,39 +677,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)
|
||||
#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)
|
||||
(let* ((len (fold min (string-length v) (map string-length vs)))
|
||||
(vec (make-string len)))
|
||||
|
|
@ -896,8 +715,7 @@
|
|||
(map (lambda (v) (vector-ref v n)) vs))
|
||||
(loop (+ n 1))))))
|
||||
|
||||
(export map for-each
|
||||
string-map string-for-each
|
||||
(export string-map string-for-each
|
||||
vector-map vector-for-each)
|
||||
|
||||
;;; 6.13. Input and output
|
||||
|
|
|
|||
192
src/number.c
192
src/number.c
|
|
@ -4,9 +4,28 @@
|
|||
|
||||
#include <math.h>
|
||||
#include <limits.h>
|
||||
#include <stdlib.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
|
||||
pic_number_real_p(pic_state *pic)
|
||||
{
|
||||
|
|
@ -133,6 +152,112 @@ DEFINE_ARITH_CMP(>, gt)
|
|||
DEFINE_ARITH_CMP(<=, le)
|
||||
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) \
|
||||
static pic_value \
|
||||
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
|
||||
pic_number_floor(pic_state *pic)
|
||||
{
|
||||
|
|
@ -526,6 +703,17 @@ pic_init_number(pic_state *pic)
|
|||
pic_defun(pic, ">=", pic_number_ge);
|
||||
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_sub);
|
||||
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_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, "ceiling", pic_number_ceil);
|
||||
pic_defun(pic, "truncate", pic_number_trunc);
|
||||
|
|
|
|||
244
src/pair.c
244
src/pair.c
|
|
@ -48,8 +48,9 @@ pic_cdr(pic_state *pic, pic_value obj)
|
|||
bool
|
||||
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;
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
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
|
||||
pic_length(pic_state *pic, pic_value obj)
|
||||
{
|
||||
|
|
@ -114,6 +129,23 @@ pic_reverse(pic_state *pic, pic_value list)
|
|||
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_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_list_ref(pic_state *pic, pic_value list, int i)
|
||||
pic_list_tail(pic_state *pic, pic_value list, int i)
|
||||
{
|
||||
while (i-- > 0) {
|
||||
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
|
||||
|
|
@ -199,6 +254,16 @@ pic_pair_pair_p(pic_state *pic)
|
|||
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
|
||||
pic_pair_car(pic_state *pic)
|
||||
{
|
||||
|
|
@ -220,23 +285,43 @@ pic_pair_cdr(pic_state *pic)
|
|||
}
|
||||
|
||||
static pic_value
|
||||
pic_pair_null_p(pic_state *pic)
|
||||
pic_pair_caar(pic_state *pic)
|
||||
{
|
||||
pic_value v;
|
||||
|
||||
pic_get_args(pic, "o", &v);
|
||||
|
||||
return pic_bool_value(pic_nil_p(v));
|
||||
return pic_caar(pic, v);
|
||||
}
|
||||
|
||||
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
|
||||
|
|
@ -267,14 +352,151 @@ pic_pair_set_cdr(pic_state *pic)
|
|||
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
|
||||
pic_init_pair(pic_state *pic)
|
||||
{
|
||||
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, "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-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
66
src/proc.c
|
|
@ -85,21 +85,73 @@ 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, pic_list_from_array(pic, argc, args));
|
||||
}
|
||||
|
||||
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
|
||||
|
|
@ -107,4 +159,6 @@ 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);
|
||||
pic_defun(pic, "for-each", pic_proc_for_each);
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue