libsi/utils.c at master · xudifsd/libsi · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
#include "utils.h"
#include "malloc.h"

void print(FILE *port, struct exp *e) {
	struct number *n;
	struct symbol *s;
	struct callable *c;
	struct pair *p;
	if (!e)
		fprintf(port, "()");
	else if (is_bool(e)) {
		if (((struct bool *)e)->value)
			fprintf(port, "#t");
		else
			fprintf(port, "#f");
	}
	else if (is_pair(e)) {
		fprintf(port, "(");
		for_pair(p, (struct pair *)e) {
			print(port, car(p));
			if (!is_pair(cdr(p)) && cdr(p) != NULL) {
				fprintf(port, ". ");
				print(port, cdr(p));
				break;
			}
		}
		fprintf(port, "\b)");
	} else if (is_number(e)) {
		n = (struct number *)e;
		if (is_long(n))
			fprintf(port, "%ld", n->l_value);
		else
			fprintf(port, "%.8f", n->d_value);
	} else if (is_symbol(e)) {
		s = (struct symbol *)e;
		fprintf(port, "%s", s->sym);
	} else if (is_callable(e)) {
		c = (struct callable *)e;
		if (is_builtin_pro(c))
			fprintf(port, "#<builtin procedure>");
		else if (is_builtin_syntax(c))
			fprintf(port, "#<builtin syntax>");
		else if (is_lambda(c)) {
			fprintf(port, "#<lambda with pars ");
			print(port, (struct exp *)c->u_value.pars);
			fprintf(port, ">");
		} else {
			/* is_macro(c) */
			fprintf(port, "#<macro with pars ");
			print(port, (struct exp *)c->u_value.pars);
			fprintf(port, ">");
		}
	}
	fputc(' ', port); /* makes output more beautiful */
}

enum rtn_type map(map_f fun, struct pair *args, struct pair **rtn) {
	struct pair *p;
	struct pair *value;
	struct exp *e;
	struct pair *head = NULL;
	struct pair **tail = &head;
	enum rtn_type r_type;

	for_pair(p, args) {
		if (!is_pair(cdr(p)) && cdr(p) != NULL) {
			*rtn = (struct pair *)alloc_err_msg("in map, args is not a list");
			return ERR_TYPE;
		}
		if ((r_type = fun(car(p), &e)) == SUCC) {
			value = alloc_pair(e, NULL);
			*tail = value;
			tail = (struct pair **)&value->cdr;
		} else {
			*rtn = (struct pair *)e;
			return r_type;
		}
	}
	*rtn = head;
	return SUCC;
}

/* if at_least is not 0, len should be at least nr_arg, not exactly */
enum rtn_type check_args(struct pair *args, unsigned int nr_arg, int at_least, struct exp **rtn) {
	unsigned int len = 0;
	struct pair *p;

	for_pair(p, args) {
		if (!is_pair(cdr(p)) && cdr(p) != NULL) {
			*rtn = (struct exp *)alloc_err_msg("in check_args, args is not list");
			return ERR_TYPE;
		}
		len++;
	}

	if (at_least && len < nr_arg) {
		*rtn = (struct exp *)alloc_err_msg("expect at least %d args, %d is given", nr_arg, len);
		return ERR_ARGC;
	} else if (!at_least && len != nr_arg) {
		*rtn = (struct exp *)alloc_err_msg("expect %d args, %d is given", nr_arg, len);
		return ERR_ARGC;
	} else
		return SUCC;
}

enum rtn_type last_element(struct pair *head, struct exp **rtn) {
	struct pair *p;
	for_pair(p, head) {
		if (!is_pair(cdr(p)) && cdr(p) != NULL) {
			*rtn = (struct exp *)alloc_err_msg("in last_element, not a list");
			return ERR_TYPE;
		} if (cdr(p) == NULL) {
			*rtn = car(p);
			return SUCC;
		}
	}
	*rtn = (struct exp *)alloc_err_msg("in last_element, not a list");
	return ERR_TYPE;
}

int above_zero(struct number *num) {
	if (is_long(num))
		return (num->l_value > 0);
	else
		return (num->d_value > 0);
}

int below_zero(struct number *num) {
	if (is_long(num))
		return (num->l_value < 0);
	else
		return (num->d_value < 0);
}

int equal_zero(struct number *num) {
	if (is_long(num))
		return (num->l_value == 0);
	else /* FIXME maybe we should not use == in double */
		return (num->d_value == 0);
}