core/mini-mes: Merge merge mes.c and mini-mes.c.
[mes.git] / lib.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017 Jan 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 #if _POSIX_SOURCE
23
24 char const*
25 itoa (int x)
26 {
27   static char buf[10];
28   char *p = buf+9;
29   *p-- = 0;
30
31   int sign = x < 0;
32   if (sign)
33     x = -x;
34   
35   do
36     {
37       *p-- = '0' + (x % 10);
38       x = x / 10;
39     } while (x);
40
41   if (sign)
42     *p-- = '-';
43
44   return p+1;
45 }
46
47 // from mlib.c
48 #define fputs fdputs
49 int
50 fdputs (char const* s, int fd)
51 {
52   int i = strlen (s);
53   write (fd, s, i);
54   return 0;
55 }
56
57 #ifdef putc
58 #undef putc
59 #endif
60 #define putc(x) fdputc(x, STDOUT)
61 #define fputc fdputc
62 int
63 fdputc (int c, int fd)
64 {
65   write (fd, (char*)&c, 1);
66   return 0;
67 }
68 #endif
69
70 SCM fdisplay_ (SCM, int);
71
72 SCM
73 display_helper (SCM x, int cont, char* sep, int fd)
74 {
75   fputs (sep, fd);
76   if (g_depth == 0) return cell_unspecified;
77   g_depth = g_depth - 1;
78   
79   switch (TYPE (x))
80     {
81     case TCHAR:
82       {
83         fputs ("#\\", fd);
84         fputc (VALUE (x), fd);
85         break;
86       }
87     case TFUNCTION:
88       {
89         fputs ("#<procedure ", fd);
90         char const *p = "?";
91         if (FUNCTION (x).name != 0)
92           p = FUNCTION (x).name;
93         fputs (p, fd);
94         fputs ("[", fd);
95         fputs (itoa (CDR (x)), fd);
96         fputs (",", fd);
97         fputs (itoa (x), fd);
98         fputs ("]>", fd);
99         break;
100       }
101     case TMACRO:
102       {
103         fputs ("#<macro ", fd);
104         display_helper (cdr (x), cont, "", fd);
105         fputs (">", fd);
106         break;
107       }
108     case TNUMBER:
109       {
110         fputs (itoa (VALUE (x)), fd);
111         break;
112       }
113     case TPAIR:
114       {
115         if (!cont) fputs ("(", fd);
116         if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
117         if (CDR (x) && TYPE (CDR (x)) == TPAIR)
118           display_helper (CDR (x), 1, " ", fd);
119         else if (CDR (x) && CDR (x) != cell_nil)
120           {
121             if (TYPE (CDR (x)) != TPAIR)
122               fputs (" . ", fd);
123             fdisplay_ (CDR (x), fd);
124           }
125         if (!cont) fputs (")", fd);
126         break;
127       }
128     case TSPECIAL:
129     case TSTRING:
130     case TSYMBOL:
131       {
132         SCM t = CAR (x);
133         while (t && t != cell_nil)
134           {
135             fputc (VALUE (CAR (t)), fd);
136             t = CDR (t);
137           }
138         break;
139       }
140     default:
141       {
142         fputs ("<", fd);
143         fputs (itoa (TYPE (x)), fd);
144         fputs (":", fd);
145         fputs (itoa (x), fd);
146         fputs (">", fd);
147         break;
148       }
149     }
150   return 0;
151 }
152
153 SCM
154 display_ (SCM x)
155 {
156   g_depth = 5;
157   return display_helper (x, 0, "", STDOUT);
158 }
159
160 SCM
161 display_error_ (SCM x)
162 {
163   g_depth = 5;
164   return display_helper (x, 0, "", STDERR);
165 }
166
167 SCM
168 fdisplay_ (SCM x, int fd) ///((internal))
169 {
170   g_depth = 5;
171   return display_helper (x, 0, "", fd);
172 }
173
174 SCM
175 exit_ (SCM x) ///((name . "exit"))
176 {
177   assert (TYPE (x) == TNUMBER);
178   exit (VALUE (x));
179 }
180
181 SCM
182 xassq (SCM x, SCM a) ///for speed in core only
183 {
184   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
185   return a != cell_nil ? CAR (a) : cell_f;
186 }
187
188 #if _POSIX_SOURCE
189 #undef fdputs
190 #undef fdputc
191 #endif