lac : ed225f50b0a9bc12fb33de17ef35b50f8c0ba18f
1: /*
2: lac -- a lisp interpreter
3: Copyright (C) 2010 Gianluca Guida
4:
5: This program is free software; you can redistribute it and/or modify
6: it under the terms of the GNU General Public License as published by
7: the Free Software Foundation; either version 2 of the License, or
8: (at your option) any later version.
9:
10: This program is distributed in the hope that it will be useful,
11: but WITHOUT ANY WARRANTY; without even the implied warranty of
12: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13: GNU General Public License for more details.
14:
15: You should have received a copy of the GNU General Public License along
16: with this program; if not, write to the Free Software Foundation, Inc.,
17: 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
18: */
19:
20: #include "lac.h"
21: #include <stdio.h>
22: #include <limits.h>
23:
24: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
25:
26: #define INT_UNBOX(lr, n) lac_extty_unbox(lr, (void **)&(n))
27:
28: /*
29: LAC Type Interface.
30: */
31:
32: static void int_print(FILE *fd, lreg_t lr)
33: {
34: intptr_t n;
35:
36: INT_UNBOX(lr, n);
37: fprintf(fd, "%ld", n);
38: }
39:
40: static lac_exttype_t int_ty = {
41: .name = "integer",
42: .print = int_print,
43: .equal = NULL,
44: };
45:
46:
47: /*
48: Additional procedures.
49: */
50:
51: #define _BINOP_CHECKS(a, b) \
52: _EXPECT_ARGS(args, 2); \
53: lreg_t arg1 = ARGEVAL(car(args), argenv); \
54: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv); \
55: \
56: if ( !(lreg_type(arg1) == lreg_type(arg2)) \
57: || lreg_type(arg1) != LREG_INTEGER ) \
58: _ERROR_AND_RET("+ requires two integers"); \
59: \
60: lac_extty_unbox(arg1, (void **)&a); \
61: lac_extty_unbox(arg2, (void **)&b);
62:
63:
64: LAC_API static lreg_t proc_plus(lreg_t args, lenv_t *argenv, lenv_t *env)
65: {
66: intptr_t n1, n2, n;
67: _BINOP_CHECKS(n1, n2);
68:
69: if ( ((n1>0) && (n2>0) && (n1 > (LONG_MAX-n2)))
70: || ((n1<0) && (n2<0) && (n1 < (LONG_MIN-n2))) )
71: _ERROR_AND_RET("+: Integer overflow\n");
72:
73: n = n1 + n2;
74: return lac_extty_box(LREG_INTEGER, (void *)n, 0);
75: }
76:
77: LAC_API static lreg_t proc_minus(lreg_t args, lenv_t *argenv, lenv_t *env)
78: {
79: long n1, n2, n;
80: _BINOP_CHECKS(n1, n2);
81:
82: if ( ((n1>0) && (n2 < 0) && (n1 > (LONG_MAX+n2)))
83: || ((n1<0) && (n2>0) && (n1 < (LONG_MIN + n2))) )
84: _ERROR_AND_RET("-: Integer signed overflow\n");
85:
86: n = n1 - n2;
87: return lac_extty_box(LREG_INTEGER, (void *)n, 0);
88: }
89:
90: LAC_API static lreg_t proc_star(lreg_t args, lenv_t *argenv, lenv_t *env)
91: {
92: long n1, n2, n;
93: _BINOP_CHECKS(n1, n2);
94:
95: if ( n1 == 0 || n2 == 0 )
96: goto mul_res;
97:
98: if ( n1 > 0 )
99: if ( n2 > 0 ) {
100: if ( n1>(LONG_MAX/(n2)) )
101: goto mul_of;
102: } else {
103: if ( n2<(LONG_MIN/(n1)) )
104: goto mul_of;
105: }
106: else
107: if ( n2 > 0 ) {
108: if ( n1<(LONG_MIN/(n2)) )
109: goto mul_of;
110: } else {
111: if ( n2 < (LONG_MAX/(n1)) )
112: goto mul_of;
113: }
114:
115: mul_res:
116: n = n1 * n2;
117: return lac_extty_box(LREG_INTEGER, (void *)n, 0);
118:
119: mul_of:
120: _ERROR_AND_RET("*: Integer sign overflow\n");
121: return NIL;
122: }
123:
124: LAC_API static lreg_t proc_mod(lreg_t args, lenv_t *argenv, lenv_t *env)
125: {
126: long n1, n2, n;
127: _BINOP_CHECKS(n1, n2);
128:
129: if ( (n2 == 0 ) || ( (n1 == LONG_MIN) && (n2 == -1) ) )
130: _ERROR_AND_RET("\%% would overflow or divide by zero\n");
131:
132: n = n1 % n2;
133: return lac_extty_box(LREG_INTEGER, (void *)n, 0);
134: }
135:
136: LAC_API static lreg_t proc_div(lreg_t args, lenv_t *argenv, lenv_t *env)
137: {
138: long n1, n2, n;
139: _BINOP_CHECKS(n1, n2);
140:
141: if ( (n2 == 0 ) || ( (n1 == LONG_MIN) && (n2 == -1) ) )
142: _ERROR_AND_RET("\%% would overflow or divide by zero\n");
143:
144: n = n1 / n2;
145: return lac_extty_box(LREG_INTEGER, (void *)n, 0);
146: }
147:
148: LAC_API static lreg_t proc_greater(lreg_t args, lenv_t *argenv, lenv_t *env)
149: {
150: long n1, n2;
151: _BINOP_CHECKS(n1, n2);
152: return n1 > n2 ? sym_true : sym_false;
153: }
154:
155: LAC_API static lreg_t proc_greatereq(lreg_t args, lenv_t *argenv, lenv_t *env)
156: {
157: long n1, n2;
158: _BINOP_CHECKS(n1, n2);
159: return n1 >= n2 ? sym_true : sym_false;
160: }
161:
162: LAC_API static lreg_t proc_less(lreg_t args, lenv_t *argenv, lenv_t *env)
163: {
164: long n1, n2;
165: _BINOP_CHECKS(n1, n2);
166: return n1 < n2 ? sym_true : sym_false;
167: }
168:
169: LAC_API static lreg_t proc_lesseq(lreg_t args, lenv_t *argenv, lenv_t *env)
170: {
171: long n1, n2;
172: _BINOP_CHECKS(n1, n2);
173: return n1 <= n2 ? sym_true : sym_false;
174: }
175:
176: LAC_DEFINE_TYPE_PFUNC(integer, LREG_INTEGER);
177:
178: void int_init(lenv_t *env)
179: {
180: lac_extty_register(LREG_INTEGER, &int_ty);
181: lac_extproc_register(env, "INTEGERP",LAC_TYPE_PFUNC(integer));
182: lac_extproc_register(env, "+", proc_plus);
183: lac_extproc_register(env, "-", proc_minus);
184: lac_extproc_register(env, "*", proc_star);
185: lac_extproc_register(env, "%", proc_mod);
186: lac_extproc_register(env, "/", proc_div);
187: lac_extproc_register(env, ">", proc_greater);
188: lac_extproc_register(env, ">=", proc_greatereq);
189: lac_extproc_register(env, "<", proc_less);
190: lac_extproc_register(env, "<=", proc_lesseq);
191: }
Generated by git2html.