src/posix.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 #include <sys/stat.h>
  22 #include <sys/wait.h>
  23 #include <fcntl.h>
  24 #include <stdlib.h>
  25 #include <unistd.h>
  26
  27 int readchar ();
  28 int unreadchar ();
  29
  30 int
  31 peekchar ()
  32 {
  33   if (g_stdin >= 0)
  34     {
  35       int c = readchar ();
  36       unreadchar (c);
  37       return c;
  38     }
  39   SCM port = current_input_port ();
  40   return VALUE (CAR (STRING (port)));
  41 }
  42
  43 int
  44 readchar ()
  45 {
  46   if (g_stdin >= 0)
  47     return  getchar ();
  48   SCM port = current_input_port ();
  49   SCM string = STRING (port);
  50   if (string == cell_nil)
  51     return -1;
  52   int c = VALUE (CAR (string));
  53   STRING (port) = CDR (string);
  54   return c;
  55 }
  56
  57 int
  58 unreadchar (int c)
  59 {
  60   if (g_stdin >= 0)
  61     return ungetc (c, g_stdin);
  62   SCM port = current_input_port ();
  63   STRING (port) = cons (MAKE_CHAR (c), STRING (port));
  64   return c;
  65 }
  66
  67 SCM
  68 peek_byte ()
  69 {
  70   return MAKE_NUMBER (peekchar ());
  71 }
  72
  73 SCM
  74 read_byte ()
  75 {
  76   return MAKE_NUMBER (readchar ());
  77 }
  78
  79 SCM
  80 unread_byte (SCM i)
  81 {
  82   unreadchar (VALUE (i));
  83   return i;
  84 }
  85
  86 SCM
  87 peek_char ()
  88 {
  89   return MAKE_CHAR (peekchar ());
  90 }
  91
  92 SCM
  93 read_char ()
  94 {
  95   return MAKE_CHAR (readchar ());
  96 }
  97
  98 SCM
  99 unread_char (SCM i)
 100 {
 101   unreadchar (VALUE (i));
 102   return i;
 103 }
 104
 105 SCM
 106 write_char (SCM i) ///((arity . n))
 107 {
 108   write_byte (i);
 109   return i;
 110 }
 111
 112 SCM
 113 read_string ()
 114 {
 115   SCM lst = cell_nil;
 116   SCM c = read_char ();
 117   while (VALUE (c) != -1)
 118     {
 119       lst = append2 (lst, cons (c, cell_nil));
 120       c = read_char ();
 121     }
 122   return MAKE_STRING (lst);
 123 }
 124
 125 SCM
 126 write_byte (SCM x) ///((arity . n))
 127 {
 128   SCM c = car (x);
 129   SCM p = cdr (x);
 130   int fd = g_stdout;
 131   if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER && VALUE (CAR (p)) != 1)
 132     fd = VALUE (CAR (p));
 133   char cc = VALUE (c);
 134   write (fd, (char*)&cc, 1);
 135 #if !__MESC__
 136   assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
 137 #endif
 138   return c;
 139 }
 140
 141 char string_to_cstring_buf[4096];
 142 char const*
 143 string_to_cstring_ (SCM s, char *buf)
 144 {
 145   char *p = buf;
 146   s = STRING(s);
 147   while (s != cell_nil)
 148     {
 149       *p++ = VALUE (car (s));
 150       s = cdr (s);
 151     }
 152   *p = 0;
 153   return buf;
 154 }
 155
 156 char const*
 157 string_to_cstring (SCM s)
 158 {
 159   return string_to_cstring_ (s, string_to_cstring_buf);
 160 }
 161
 162 SCM
 163 getenv_ (SCM s) ///((name . "getenv"))
 164 {
 165   char *p;
 166   p = getenv (string_to_cstring (s));
 167   return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
 168 }
 169
 170 SCM
 171 setenv_ (SCM s, SCM v) ///((name . "setenv"))
 172 {
 173   char buf[1024];
 174   strcpy (buf, string_to_cstring (s));
 175   setenv (buf, string_to_cstring (v), 1);
 176   return cell_unspecified;
 177 }
 178
 179 SCM
 180 access_p (SCM file_name, SCM mode)
 181 {
 182   return access (string_to_cstring (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
 183 }
 184
 185 SCM
 186 current_input_port ()
 187 {
 188   if (g_stdin >= 0)
 189     return MAKE_NUMBER (g_stdin);
 190   SCM x = g_ports;
 191   while (x && PORT (CAR (x)) != g_stdin)
 192     x = CDR (x);
 193   return CAR (x);
 194 }
 195
 196 SCM
 197 open_input_file (SCM file_name)
 198 {
 199   return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY));
 200 }
 201
 202 SCM
 203 open_input_string (SCM string)
 204 {
 205   SCM port = MAKE_STRING_PORT (STRING (string));
 206   g_ports = cons (port, g_ports);
 207   return port;
 208 }
 209
 210 SCM
 211 set_current_input_port (SCM port)
 212 {
 213   SCM prev = current_input_port ();
 214   if (TYPE (port) == TNUMBER)
 215     g_stdin = VALUE (port) ? VALUE (port) : STDIN;
 216   else if (TYPE (port) == TPORT)
 217     g_stdin = PORT (port);
 218   return prev;
 219 }
 220
 221 SCM
 222 current_output_port ()
 223 {
 224   return MAKE_NUMBER (g_stdout);
 225 }
 226
 227 SCM
 228 open_output_file (SCM x) ///((arity . n))
 229 {
 230   SCM file_name = car (x);
 231   x = cdr (x);
 232   int mode = S_IRUSR|S_IWUSR;
 233   if (TYPE (x) == TPAIR && TYPE (car (x)) == TNUMBER)
 234     mode = VALUE (car (x));
 235   return MAKE_NUMBER (open (string_to_cstring (file_name), O_WRONLY|O_CREAT|O_TRUNC,mode));
 236 }
 237
 238 SCM
 239 set_current_output_port (SCM port)
 240 {
 241   g_stdout = VALUE (port) ? VALUE (port) : STDOUT;
 242   return current_output_port ();
 243 }
 244
 245 SCM
 246 force_output (SCM p) ///((arity . n))
 247 {
 248   return cell_unspecified;
 249 }
 250
 251 SCM
 252 chmod_ (SCM file_name, SCM mode) ///((name . "chmod"))
 253 {
 254   chmod (string_to_cstring (file_name), VALUE (mode));
 255   return cell_unspecified;
 256 }
 257
 258 SCM
 259 isatty_p (SCM port)
 260 {
 261   return isatty (VALUE (port)) ? cell_t : cell_f;
 262 }
 263
 264 SCM
 265 primitive_fork ()
 266 {
 267   return MAKE_NUMBER (fork ());
 268 }
 269
 270 SCM
 271 execl_ (SCM file_name, SCM args) ///((name . "execl"))
 272 {
 273   char *c_argv[100];
 274   int i = 0;
 275   int n = 0;
 276   c_argv[i++] = string_to_cstring_ (file_name, string_to_cstring_buf+n);
 277   n += length__ (STRING (file_name)) + 1;
 278   while (args != cell_nil)
 279     {
 280       assert (TYPE (CAR (args)) == TSTRING);
 281       assert (i < 20);
 282       c_argv[i++] = string_to_cstring_ (CAR (args), string_to_cstring_buf+n);
 283       n += length__ (STRING (CAR (args))) + 1;
 284       args = CDR (args);
 285     }
 286   c_argv[i] = 0;
 287   return MAKE_NUMBER (execve (c_argv[0], c_argv, g_environment));
 288 }
 289
 290 SCM
 291 waitpid_ (SCM pid, SCM options)
 292 {
 293   int status;
 294   int child = waitpid (VALUE (pid), &status, VALUE (options));
 295   return cons (MAKE_NUMBER (child), MAKE_NUMBER (status));
 296 }