core: Implement stack and frame.
[mes.git] / src / posix.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 #include <fcntl.h>
22 #include <stdlib.h>
23 #include <sys/stat.h>
24 #include <sys/time.h>
25 #include <sys/wait.h>
26 #include <time.h>
27 #include <unistd.h>
28
29 int readchar ();
30 int unreadchar ();
31
32 int
33 peekchar ()
34 {
35   if (g_stdin >= 0)
36     {
37       int c = readchar ();
38       unreadchar (c);
39       return c;
40     }
41   SCM port = current_input_port ();
42   return VALUE (CAR (STRING (port)));
43 }
44
45 int
46 readchar ()
47 {
48   if (g_stdin >= 0)
49     return fdgetc (g_stdin);
50   SCM port = current_input_port ();
51   SCM string = STRING (port);
52   if (string == cell_nil)
53     return -1;
54   int c = VALUE (CAR (string));
55   STRING (port) = CDR (string);
56   return c;
57 }
58
59 int
60 unreadchar (int c)
61 {
62   if (g_stdin >= 0)
63     return fdungetc (c, g_stdin);
64   SCM port = current_input_port ();
65   STRING (port) = cons (MAKE_CHAR (c), STRING (port));
66   return c;
67 }
68
69 SCM
70 peek_byte ()
71 {
72   return MAKE_NUMBER (peekchar ());
73 }
74
75 SCM
76 read_byte ()
77 {
78   return MAKE_NUMBER (readchar ());
79 }
80
81 SCM
82 unread_byte (SCM i)
83 {
84   unreadchar (VALUE (i));
85   return i;
86 }
87
88 SCM
89 peek_char ()
90 {
91   return MAKE_CHAR (peekchar ());
92 }
93
94 SCM
95 read_char ()
96 {
97   return MAKE_CHAR (readchar ());
98 }
99
100 SCM
101 unread_char (SCM i)
102 {
103   unreadchar (VALUE (i));
104   return i;
105 }
106
107 SCM
108 write_char (SCM i) ///((arity . n))
109 {
110   write_byte (i);
111   return i;
112 }
113
114 SCM
115 read_string ()
116 {
117   SCM lst = cell_nil;
118   SCM c = read_char ();
119   while (VALUE (c) != -1)
120     {
121       lst = append2 (lst, cons (c, cell_nil));
122       c = read_char ();
123     }
124   return MAKE_STRING (lst);
125 }
126
127 SCM
128 write_byte (SCM x) ///((arity . n))
129 {
130   SCM c = car (x);
131   SCM p = cdr (x);
132   int fd = g_stdout;
133   if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER && VALUE (CAR (p)) != 1)
134     fd = VALUE (CAR (p));
135   char cc = VALUE (c);
136   write (fd, (char*)&cc, 1);
137 #if !__MESC__
138   assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
139 #endif
140   return c;
141 }
142
143 char string_to_cstring_buf[4096];
144 char const*
145 string_to_cstring_ (SCM s, char *buf)
146 {
147   char *p = buf;
148   s = STRING(s);
149   while (s != cell_nil)
150     {
151       *p++ = VALUE (car (s));
152       s = cdr (s);
153     }
154   *p = 0;
155   return buf;
156 }
157
158 char const*
159 string_to_cstring (SCM s)
160 {
161   return string_to_cstring_ (s, string_to_cstring_buf);
162 }
163
164 SCM
165 getenv_ (SCM s) ///((name . "getenv"))
166 {
167   char *p;
168   p = getenv (string_to_cstring (s));
169   return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
170 }
171
172 SCM
173 setenv_ (SCM s, SCM v) ///((name . "setenv"))
174 {
175   char buf[1024];
176   strcpy (buf, string_to_cstring (s));
177   setenv (buf, string_to_cstring (v), 1);
178   return cell_unspecified;
179 }
180
181 SCM
182 access_p (SCM file_name, SCM mode)
183 {
184   return access (string_to_cstring (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
185 }
186
187 SCM
188 current_input_port ()
189 {
190   if (g_stdin >= 0)
191     return MAKE_NUMBER (g_stdin);
192   SCM x = g_ports;
193   while (x && PORT (CAR (x)) != g_stdin)
194     x = CDR (x);
195   return CAR (x);
196 }
197
198 SCM
199 open_input_file (SCM file_name)
200 {
201   return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY));
202 }
203
204 SCM
205 open_input_string (SCM string)
206 {
207   SCM port = MAKE_STRING_PORT (STRING (string));
208   g_ports = cons (port, g_ports);
209   return port;
210 }
211
212 SCM
213 set_current_input_port (SCM port)
214 {
215   SCM prev = current_input_port ();
216   if (TYPE (port) == TNUMBER)
217     g_stdin = VALUE (port) ? VALUE (port) : STDIN;
218   else if (TYPE (port) == TPORT)
219     g_stdin = PORT (port);
220   return prev;
221 }
222
223 SCM
224 current_output_port ()
225 {
226   return MAKE_NUMBER (g_stdout);
227 }
228
229 SCM
230 open_output_file (SCM x) ///((arity . n))
231 {
232   SCM file_name = car (x);
233   x = cdr (x);
234   int mode = S_IRUSR|S_IWUSR;
235   if (TYPE (x) == TPAIR && TYPE (car (x)) == TNUMBER)
236     mode = VALUE (car (x));
237   return MAKE_NUMBER (open (string_to_cstring (file_name), O_WRONLY|O_CREAT|O_TRUNC,mode));
238 }
239
240 SCM
241 set_current_output_port (SCM port)
242 {
243   g_stdout = VALUE (port) ? VALUE (port) : STDOUT;
244   return current_output_port ();
245 }
246
247 SCM
248 force_output (SCM p) ///((arity . n))
249 {
250   return cell_unspecified;
251 }
252
253 SCM
254 chmod_ (SCM file_name, SCM mode) ///((name . "chmod"))
255 {
256   chmod (string_to_cstring (file_name), VALUE (mode));
257   return cell_unspecified;
258 }
259
260 SCM
261 isatty_p (SCM port)
262 {
263   return isatty (VALUE (port)) ? cell_t : cell_f;
264 }
265
266 SCM
267 primitive_fork ()
268 {
269   return MAKE_NUMBER (fork ());
270 }
271
272 SCM
273 execl_ (SCM file_name, SCM args) ///((name . "execl"))
274 {
275   char *c_argv[1000];           // POSIX minimum 4096
276   int i = 0;
277   int n = 0;
278
279   if (length__ (args) > 1000)
280     error (cell_symbol_system_error,
281            cons (file_name,
282                  cons (MAKE_STRING (cstring_to_list ("too many arguments")),
283                        cons (file_name, args))));
284   c_argv[i++] = (char*)string_to_cstring_ (file_name, string_to_cstring_buf+n);
285   n += length__ (STRING (file_name)) + 1;
286   while (args != cell_nil)
287     {
288       assert (TYPE (CAR (args)) == TSTRING);
289       c_argv[i++] = (char*)string_to_cstring_ (CAR (args), string_to_cstring_buf+n);
290       n += length__ (STRING (CAR (args))) + 1;
291       args = CDR (args);
292       if (g_debug > 2)
293         {
294           eputs ("arg["); eputs (itoa (i)); eputs ("]: "); eputs (c_argv[i-1]); eputs ("\n");
295         }
296     }
297   c_argv[i] = 0;
298   return MAKE_NUMBER (execv (c_argv[0], c_argv));
299 }
300
301 SCM
302 waitpid_ (SCM pid, SCM options)
303 {
304   int status;
305   int child = waitpid (VALUE (pid), &status, VALUE (options));
306   return cons (MAKE_NUMBER (child), MAKE_NUMBER (status));
307 }
308
309 #if __x86_64__
310 /* Nanoseconds on 64-bit systems with POSIX timers.  */
311 #define TIME_UNITS_PER_SECOND 1000000000
312 #else
313 /* Milliseconds for everyone else.  */
314 #define TIME_UNITS_PER_SECOND 1000
315 #endif
316
317 struct timespec g_start_time;
318 SCM
319 init_time (SCM a) ///((internal))
320 {
321   clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &g_start_time);
322   a = acons (cell_symbol_internal_time_units_per_second, MAKE_NUMBER (TIME_UNITS_PER_SECOND), a);
323 }
324
325 SCM
326 current_time ()
327 {
328   return MAKE_NUMBER (time (0));
329 }
330
331 SCM
332 gettimeofday_ () ///((name . "gettimeofday"))
333 {
334   struct timeval time;
335   gettimeofday (&time, 0);
336   return cons (MAKE_NUMBER (time.tv_sec), MAKE_NUMBER (time.tv_usec));
337 }
338
339 long
340 seconds_and_nanoseconds_to_long (long s, long ns)
341 {
342   return s * TIME_UNITS_PER_SECOND
343     + ns / (1000000000 / TIME_UNITS_PER_SECOND);
344 }
345
346 SCM
347 get_internal_run_time ()
348 {
349   struct timespec ts;
350   clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
351   long time = seconds_and_nanoseconds_to_long (ts.tv_sec - g_start_time.tv_sec,
352                                                ts.tv_nsec - g_start_time.tv_nsec);
353   return MAKE_NUMBER (time);
354 }