lac : b83c46fb5bba76ef6b7d48e30169fa2e8a921398
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
33: int_print (FILE * fd, lreg_t lr)
34: {
35: intptr_t n;
36:
37: INT_UNBOX (lr, n);
38: fprintf (fd, "%ld", n);
39: }
40:
41: static lac_exttype_t int_ty = {
42: .name = "integer",
43: .print = int_print,
44: .equal = NULL,
45: };
46:
47:
48: /*
49: Additional procedures.
50: */
51:
52: #define _BINOP_CHECKS(a, b) \
53: _EXPECT_ARGS(args, 2); \
54: lreg_t arg1 = ARGEVAL(car(args), argenv); \
55: lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv); \
56: \
57: if ( !(lreg_type(arg1) == lreg_type(arg2)) \
58: || lreg_type(arg1) != LREG_INTEGER ) \
59: _ERROR_AND_RET("+ requires two integers"); \
60: \
61: lac_extty_unbox(arg1, (void **)&a); \
62: lac_extty_unbox(arg2, (void **)&b);
63:
64:
65: LAC_API static lreg_t
66: proc_plus (lreg_t args, lenv_t * argenv, lenv_t * env)
67: {
68: intptr_t n1, n2, n;
69: _BINOP_CHECKS (n1, n2);
70:
71: if (((n1 > 0) && (n2 > 0) && (n1 > (LONG_MAX - n2)))
72: || ((n1 < 0) && (n2 < 0) && (n1 < (LONG_MIN - n2))))
73: _ERROR_AND_RET ("+: Integer overflow\n");
74:
75: n = n1 + n2;
76: return lac_extty_box (LREG_INTEGER, (void *) n, 0);
77: }
78:
79: LAC_API static lreg_t
80: proc_minus (lreg_t args, lenv_t * argenv, lenv_t * env)
81: {
82: long n1, n2, n;
83: _BINOP_CHECKS (n1, n2);
84:
85: if (((n1 > 0) && (n2 < 0) && (n1 > (LONG_MAX + n2)))
86: || ((n1 < 0) && (n2 > 0) && (n1 < (LONG_MIN + n2))))
87: _ERROR_AND_RET ("-: Integer signed overflow\n");
88:
89: n = n1 - n2;
90: return lac_extty_box (LREG_INTEGER, (void *) n, 0);
91: }
92:
93: LAC_API static lreg_t
94: proc_star (lreg_t args, lenv_t * argenv, lenv_t * env)
95: {
96: long n1, n2, n;
97: _BINOP_CHECKS (n1, n2);
98:
99: if (n1 == 0 || n2 == 0)
100: goto mul_res;
101:
102: if (n1 > 0)
103: if (n2 > 0)
104: {
105: if (n1 > (LONG_MAX / (n2)))
106: goto mul_of;
107: }
108: else
109: {
110: if (n2 < (LONG_MIN / (n1)))
111: goto mul_of;
112: }
113: else if (n2 > 0)
114: {
115: if (n1 < (LONG_MIN / (n2)))
116: goto mul_of;
117: }
118: else
119: {
120: if (n2 < (LONG_MAX / (n1)))
121: goto mul_of;
122: }
123:
124: mul_res:
125: n = n1 * n2;
126: return lac_extty_box (LREG_INTEGER, (void *) n, 0);
127:
128: mul_of:
129: _ERROR_AND_RET ("*: Integer sign overflow\n");
130: return NIL;
131: }
132:
133: LAC_API static lreg_t
134: proc_mod (lreg_t args, lenv_t * argenv, lenv_t * env)
135: {
136: long n1, n2, n;
137: _BINOP_CHECKS (n1, n2);
138:
139: if ((n2 == 0) || ((n1 == LONG_MIN) && (n2 == -1)))
140: _ERROR_AND_RET ("\%% would overflow or divide by zero\n");
141:
142: n = n1 % n2;
143: return lac_extty_box (LREG_INTEGER, (void *) n, 0);
144: }
145:
146: LAC_API static lreg_t
147: proc_div (lreg_t args, lenv_t * argenv, lenv_t * env)
148: {
149: long n1, n2, n;
150: _BINOP_CHECKS (n1, n2);
151:
152: if ((n2 == 0) || ((n1 == LONG_MIN) && (n2 == -1)))
153: _ERROR_AND_RET ("\%% would overflow or divide by zero\n");
154:
155: n = n1 / n2;
156: return lac_extty_box (LREG_INTEGER, (void *) n, 0);
157: }
158:
159: LAC_API static lreg_t
160: proc_greater (lreg_t args, lenv_t * argenv, lenv_t * env)
161: {
162: long n1, n2;
163: _BINOP_CHECKS (n1, n2);
164: return n1 > n2 ? sym_true : sym_false;
165: }
166:
167: LAC_API static lreg_t
168: proc_greatereq (lreg_t args, lenv_t * argenv, lenv_t * env)
169: {
170: long n1, n2;
171: _BINOP_CHECKS (n1, n2);
172: return n1 >= n2 ? sym_true : sym_false;
173: }
174:
175: LAC_API static lreg_t
176: proc_less (lreg_t args, lenv_t * argenv, lenv_t * env)
177: {
178: long n1, n2;
179: _BINOP_CHECKS (n1, n2);
180: return n1 < n2 ? sym_true : sym_false;
181: }
182:
183: LAC_API static lreg_t
184: proc_lesseq (lreg_t args, lenv_t * argenv, lenv_t * env)
185: {
186: long n1, n2;
187: _BINOP_CHECKS (n1, n2);
188: return n1 <= n2 ? sym_true : sym_false;
189: }
190:
191: LAC_DEFINE_TYPE_PFUNC (integer, LREG_INTEGER);
192:
193: void
194: int_init (lenv_t * env)
195: {
196: lac_extty_register (LREG_INTEGER, &int_ty);
197: lac_extproc_register (env, "INTEGERP", LAC_TYPE_PFUNC (integer));
198: lac_extproc_register (env, "+", proc_plus);
199: lac_extproc_register (env, "-", proc_minus);
200: lac_extproc_register (env, "*", proc_star);
201: lac_extproc_register (env, "%", proc_mod);
202: lac_extproc_register (env, "/", proc_div);
203: lac_extproc_register (env, ">", proc_greater);
204: lac_extproc_register (env, ">=", proc_greatereq);
205: lac_extproc_register (env, "<", proc_less);
206: lac_extproc_register (env, "<=", proc_lesseq);
207: }
Generated by git2html.