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