core: display_helper: Display escaped characters.
[mes.git] / src / lib.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of Mes.
6  *
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.
11  *
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.
16  *
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/>.
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   fputs (sep, fd);
28   if (g_depth == 0)
29     return cell_unspecified;
30   g_depth = g_depth - 1;
31   
32   switch (TYPE (x))
33     {
34     case TCHAR:
35       {
36         if (!write_p)
37           fputc (VALUE (x), fd);
38         else
39           {
40             fputs ("#\\", fd);
41             switch (VALUE (x))
42               {
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;
50                 //Nyacc bug
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);
55               }
56           }
57         break;
58       }
59     case TCLOSURE:
60       {
61         fputs ("#<closure ", fd);
62         display_helper (CDR (x), cont, "", fd, 0);
63         fputs (">", fd);
64         break;
65       }
66     case TFUNCTION:
67       {
68         fputs ("#<procedure ", fd);
69         char const *p = "?";
70         if (FUNCTION (x).name != 0)
71           p = FUNCTION (x).name;
72         fputs (p, fd);
73         fputs ("[", fd);
74         fputs (itoa (CDR (x)), fd);
75         fputs (",", fd);
76         fputs (itoa (x), fd);
77         fputs ("]>", fd);
78         break;
79       }
80     case TMACRO:
81       {
82         fputs ("#<macro ", fd);
83         display_helper (CDR (x), cont, "", fd, 0);
84         fputs (">", fd);
85         break;
86       }
87     case TVARIABLE:
88       {
89         fputs ("#<variable ", fd);
90         display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
91         fputs (">", fd);
92         break;
93       }
94     case TNUMBER:
95       {
96         fputs (itoa (VALUE (x)), fd);
97         break;
98       }
99     case TPAIR:
100       {
101         if (!cont)
102           fputs ("(", fd);
103         if (CAR (x) == cell_circular
104             && CADR (x) != cell_closure)
105           {
106             fputs ("(*circ* . ", fd);
107             int i = 0;
108             x = CDR (x);
109             while (x != cell_nil && i++ < 10)
110               {
111                 fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
112                 x = CDR (x);
113               }
114             fputs (" ...)", fd);
115           }
116         else
117           {
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)
123               {
124                 if (TYPE (CDR (x)) != TPAIR)
125                   fputs (" . ", fd);
126                 fdisplay_ (CDR (x), fd, write_p);
127               }
128           }
129         if (!cont)
130           fputs (")", fd);
131         break;
132       }
133     case TKEYWORD:
134     case TSPECIAL:
135     case TSTRING:
136     case TSYMBOL:
137       {
138         if (TYPE (x) == TKEYWORD)
139           fputs ("#:", fd);
140         if (write_p && TYPE (x) == TSTRING)
141           fputc ('"', fd);
142         SCM t = CAR (x);
143         while (t && t != cell_nil)
144           {
145             switch (write_p ? VALUE (CAR (t)) : -1)
146               {
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;
154 #if 1 //__MESC__
155       //Nyacc bug
156               case 13: fputs ("\\r", fd); break;
157               case 27: fputs ("\\e", fd); break;
158 #else
159                 //case '\r': fputs ("\\r", fd); break;
160                 //Nyacc crash
161                 //case '\e': fputs ("\\e", fd); break;
162 #endif
163               case '\\': fputs ("\\\\", fd); break;
164               case '"': fputs ("\\\"", fd); break;
165               default:
166                 fputc (VALUE (CAR (t)), fd);
167               }
168             t = CDR (t);
169           }
170         if (write_p && TYPE (x) == TSTRING)
171           fputc ('"', fd);
172         break;
173       }
174     case TVECTOR:
175       {
176         fputs ("#(", fd);
177         SCM t = CAR (x);
178         for (int i = 0; i < LENGTH (x); i++)
179           {
180             if (i)
181               fputc (' ', fd);
182             fdisplay_ (VECTOR (x) + i, fd, write_p);
183           }
184         fputc (')', fd);
185         break;
186       }
187     default:
188       {
189         fputs ("<", fd);
190         fputs (itoa (TYPE (x)), fd);
191         fputs (":", fd);
192         fputs (itoa (x), fd);
193         fputs (">", fd);
194         break;
195       }
196     }
197   return 0;
198 }
199
200 SCM
201 display_ (SCM x)
202 {
203   g_depth = 5;
204   return display_helper (x, 0, "", g_stdout, 0);
205 }
206
207 SCM
208 display_error_ (SCM x)
209 {
210   g_depth = 5;
211   return display_helper (x, 0, "", STDERR, 0);
212 }
213
214 SCM
215 display_port_ (SCM x, SCM p)
216 {
217   assert (TYPE (p) == TNUMBER);
218   return fdisplay_ (x, VALUE (p), 0);
219 }
220
221 SCM
222 write_ (SCM x)
223 {
224   g_depth = 5;
225   return display_helper (x, 0, "", g_stdout, 1);
226 }
227
228 SCM
229 write_error_ (SCM x)
230 {
231   g_depth = 5;
232   return display_helper (x, 0, "", STDERR, 1);
233 }
234
235 SCM
236 write_port_ (SCM x, SCM p)
237 {
238   assert (TYPE (p) == TNUMBER);
239   return fdisplay_ (x, VALUE (p), 1);
240 }
241
242 SCM
243 fdisplay_ (SCM x, int fd, int write_p) ///((internal))
244 {
245   g_depth = 5;
246   return display_helper (x, 0, "", fd, write_p);
247 }
248
249 SCM
250 exit_ (SCM x) ///((name . "exit"))
251 {
252   assert (TYPE (x) == TNUMBER);
253   exit (VALUE (x));
254 }
255
256 SCM
257 xassq (SCM x, SCM a) ///for speed in core only
258 {
259   while (a != cell_nil && x != CDAR (a))
260     a = CDR (a);
261   return a != cell_nil ? CAR (a) : cell_f;
262 }
263
264 SCM
265 memq (SCM x, SCM a)
266 {
267   switch (TYPE (x))
268     {
269     case TCHAR:
270     case TNUMBER:
271       {
272         SCM v = VALUE (x);
273         while (a != cell_nil && v != VALUE (CAR (a)))
274           a = CDR (a);
275         break;
276       }
277     case TKEYWORD:
278       {
279         SCM v = STRING (x);
280         while (a != cell_nil && v != STRING (CAR (a)))
281           a = CDR (a);
282         break;
283       }
284       // case TSYMBOL:
285       // case TSPECIAL:
286     default:
287       while (a != cell_nil && x != CAR (a))
288         a = CDR (a);
289     }
290   return a != cell_nil ? a : cell_f;
291 }
292
293 SCM
294 equal2_p (SCM a, SCM b)
295 {
296   if (a == cell_nil && b == cell_nil)
297     return cell_t;
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
301       ? cell_t : cell_f;
302   if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
303     return equal2_p (STRING (a), STRING (b));
304   if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
305     {
306       if (LENGTH (a) != LENGTH (b))
307         return cell_f;
308       for (int i=0; i < LENGTH (a); i++)
309         {
310           SCM ai = VECTOR (a) + i;
311           SCM bi = VECTOR (b) + i;
312           if (TYPE (ai) == TREF)
313             ai = REF (ai);
314           if (TYPE (bi) == TREF)
315             bi = REF (bi);
316           if (equal2_p (ai, bi) == cell_f)
317             return cell_f;
318         }
319       return cell_t;
320     }
321   return eq_p (a, b);
322 }