1 /* -*-comment-start: "//";comment-end:""-*-
2 * Mes --- Maxwell Equations of Software
3 * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 * This file is part of Mes.
7 * 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.
12 * 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.
17 * You should have received a copy of the GNU General Public License
18 * along with Mes. If not, see <http://www.gnu.org/licenses/>.
22 SCM fdisplay_ (SCM, int, int);
25 display_helper (SCM x, int cont, char* sep, int fd, int write_p)
29 return cell_unspecified;
30 g_depth = g_depth - 1;
37 fputc (VALUE (x), fd);
43 case '\0': fputs ("nul", fd); break;
44 case '\a': fputs ("alarm", fd); break;
45 case '\b': fputs ("backspace", fd); break;
46 case '\t': fputs ("tab", fd); break;
47 case '\n': fputs ("newline", fd); break;
48 case '\v': fputs ("vtab", fd); break;
49 case '\f': fputs ("page", fd); break;
51 // case '\r': fputs ("return", fd); break;
52 case 13: fputs ("return", fd); break;
53 case ' ': fputs ("space", fd); break;
54 default: fputc (VALUE (x), fd);
61 fputs ("#<closure ", fd);
62 display_helper (CDR (x), cont, "", fd, 0);
68 fputs ("#<procedure ", fd);
70 if (FUNCTION (x).name != 0)
71 p = FUNCTION (x).name;
74 fputs (itoa (CDR (x)), fd);
82 fputs ("#<macro ", fd);
83 display_helper (CDR (x), cont, "", fd, 0);
89 fputs ("#<variable ", fd);
90 display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
96 fputs (itoa (VALUE (x)), fd);
103 if (CAR (x) == cell_circular
104 && CADR (x) != cell_closure)
106 fputs ("(*circ* . ", fd);
109 while (x != cell_nil && i++ < 10)
111 fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
118 if (x && x != cell_nil)
119 fdisplay_ (CAR (x), fd, write_p);
120 if (CDR (x) && TYPE (CDR (x)) == TPAIR)
121 display_helper (CDR (x), 1, " ", fd, write_p);
122 else if (CDR (x) && CDR (x) != cell_nil)
124 if (TYPE (CDR (x)) != TPAIR)
126 fdisplay_ (CDR (x), fd, write_p);
138 if (TYPE (x) == TKEYWORD)
140 if (write_p && TYPE (x) == TSTRING)
143 while (t && t != cell_nil)
145 switch (write_p ? VALUE (CAR (t)) : -1)
147 case '\0': fputs ("\\0", fd); break;
148 case '\a': fputs ("\\a", fd); break;
149 case '\b': fputs ("\\b", fd); break;
150 case '\t': fputs ("\\t", fd); break;
151 case '\v': fputs ("\\v", fd); break;
152 case '\n': fputs ("\\n", fd); break;
153 case '\f': fputs ("\\f", fd); break;
156 case 13: fputs ("\\r", fd); break;
157 case 27: fputs ("\\e", fd); break;
159 //case '\r': fputs ("\\r", fd); break;
161 //case '\e': fputs ("\\e", fd); break;
163 case '\\': fputs ("\\\\", fd); break;
164 case '"': fputs ("\\\"", fd); break;
166 fputc (VALUE (CAR (t)), fd);
170 if (write_p && TYPE (x) == TSTRING)
178 for (int i = 0; i < LENGTH (x); i++)
182 fdisplay_ (VECTOR (x) + i, fd, write_p);
190 fputs (itoa (TYPE (x)), fd);
192 fputs (itoa (x), fd);
204 return display_helper (x, 0, "", g_stdout, 0);
208 display_error_ (SCM x)
211 return display_helper (x, 0, "", STDERR, 0);
215 display_port_ (SCM x, SCM p)
217 assert (TYPE (p) == TNUMBER);
218 return fdisplay_ (x, VALUE (p), 0);
225 return display_helper (x, 0, "", g_stdout, 1);
232 return display_helper (x, 0, "", STDERR, 1);
236 write_port_ (SCM x, SCM p)
238 assert (TYPE (p) == TNUMBER);
239 return fdisplay_ (x, VALUE (p), 1);
243 fdisplay_ (SCM x, int fd, int write_p) ///((internal))
246 return display_helper (x, 0, "", fd, write_p);
250 exit_ (SCM x) ///((name . "exit"))
252 assert (TYPE (x) == TNUMBER);
257 xassq (SCM x, SCM a) ///for speed in core only
259 while (a != cell_nil && x != CDAR (a))
261 return a != cell_nil ? CAR (a) : cell_f;
273 while (a != cell_nil && v != VALUE (CAR (a)))
280 while (a != cell_nil && v != STRING (CAR (a)))
287 while (a != cell_nil && x != CAR (a))
290 return a != cell_nil ? a : cell_f;
294 equal2_p (SCM a, SCM b)
296 if (a == cell_nil && b == cell_nil)
298 if (TYPE (a) == TPAIR && TYPE (b) == TPAIR)
299 return equal2_p (CAR (a), CAR (b)) == cell_t
300 && equal2_p (CDR (a), CDR (b)) == cell_t
302 if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
303 return equal2_p (STRING (a), STRING (b));
304 if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
306 if (LENGTH (a) != LENGTH (b))
308 for (int i=0; i < LENGTH (a); i++)
310 SCM ai = VECTOR (a) + i;
311 SCM bi = VECTOR (b) + i;
312 if (TYPE (ai) == TREF)
314 if (TYPE (bi) == TREF)
316 if (equal2_p (ai, bi) == cell_f)