core: Support x86_64.
[mes.git] / src / lib.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of GNU Mes.
6  *
7  * GNU Mes is free software; you can redistribute it and/or modify it
8  * under the terms of the GNU General Public License as published by
9  * the Free Software Foundation; either version 3 of the License, or (at
10  * your option) any later version.
11  *
12  * GNU Mes is distributed in the hope that it will be useful, but
13  * WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 int g_depth;
22 SCM fdisplay_ (SCM, int, int);
23
24 SCM
25 display_helper (SCM x, int cont, char* sep, int fd, int write_p)
26 {
27   fdputs (sep, fd);
28   if (g_depth == 0)
29     return cell_unspecified;
30   g_depth = g_depth - 1;
31
32   int t = TYPE (x);
33   if (t == TCHAR)
34     {
35       if (!write_p)
36         fdputc (VALUE (x), fd);
37       else
38         {
39           fdputs ("#\\", fd);
40           long v = VALUE (x);
41           if (v == '\0') fdputs ("nul", fd);
42           else if (v == '\a') fdputs ("alarm", fd);
43           else if (v == '\b') fdputs ("backspace", fd);
44           else if (v == '\t') fdputs ("tab", fd);
45           else if (v == '\n') fdputs ("newline", fd);
46           else if (v == '\v') fdputs ("vtab", fd);
47           else if (v == '\f') fdputs ("page", fd);
48           //Nyacc bug
49           // else if (v == '\r') fdputs ("return", fd);
50             else if (v == 13) fdputs ("return", fd);
51           else if (v == ' ') fdputs ("space", fd);
52           else fdputc (VALUE (x), fd);
53         }
54     }
55   else if (t == TCLOSURE)
56     {
57       fdputs ("#<closure ", fd);
58       display_helper (CDR (x), cont, "", fd, 0);
59       fdputs (">", fd);
60     }
61   else if (t == TFUNCTION)
62     {
63       fdputs ("#<procedure ", fd);
64       char const *p = "?";
65       if (FUNCTION (x).name != 0)
66         p = FUNCTION (x).name;
67       fdputs (p, fd);
68       fdputs ("[", fd);
69       fdputs (itoa (CDR (x)), fd);
70       fdputs (",", fd);
71       fdputs (itoa (x), fd);
72       fdputs ("]>", fd);
73     }
74   else if (t == TMACRO)
75     {
76       fdputs ("#<macro ", fd);
77       display_helper (CDR (x), cont, "", fd, 0);
78       fdputs (">", fd);
79     }
80   else if (t == TVARIABLE)
81     {
82       fdputs ("#<variable ", fd);
83       display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
84       fdputs (">", fd);
85     }
86   else if (t == TNUMBER)
87     {
88       fdputs (itoa (VALUE (x)), fd);
89     }
90   else if (t == TPAIR)
91     {
92       if (!cont)
93         fdputs ("(", fd);
94       if (CAR (x) == cell_circular
95           && CADR (x) != cell_closure)
96         {
97           fdputs ("(*circ* . ", fd);
98           int i = 0;
99           x = CDR (x);
100           while (x != cell_nil && i++ < 10)
101             {
102               fdisplay_ (CAAR (x), fd, write_p); fdputs (" ", fd);
103               x = CDR (x);
104             }
105           fdputs (" ...)", fd);
106         }
107       else
108         {
109           if (x && x != cell_nil)
110             fdisplay_ (CAR (x), fd, write_p);
111           if (CDR (x) && TYPE (CDR (x)) == TPAIR)
112             display_helper (CDR (x), 1, " ", fd, write_p);
113           else if (CDR (x) && CDR (x) != cell_nil)
114             {
115               if (TYPE (CDR (x)) != TPAIR)
116                 fdputs (" . ", fd);
117               fdisplay_ (CDR (x), fd, write_p);
118             }
119         }
120       if (!cont)
121         fdputs (")", fd);
122     }
123   else if (t == TKEYWORD
124            || t == TPORT
125            || t == TSPECIAL
126            || t == TSTRING
127            || t == TSYMBOL)
128     {
129       if (TYPE (x) == TPORT)
130         {
131           fdputs ("#<port ", fd);
132           fdputs (itoa (PORT (x)), fd);
133           fdputs (" " ,fd);
134         }
135       if (TYPE (x) == TKEYWORD)
136         fdputs ("#:", fd);
137       if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
138         fdputc ('"', fd);
139       SCM t = CAR (x);
140       while (t && t != cell_nil)
141         {
142           long v = write_p ? VALUE (CAR (t)) : -1;
143           if (v == '\0') fdputs ("\\0", fd);
144           else if (v == '\a') fdputs ("\\a", fd);
145           else if (v == '\b') fdputs ("\\b", fd);
146           else if (v == '\t') fdputs ("\\t", fd);
147           else if (v == '\v') fdputs ("\\v", fd);
148           else if (v == '\n') fdputs ("\\n", fd);
149           else if (v == '\f') fdputs ("\\f", fd);
150 #if 1 //__MESC__
151       //Nyacc bug
152           else if (v == 13) fdputs ("\\r", fd);
153           else if (v == 27) fdputs ("\\e", fd);
154 #else
155           //else if (v == '\r') fdputs ("\\r", fd);
156           //Nyacc crash
157           //else if (v == '\e') fdputs ("\\e", fd);
158 #endif
159           else if (v == '\\') fdputs ("\\\\", fd);
160           else if (v == '"') fdputs ("\\\"", fd);
161           else fdputc (VALUE (CAR (t)), fd);
162           t = CDR (t);
163         }
164       if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
165         fdputc ('"', fd);
166       if (TYPE (x) == TPORT)
167         fdputs (">", fd);
168     }
169   else if (t == TVECTOR)
170     {
171       fdputs ("#(", fd);
172       SCM t = CAR (x);
173       for (long i = 0; i < LENGTH (x); i++)
174         {
175           if (i)
176             fdputc (' ', fd);
177           fdisplay_ (VECTOR (x) + i, fd, write_p);
178         }
179       fdputc (')', fd);
180     }
181   else
182     {
183       fdputs ("<", fd);
184       fdputs (itoa (TYPE (x)), fd);
185       fdputs (":", fd);
186       fdputs (itoa (x), fd);
187       fdputs (">", fd);
188     }
189   return 0;
190 }
191
192 SCM
193 display_ (SCM x)
194 {
195   g_depth = 5;
196   return display_helper (x, 0, "", g_stdout, 0);
197 }
198
199 SCM
200 display_error_ (SCM x)
201 {
202   g_depth = 5;
203   return display_helper (x, 0, "", STDERR, 0);
204 }
205
206 SCM
207 display_port_ (SCM x, SCM p)
208 {
209   assert (TYPE (p) == TNUMBER);
210   return fdisplay_ (x, VALUE (p), 0);
211 }
212
213 SCM
214 write_ (SCM x)
215 {
216   g_depth = 5;
217   return display_helper (x, 0, "", g_stdout, 1);
218 }
219
220 SCM
221 write_error_ (SCM x)
222 {
223   g_depth = 5;
224   return display_helper (x, 0, "", STDERR, 1);
225 }
226
227 SCM
228 write_port_ (SCM x, SCM p)
229 {
230   assert (TYPE (p) == TNUMBER);
231   return fdisplay_ (x, VALUE (p), 1);
232 }
233
234 SCM
235 fdisplay_ (SCM x, int fd, int write_p) ///((internal))
236 {
237   g_depth = 5;
238   return display_helper (x, 0, "", fd, write_p);
239 }
240
241 SCM
242 exit_ (SCM x) ///((name . "exit"))
243 {
244   assert (TYPE (x) == TNUMBER);
245   exit (VALUE (x));
246 }
247
248 SCM
249 xassq (SCM x, SCM a) ///for speed in core only
250 {
251   while (a != cell_nil && x != CDAR (a))
252     a = CDR (a);
253   return a != cell_nil ? CAR (a) : cell_f;
254 }
255
256 SCM
257 memq (SCM x, SCM a)
258 {
259   int t = TYPE (x);
260   if (t == TCHAR
261       || t == TNUMBER)
262       {
263         SCM v = VALUE (x);
264         while (a != cell_nil && v != VALUE (CAR (a)))
265           a = CDR (a);
266       }
267     else if (t == TKEYWORD)
268       {
269         SCM v = STRING (x);
270         while (a != cell_nil && v != STRING (CAR (a)))
271           a = CDR (a);
272       }
273     else
274       while (a != cell_nil && x != CAR (a))
275         a = CDR (a);
276   return a != cell_nil ? a : cell_f;
277 }
278
279 SCM
280 equal2_p (SCM a, SCM b)
281 {
282  equal2:
283   if (a == b)
284     return cell_t;
285   if (TYPE (a) == TPAIR && TYPE (b) == TPAIR)
286     {
287       if (equal2_p (CAR (a), CAR (b)) == cell_t)
288         {
289           a = CDR (a);
290           b = CDR (b);
291           goto equal2;
292         }
293       return cell_f;
294     }
295   if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
296     {
297       a = STRING (a);
298       b = STRING (b);
299       goto equal2;
300     }
301   if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
302     {
303       if (LENGTH (a) != LENGTH (b))
304         return cell_f;
305       for (long i=0; i < LENGTH (a); i++)
306         {
307           SCM ai = VECTOR (a) + i;
308           SCM bi = VECTOR (b) + i;
309           if (TYPE (ai) == TREF)
310             ai = REF (ai);
311           if (TYPE (bi) == TREF)
312             bi = REF (bi);
313           if (equal2_p (ai, bi) == cell_f)
314             return cell_f;
315         }
316       return cell_t;
317     }
318   return eq_p (a, b);
319 }
320
321 SCM
322 last_pair (SCM x)
323 {
324   while (x != cell_nil && CDR (x) != cell_nil)
325     x = CDR (x);
326   return x;
327 }