tests/gpgscm/ffi.c

   1 /* FFI interface for TinySCHEME.
   2  *
   3  * Copyright (C) 2016 g10 code GmbH
   4  *
   5  * This file is part of GnuPG.
   6  *
   7  * GnuPG is free software; you can redistribute it and/or modify
   8  * it under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or
  10  * (at your option) any later version.
  11  *
  12  * GnuPG is distributed in the hope that it will be useful,
  13  * but 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 this program; if not, see <https://www.gnu.org/licenses/>.
  19  */
  20
  21 #include <config.h>
  22
  23 #include <assert.h>
  24 #include <ctype.h>
  25 #include <dirent.h>
  26 #include <errno.h>
  27 #include <fcntl.h>
  28 #include <gpg-error.h>
  29 #include <stdarg.h>
  30 #include <stdlib.h>
  31 #include <stdio.h>
  32 #include <string.h>
  33 #include <sys/types.h>
  34 #include <sys/stat.h>
  35 #include <unistd.h>
  36
  37 #if HAVE_LIBREADLINE
  38 #define GNUPG_LIBREADLINE_H_INCLUDED
  39 #include <readline/readline.h>
  40 #include <readline/history.h>
  41 #endif
  42
  43 #include "../../common/util.h"
  44 #include "../../common/exechelp.h"
  45 #include "../../common/sysutils.h"
  46
  47 #include "private.h"
  48 #include "ffi.h"
  49 #include "ffi-private.h"
  50
  51 /* For use in nice error messages.  */
  52 static const char *
  53 ordinal_suffix (int n)
  54 {
  55   switch (n)
  56     {
  57     case 1: return "st";
  58     case 2: return "nd";
  59     case 3: return "rd";
  60     default: return "th";
  61     }
  62   assert (! "reached");
  63 }
  64
  65 \f
  66
  67 int
  68 ffi_bool_value (scheme *sc, pointer p)
  69 {
  70   return ! (p == sc->F);
  71 }
  72
  73
  74 \f
  75 static pointer
  76 do_logand (scheme *sc, pointer args)
  77 {
  78   FFI_PROLOG ();
  79   unsigned int v, acc = ~0;
  80   while (args != sc->NIL)
  81     {
  82       FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
  83       acc &= v;
  84     }
  85   FFI_RETURN_INT (sc, acc);
  86 }
  87
  88 static pointer
  89 do_logior (scheme *sc, pointer args)
  90 {
  91   FFI_PROLOG ();
  92   unsigned int v, acc = 0;
  93   while (args != sc->NIL)
  94     {
  95       FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
  96       acc |= v;
  97     }
  98   FFI_RETURN_INT (sc, acc);
  99 }
 100
 101 static pointer
 102 do_logxor (scheme *sc, pointer args)
 103 {
 104   FFI_PROLOG ();
 105   unsigned int v, acc = 0;
 106   while (args != sc->NIL)
 107     {
 108       FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
 109       acc ^= v;
 110     }
 111   FFI_RETURN_INT (sc, acc);
 112 }
 113
 114 static pointer
 115 do_lognot (scheme *sc, pointer args)
 116 {
 117   FFI_PROLOG ();
 118   unsigned int v;
 119   FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
 120   FFI_ARGS_DONE_OR_RETURN (sc, args);
 121   FFI_RETURN_INT (sc, ~v);
 122 }
 123 \f
 124 /* User interface.  */
 125
 126 static pointer
 127 do_flush_stdio (scheme *sc, pointer args)
 128 {
 129   FFI_PROLOG ();
 130   FFI_ARGS_DONE_OR_RETURN (sc, args);
 131   fflush (stdout);
 132   fflush (stderr);
 133   FFI_RETURN (sc);
 134 }
 135
 136
 137 int use_libreadline;
 138
 139 /* Read a string, and return a pointer to it.  Returns NULL on EOF. */
 140 char *
 141 rl_gets (const char *prompt)
 142 {
 143   static char *line = NULL;
 144   char *p;
 145   xfree (line);
 146
 147 #if HAVE_LIBREADLINE
 148     {
 149       line = readline (prompt);
 150       if (line && *line)
 151         add_history (line);
 152     }
 153 #else
 154     {
 155       size_t max_size = 0xff;
 156       printf ("%s", prompt);
 157       fflush (stdout);
 158       line = xtrymalloc (max_size);
 159       if (line != NULL)
 160         fgets (line, max_size, stdin);
 161     }
 162 #endif
 163
 164   /* Strip trailing whitespace.  */
 165   if (line && strlen (line) > 0)
 166     for (p = &line[strlen (line) - 1]; isspace (*p); p--)
 167       *p = 0;
 168
 169   return line;
 170 }
 171
 172 static pointer
 173 do_prompt (scheme *sc, pointer args)
 174 {
 175   FFI_PROLOG ();
 176   const char *prompt;
 177   const char *line;
 178   FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args);
 179   FFI_ARGS_DONE_OR_RETURN (sc, args);
 180   line = rl_gets (prompt);
 181   if (! line)
 182     FFI_RETURN_POINTER (sc, sc->EOF_OBJ);
 183
 184   FFI_RETURN_STRING (sc, line);
 185 }
 186 \f
 187 static pointer
 188 do_sleep (scheme *sc, pointer args)
 189 {
 190   FFI_PROLOG ();
 191   unsigned int seconds;
 192   FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args);
 193   FFI_ARGS_DONE_OR_RETURN (sc, args);
 194   sleep (seconds);
 195   FFI_RETURN (sc);
 196 }
 197
 198 static pointer
 199 do_usleep (scheme *sc, pointer args)
 200 {
 201   FFI_PROLOG ();
 202   useconds_t microseconds;
 203   FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args);
 204   FFI_ARGS_DONE_OR_RETURN (sc, args);
 205   usleep (microseconds);
 206   FFI_RETURN (sc);
 207 }
 208
 209 static pointer
 210 do_chdir (scheme *sc, pointer args)
 211 {
 212   FFI_PROLOG ();
 213   char *name;
 214   FFI_ARG_OR_RETURN (sc, char *, name, path, args);
 215   FFI_ARGS_DONE_OR_RETURN (sc, args);
 216   if (chdir (name))
 217     FFI_RETURN_ERR (sc, errno);
 218   FFI_RETURN (sc);
 219 }
 220
 221 static pointer
 222 do_strerror (scheme *sc, pointer args)
 223 {
 224   FFI_PROLOG ();
 225   int error;
 226   FFI_ARG_OR_RETURN (sc, int, error, number, args);
 227   FFI_ARGS_DONE_OR_RETURN (sc, args);
 228   FFI_RETURN_STRING (sc, gpg_strerror (error));
 229 }
 230
 231 static pointer
 232 do_getenv (scheme *sc, pointer args)
 233 {
 234   FFI_PROLOG ();
 235   char *name;
 236   char *value;
 237   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
 238   FFI_ARGS_DONE_OR_RETURN (sc, args);
 239   value = getenv (name);
 240   FFI_RETURN_STRING (sc, value ? value : "");
 241 }
 242
 243 static pointer
 244 do_setenv (scheme *sc, pointer args)
 245 {
 246   FFI_PROLOG ();
 247   char *name;
 248   char *value;
 249   int overwrite;
 250   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
 251   FFI_ARG_OR_RETURN (sc, char *, value, string, args);
 252   FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args);
 253   FFI_ARGS_DONE_OR_RETURN (sc, args);
 254   if (gnupg_setenv (name, value, overwrite))
 255     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 256   FFI_RETURN (sc);
 257 }
 258
 259 static pointer
 260 do_exit (scheme *sc, pointer args)
 261 {
 262   FFI_PROLOG ();
 263   int retcode;
 264   FFI_ARG_OR_RETURN (sc, int, retcode, number, args);
 265   FFI_ARGS_DONE_OR_RETURN (sc, args);
 266   exit (retcode);
 267 }
 268
 269 /* XXX: use gnupgs variant b/c mode as string */
 270 static pointer
 271 do_open (scheme *sc, pointer args)
 272 {
 273   FFI_PROLOG ();
 274   int fd;
 275   char *pathname;
 276   int flags;
 277   mode_t mode = 0;
 278   FFI_ARG_OR_RETURN (sc, char *, pathname, path, args);
 279   FFI_ARG_OR_RETURN (sc, int, flags, number, args);
 280   if (args != sc->NIL)
 281     FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args);
 282   FFI_ARGS_DONE_OR_RETURN (sc, args);
 283
 284   fd = open (pathname, flags, mode);
 285   if (fd == -1)
 286     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 287   FFI_RETURN_INT (sc, fd);
 288 }
 289
 290 static pointer
 291 do_fdopen (scheme *sc, pointer args)
 292 {
 293   FFI_PROLOG ();
 294   FILE *stream;
 295   int fd;
 296   char *mode;
 297   int kind;
 298   FFI_ARG_OR_RETURN (sc, int, fd, number, args);
 299   FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
 300   FFI_ARGS_DONE_OR_RETURN (sc, args);
 301
 302   stream = fdopen (fd, mode);
 303   if (stream == NULL)
 304     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 305
 306   if (setvbuf (stream, NULL, _IONBF, 0) != 0)
 307     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 308
 309   kind = 0;
 310   if (strchr (mode, 'r'))
 311     kind |= port_input;
 312   if (strchr (mode, 'w'))
 313     kind |= port_output;
 314
 315   FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind));
 316 }
 317
 318 static pointer
 319 do_close (scheme *sc, pointer args)
 320 {
 321   FFI_PROLOG ();
 322   int fd;
 323   FFI_ARG_OR_RETURN (sc, int, fd, number, args);
 324   FFI_ARGS_DONE_OR_RETURN (sc, args);
 325   FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ());
 326 }
 327
 328 static pointer
 329 do_seek (scheme *sc, pointer args)
 330 {
 331   FFI_PROLOG ();
 332   int fd;
 333   off_t offset;
 334   int whence;
 335   FFI_ARG_OR_RETURN (sc, int, fd, number, args);
 336   FFI_ARG_OR_RETURN (sc, off_t, offset, number, args);
 337   FFI_ARG_OR_RETURN (sc, int, whence, number, args);
 338   FFI_ARGS_DONE_OR_RETURN (sc, args);
 339   FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1
 340                   ? gpg_error_from_syserror () : 0);
 341 }
 342
 343 static pointer
 344 do_mkdtemp (scheme *sc, pointer args)
 345 {
 346   FFI_PROLOG ();
 347   char *template;
 348   char buffer[128];
 349   char *name;
 350   FFI_ARG_OR_RETURN (sc, char *, template, string, args);
 351   FFI_ARGS_DONE_OR_RETURN (sc, args);
 352
 353   if (strlen (template) > sizeof buffer - 1)
 354     FFI_RETURN_ERR (sc, EINVAL);
 355   strncpy (buffer, template, sizeof buffer);
 356
 357   name = gnupg_mkdtemp (buffer);
 358   if (name == NULL)
 359     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 360   FFI_RETURN_STRING (sc, name);
 361 }
 362
 363 static pointer
 364 do_unlink (scheme *sc, pointer args)
 365 {
 366   FFI_PROLOG ();
 367   char *name;
 368   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
 369   FFI_ARGS_DONE_OR_RETURN (sc, args);
 370   if (unlink (name) == -1)
 371     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 372   FFI_RETURN (sc);
 373 }
 374
 375 static gpg_error_t
 376 unlink_recursively (const char *name)
 377 {
 378   gpg_error_t err = 0;
 379   struct stat st;
 380
 381   if (stat (name, &st) == -1)
 382     return gpg_error_from_syserror ();
 383
 384   if (S_ISDIR (st.st_mode))
 385     {
 386       DIR *dir;
 387       struct dirent *dent;
 388
 389       dir = opendir (name);
 390       if (dir == NULL)
 391         return gpg_error_from_syserror ();
 392
 393       while ((dent = readdir (dir)))
 394         {
 395           char *child;
 396
 397           if (strcmp (dent->d_name, ".") == 0
 398               || strcmp (dent->d_name, "..") == 0)
 399             continue;
 400
 401           child = xtryasprintf ("%s/%s", name, dent->d_name);
 402           if (child == NULL)
 403             {
 404               err = gpg_error_from_syserror ();
 405               goto leave;
 406             }
 407
 408           err = unlink_recursively (child);
 409           xfree (child);
 410           if (err == gpg_error_from_errno (ENOENT))
 411             err = 0;
 412           if (err)
 413             goto leave;
 414         }
 415
 416     leave:
 417       closedir (dir);
 418       if (! err)
 419         rmdir (name);
 420       return err;
 421     }
 422   else
 423     if (unlink (name) == -1)
 424       return gpg_error_from_syserror ();
 425   return 0;
 426 }
 427
 428 static pointer
 429 do_unlink_recursively (scheme *sc, pointer args)
 430 {
 431   FFI_PROLOG ();
 432   char *name;
 433   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
 434   FFI_ARGS_DONE_OR_RETURN (sc, args);
 435   err = unlink_recursively (name);
 436   FFI_RETURN (sc);
 437 }
 438
 439 static pointer
 440 do_rename (scheme *sc, pointer args)
 441 {
 442   FFI_PROLOG ();
 443   char *old;
 444   char *new;
 445   FFI_ARG_OR_RETURN (sc, char *, old, string, args);
 446   FFI_ARG_OR_RETURN (sc, char *, new, string, args);
 447   FFI_ARGS_DONE_OR_RETURN (sc, args);
 448   if (rename (old, new) == -1)
 449     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 450   FFI_RETURN (sc);
 451 }
 452
 453 static pointer
 454 do_getcwd (scheme *sc, pointer args)
 455 {
 456   FFI_PROLOG ();
 457   pointer result;
 458   char *cwd;
 459   FFI_ARGS_DONE_OR_RETURN (sc, args);
 460   cwd = gnupg_getcwd ();
 461   if (cwd == NULL)
 462     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 463   result = sc->vptr->mk_string (sc, cwd);
 464   xfree (cwd);
 465   FFI_RETURN_POINTER (sc, result);
 466 }
 467
 468 static pointer
 469 do_mkdir (scheme *sc, pointer args)
 470 {
 471   FFI_PROLOG ();
 472   char *name;
 473   char *mode;
 474   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
 475   FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
 476   FFI_ARGS_DONE_OR_RETURN (sc, args);
 477   if (gnupg_mkdir (name, mode) == -1)
 478     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 479   FFI_RETURN (sc);
 480 }
 481
 482 static pointer
 483 do_rmdir (scheme *sc, pointer args)
 484 {
 485   FFI_PROLOG ();
 486   char *name;
 487   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
 488   FFI_ARGS_DONE_OR_RETURN (sc, args);
 489   if (rmdir (name) == -1)
 490     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 491   FFI_RETURN (sc);
 492 }
 493
 494 static pointer
 495 do_get_isotime (scheme *sc, pointer args)
 496 {
 497   FFI_PROLOG ();
 498   gnupg_isotime_t timebuf;
 499   FFI_ARGS_DONE_OR_RETURN (sc, args);
 500   gnupg_get_isotime (timebuf);
 501   FFI_RETURN_STRING (sc, timebuf);
 502 }
 503
 504 static pointer
 505 do_getpid (scheme *sc, pointer args)
 506 {
 507   FFI_PROLOG ();
 508   FFI_ARGS_DONE_OR_RETURN (sc, args);
 509   FFI_RETURN_INT (sc, getpid ());
 510 }
 511
 512 static pointer
 513 do_srandom (scheme *sc, pointer args)
 514 {
 515   FFI_PROLOG ();
 516   int seed;
 517   FFI_ARG_OR_RETURN (sc, int, seed, number, args);
 518   FFI_ARGS_DONE_OR_RETURN (sc, args);
 519   srand (seed);
 520   FFI_RETURN (sc);
 521 }
 522
 523 static int
 524 random_scaled (int scale)
 525 {
 526   int v;
 527 #ifdef HAVE_RAND
 528   v = rand ();
 529 #else
 530   v = random ();
 531 #endif
 532
 533 #ifndef RAND_MAX   /* for SunOS */
 534 #define RAND_MAX 32767
 535 #endif
 536
 537   return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1);
 538 }
 539
 540 static pointer
 541 do_random (scheme *sc, pointer args)
 542 {
 543   FFI_PROLOG ();
 544   int scale;
 545   FFI_ARG_OR_RETURN (sc, int, scale, number, args);
 546   FFI_ARGS_DONE_OR_RETURN (sc, args);
 547   FFI_RETURN_INT (sc, random_scaled (scale));
 548 }
 549
 550 static pointer
 551 do_make_random_string (scheme *sc, pointer args)
 552 {
 553   FFI_PROLOG ();
 554   int size;
 555   pointer chunk;
 556   char *p;
 557   FFI_ARG_OR_RETURN (sc, int, size, number, args);
 558   FFI_ARGS_DONE_OR_RETURN (sc, args);
 559   if (size < 0)
 560     return ffi_sprintf (sc, "size must be positive");
 561
 562   chunk = sc->vptr->mk_counted_string (sc, NULL, size);
 563   if (sc->no_memory)
 564     FFI_RETURN_ERR (sc, ENOMEM);
 565
 566   for (p = sc->vptr->string_value (chunk); size; p++, size--)
 567     *p = (char) random_scaled (256);
 568   FFI_RETURN_POINTER (sc, chunk);
 569 }
 570
 571 \f
 572
 573 /* estream functions.  */
 574
 575 struct es_object_box
 576 {
 577   estream_t stream;
 578   int closed;
 579 };
 580
 581 static void
 582 es_object_finalize (scheme *sc, void *data)
 583 {
 584   struct es_object_box *box = data;
 585   (void) sc;
 586
 587   if (! box->closed)
 588     es_fclose (box->stream);
 589   xfree (box);
 590 }
 591
 592 static void
 593 es_object_to_string (scheme *sc, char *out, size_t size, void *data)
 594 {
 595   struct es_object_box *box = data;
 596   (void) sc;
 597
 598   snprintf (out, size, "#estream %p", box->stream);
 599 }
 600
 601 static struct foreign_object_vtable es_object_vtable =
 602   {
 603     es_object_finalize,
 604     es_object_to_string,
 605   };
 606
 607 static pointer
 608 es_wrap (scheme *sc, estream_t stream)
 609 {
 610   struct es_object_box *box = xmalloc (sizeof *box);
 611   if (box == NULL)
 612     return sc->NIL;
 613
 614   box->stream = stream;
 615   box->closed = 0;
 616   return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
 617 }
 618
 619 static struct es_object_box *
 620 es_unwrap (scheme *sc, pointer object)
 621 {
 622   (void) sc;
 623
 624   if (! is_foreign_object (object))
 625     return NULL;
 626
 627   if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable)
 628     return NULL;
 629
 630   return sc->vptr->get_foreign_object_data (object);
 631 }
 632
 633 #define CONVERSION_estream(SC, X)       es_unwrap (SC, X)
 634 #define IS_A_estream(SC, X)             es_unwrap (SC, X)
 635
 636 static pointer
 637 do_es_fclose (scheme *sc, pointer args)
 638 {
 639   FFI_PROLOG ();
 640   struct es_object_box *box;
 641   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
 642   FFI_ARGS_DONE_OR_RETURN (sc, args);
 643   err = es_fclose (box->stream);
 644   if (! err)
 645     box->closed = 1;
 646   FFI_RETURN (sc);
 647 }
 648
 649 static pointer
 650 do_es_read (scheme *sc, pointer args)
 651 {
 652   FFI_PROLOG ();
 653   struct es_object_box *box;
 654   size_t bytes_to_read;
 655
 656   pointer result;
 657   void *buffer;
 658   size_t bytes_read;
 659
 660   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
 661   FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args);
 662   FFI_ARGS_DONE_OR_RETURN (sc, args);
 663
 664   buffer = xtrymalloc (bytes_to_read);
 665   if (buffer == NULL)
 666     FFI_RETURN_ERR (sc, ENOMEM);
 667
 668   err = es_read (box->stream, buffer, bytes_to_read, &bytes_read);
 669   if (err)
 670     FFI_RETURN_ERR (sc, err);
 671
 672   result = sc->vptr->mk_counted_string (sc, buffer, bytes_read);
 673   xfree (buffer);
 674   FFI_RETURN_POINTER (sc, result);
 675 }
 676
 677 static pointer
 678 do_es_feof (scheme *sc, pointer args)
 679 {
 680   FFI_PROLOG ();
 681   struct es_object_box *box;
 682   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
 683   FFI_ARGS_DONE_OR_RETURN (sc, args);
 684
 685   FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F);
 686 }
 687
 688 static pointer
 689 do_es_write (scheme *sc, pointer args)
 690 {
 691   FFI_PROLOG ();
 692   struct es_object_box *box;
 693   const char *buffer;
 694   size_t bytes_to_write, bytes_written;
 695
 696   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
 697   /* XXX how to get the length of the string buffer?  scheme strings
 698      may contain \0.  */
 699   FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args);
 700   FFI_ARGS_DONE_OR_RETURN (sc, args);
 701
 702   bytes_to_write = strlen (buffer);
 703   while (bytes_to_write > 0)
 704     {
 705       err = es_write (box->stream, buffer, bytes_to_write, &bytes_written);
 706       if (err)
 707         break;
 708       bytes_to_write -= bytes_written;
 709       buffer += bytes_written;
 710     }
 711
 712   FFI_RETURN (sc);
 713 }
 714
 715 \f
 716
 717 /* Process handling.  */
 718
 719 static pointer
 720 do_spawn_process (scheme *sc, pointer args)
 721 {
 722   FFI_PROLOG ();
 723   pointer arguments;
 724   char **argv;
 725   size_t len;
 726   unsigned int flags;
 727
 728   estream_t infp;
 729   estream_t outfp;
 730   estream_t errfp;
 731   pid_t pid;
 732
 733   FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
 734   FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
 735   FFI_ARGS_DONE_OR_RETURN (sc, args);
 736
 737   err = ffi_list2argv (sc, arguments, &argv, &len);
 738   if (err == gpg_error (GPG_ERR_INV_VALUE))
 739     return ffi_sprintf (sc, "%luth element of first argument is "
 740                         "neither string nor symbol",
 741                         (unsigned long) len);
 742   if (err)
 743     FFI_RETURN_ERR (sc, err);
 744
 745   if (verbose > 1)
 746     {
 747       char **p;
 748       fprintf (stderr, "Executing:");
 749       for (p = argv; *p; p++)
 750         fprintf (stderr, " '%s'", *p);
 751       fprintf (stderr, "\n");
 752     }
 753
 754   err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
 755                              NULL,
 756                              NULL,
 757                              flags,
 758                              &infp, &outfp, &errfp, &pid);
 759   xfree (argv);
 760 #define IMC(A, B)                                                       \
 761   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
 762 #define IMS(A, B)                                                       \
 763   _cons (sc, es_wrap (sc, (A)), (B), 1)
 764   FFI_RETURN_POINTER (sc, IMS (infp,
 765                               IMS (outfp,
 766                                    IMS (errfp,
 767                                         IMC (pid, sc->NIL)))));
 768 #undef IMS
 769 #undef IMC
 770 }
 771
 772 static pointer
 773 do_spawn_process_fd (scheme *sc, pointer args)
 774 {
 775   FFI_PROLOG ();
 776   pointer arguments;
 777   char **argv;
 778   size_t len;
 779   int infd, outfd, errfd;
 780
 781   pid_t pid;
 782
 783   FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
 784   FFI_ARG_OR_RETURN (sc, int, infd, number, args);
 785   FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
 786   FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
 787   FFI_ARGS_DONE_OR_RETURN (sc, args);
 788
 789   err = ffi_list2argv (sc, arguments, &argv, &len);
 790   if (err == gpg_error (GPG_ERR_INV_VALUE))
 791     return ffi_sprintf (sc, "%luth element of first argument is "
 792                         "neither string nor symbol",
 793                         (unsigned long) len);
 794   if (err)
 795     FFI_RETURN_ERR (sc, err);
 796
 797   if (verbose > 1)
 798     {
 799       char **p;
 800       fprintf (stderr, "Executing:");
 801       for (p = argv; *p; p++)
 802         fprintf (stderr, " '%s'", *p);
 803       fprintf (stderr, "\n");
 804     }
 805
 806   err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
 807                                 infd, outfd, errfd, &pid);
 808   xfree (argv);
 809   FFI_RETURN_INT (sc, pid);
 810 }
 811
 812 static pointer
 813 do_wait_process (scheme *sc, pointer args)
 814 {
 815   FFI_PROLOG ();
 816   const char *name;
 817   pid_t pid;
 818   int hang;
 819
 820   int retcode;
 821
 822   FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
 823   FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
 824   FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
 825   FFI_ARGS_DONE_OR_RETURN (sc, args);
 826   err = gnupg_wait_process (name, pid, hang, &retcode);
 827   if (err == GPG_ERR_GENERAL)
 828     err = 0;    /* Let the return code speak for itself.  */
 829
 830   FFI_RETURN_INT (sc, retcode);
 831 }
 832
 833
 834 static pointer
 835 do_wait_processes (scheme *sc, pointer args)
 836 {
 837   FFI_PROLOG ();
 838   pointer list_names;
 839   char **names;
 840   pointer list_pids;
 841   size_t i, count;
 842   pid_t *pids;
 843   int hang;
 844   int *retcodes;
 845   pointer retcodes_list = sc->NIL;
 846
 847   FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
 848   FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
 849   FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
 850   FFI_ARGS_DONE_OR_RETURN (sc, args);
 851
 852   if (sc->vptr->list_length (sc, list_names)
 853       != sc->vptr->list_length (sc, list_pids))
 854     return
 855       sc->vptr->mk_string (sc, "length of first two arguments must match");
 856
 857   err = ffi_list2argv (sc, list_names, &names, &count);
 858   if (err == gpg_error (GPG_ERR_INV_VALUE))
 859     return ffi_sprintf (sc, "%lu%s element of first argument is "
 860                         "neither string nor symbol",
 861                         (unsigned long) count,
 862                         ordinal_suffix ((int) count));
 863   if (err)
 864     FFI_RETURN_ERR (sc, err);
 865
 866   err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
 867   if (err == gpg_error (GPG_ERR_INV_VALUE))
 868     return ffi_sprintf (sc, "%lu%s element of second argument is "
 869                         "not a number",
 870                         (unsigned long) count,
 871                         ordinal_suffix ((int) count));
 872   if (err)
 873     FFI_RETURN_ERR (sc, err);
 874
 875   retcodes = xtrycalloc (sizeof *retcodes, count);
 876   if (retcodes == NULL)
 877     {
 878       xfree (names);
 879       xfree (pids);
 880       FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
 881     }
 882
 883   err = gnupg_wait_processes ((const char **) names, pids, count, hang,
 884                               retcodes);
 885   if (err == GPG_ERR_GENERAL)
 886     err = 0;    /* Let the return codes speak.  */
 887
 888   for (i = 0; i < count; i++)
 889     retcodes_list =
 890       (sc->vptr->cons) (sc,
 891                         sc->vptr->mk_integer (sc,
 892                                               (long) retcodes[count-1-i]),
 893                         retcodes_list);
 894
 895   xfree (names);
 896   xfree (pids);
 897   xfree (retcodes);
 898   FFI_RETURN_POINTER (sc, retcodes_list);
 899 }
 900
 901
 902 static pointer
 903 do_pipe (scheme *sc, pointer args)
 904 {
 905   FFI_PROLOG ();
 906   int filedes[2];
 907   FFI_ARGS_DONE_OR_RETURN (sc, args);
 908   err = gnupg_create_pipe (filedes);
 909 #define IMC(A, B)                                                       \
 910   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
 911   FFI_RETURN_POINTER (sc, IMC (filedes[0],
 912                               IMC (filedes[1], sc->NIL)));
 913 #undef IMC
 914 }
 915
 916 static pointer
 917 do_inbound_pipe (scheme *sc, pointer args)
 918 {
 919   FFI_PROLOG ();
 920   int filedes[2];
 921   FFI_ARGS_DONE_OR_RETURN (sc, args);
 922   err = gnupg_create_inbound_pipe (filedes, NULL, 0);
 923 #define IMC(A, B)                                                       \
 924   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
 925   FFI_RETURN_POINTER (sc, IMC (filedes[0],
 926                               IMC (filedes[1], sc->NIL)));
 927 #undef IMC
 928 }
 929
 930 static pointer
 931 do_outbound_pipe (scheme *sc, pointer args)
 932 {
 933   FFI_PROLOG ();
 934   int filedes[2];
 935   FFI_ARGS_DONE_OR_RETURN (sc, args);
 936   err = gnupg_create_outbound_pipe (filedes, NULL, 0);
 937 #define IMC(A, B)                                                       \
 938   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
 939   FFI_RETURN_POINTER (sc, IMC (filedes[0],
 940                               IMC (filedes[1], sc->NIL)));
 941 #undef IMC
 942 }
 943
 944 \f
 945
 946 /* Test helper functions.  */
 947 static pointer
 948 do_file_equal (scheme *sc, pointer args)
 949 {
 950   FFI_PROLOG ();
 951   pointer result = sc->F;
 952   char *a_name, *b_name;
 953   int binary;
 954   const char *mode;
 955   FILE *a_stream = NULL, *b_stream = NULL;
 956   struct stat a_stat, b_stat;
 957 #define BUFFER_SIZE     1024
 958   char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE];
 959 #undef BUFFER_SIZE
 960   size_t chunk;
 961
 962   FFI_ARG_OR_RETURN (sc, char *, a_name, string, args);
 963   FFI_ARG_OR_RETURN (sc, char *, b_name, string, args);
 964   FFI_ARG_OR_RETURN (sc, int, binary, bool, args);
 965   FFI_ARGS_DONE_OR_RETURN (sc, args);
 966
 967   mode = binary ? "rb" : "r";
 968   a_stream = fopen (a_name, mode);
 969   if (a_stream == NULL)
 970     goto errout;
 971
 972   b_stream = fopen (b_name, mode);
 973   if (b_stream == NULL)
 974     goto errout;
 975
 976   if (fstat (fileno (a_stream), &a_stat) < 0)
 977     goto errout;
 978
 979   if (fstat (fileno (b_stream), &b_stat) < 0)
 980     goto errout;
 981
 982   if (binary && a_stat.st_size != b_stat.st_size)
 983     {
 984       if (verbose)
 985         fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n",
 986                  a_name, b_name, (unsigned long) a_stat.st_size,
 987                  (unsigned long) b_stat.st_size);
 988
 989       goto out;
 990     }
 991
 992   while (! feof (a_stream))
 993     {
 994       chunk = sizeof a_buf;
 995
 996       chunk = fread (a_buf, 1, chunk, a_stream);
 997       if (chunk == 0 && ferror (a_stream))
 998         goto errout;    /* some error */
 999
1000       if (fread (b_buf, 1, chunk, b_stream) < chunk)
1001         {
1002           if (feof (b_stream))
1003             goto out;   /* short read */
1004           goto errout;  /* some error */
1005         }
1006
1007       if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0)
1008         goto out;
1009     }
1010
1011   fread (b_buf, 1, 1, b_stream);
1012   if (! feof (b_stream))
1013     goto out;   /* b is longer */
1014
1015   /* They match.  */
1016   result = sc->T;
1017
1018  out:
1019   if (a_stream)
1020     fclose (a_stream);
1021   if (b_stream)
1022     fclose (b_stream);
1023   FFI_RETURN_POINTER (sc, result);
1024  errout:
1025   err = gpg_error_from_syserror ();
1026   goto out;
1027 }
1028
1029 static pointer
1030 do_splice (scheme *sc, pointer args)
1031 {
1032   FFI_PROLOG ();
1033   int source;
1034   char buffer[1024];
1035   ssize_t bytes_read;
1036   pointer sinks, sink;
1037   FFI_ARG_OR_RETURN (sc, int, source, number, args);
1038   sinks = args;
1039   if (sinks == sc->NIL)
1040     return ffi_sprintf (sc, "need at least one sink");
1041   for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++)
1042     if (! sc->vptr->is_number (pair_car (sink)))
1043       return ffi_sprintf (sc, "%d%s argument is not a number",
1044                           ffi_arg_index, ordinal_suffix (ffi_arg_index));
1045
1046   while (1)
1047     {
1048       bytes_read = read (source, buffer, sizeof buffer);
1049       if (bytes_read == 0)
1050         break;
1051       if (bytes_read < 0)
1052         FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
1053
1054       for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink))
1055         {
1056           int fd = sc->vptr->ivalue (pair_car (sink));
1057           char *p = buffer;
1058           ssize_t left = bytes_read;
1059
1060           while (left)
1061             {
1062               ssize_t written = write (fd, p, left);
1063               if (written < 0)
1064                 FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
1065               assert (written <= left);
1066               left -= written;
1067               p += written;
1068             }
1069         }
1070     }
1071   FFI_RETURN (sc);
1072 }
1073
1074 static pointer
1075 do_string_index (scheme *sc, pointer args)
1076 {
1077   FFI_PROLOG ();
1078   char *haystack;
1079   char needle;
1080   ssize_t offset = 0;
1081   char *position;
1082   FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
1083   FFI_ARG_OR_RETURN (sc, char, needle, character, args);
1084   if (args != sc->NIL)
1085     {
1086       FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
1087       if (offset < 0)
1088         return ffi_sprintf (sc, "offset must be positive");
1089       if (offset > strlen (haystack))
1090         return ffi_sprintf (sc, "offset exceeds haystack");
1091     }
1092   FFI_ARGS_DONE_OR_RETURN (sc, args);
1093
1094   position = strchr (haystack+offset, needle);
1095   if (position)
1096     FFI_RETURN_INT (sc, position - haystack);
1097   else
1098     FFI_RETURN_POINTER (sc, sc->F);
1099 }
1100
1101 static pointer
1102 do_string_rindex (scheme *sc, pointer args)
1103 {
1104   FFI_PROLOG ();
1105   char *haystack;
1106   char needle;
1107   ssize_t offset = 0;
1108   char *position;
1109   FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
1110   FFI_ARG_OR_RETURN (sc, char, needle, character, args);
1111   if (args != sc->NIL)
1112     {
1113       FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
1114       if (offset < 0)
1115         return ffi_sprintf (sc, "offset must be positive");
1116       if (offset > strlen (haystack))
1117         return ffi_sprintf (sc, "offset exceeds haystack");
1118     }
1119   FFI_ARGS_DONE_OR_RETURN (sc, args);
1120
1121   position = strrchr (haystack+offset, needle);
1122   if (position)
1123     FFI_RETURN_INT (sc, position - haystack);
1124   else
1125     FFI_RETURN_POINTER (sc, sc->F);
1126 }
1127
1128 static pointer
1129 do_string_contains (scheme *sc, pointer args)
1130 {
1131   FFI_PROLOG ();
1132   char *haystack;
1133   char *needle;
1134   FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
1135   FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
1136   FFI_ARGS_DONE_OR_RETURN (sc, args);
1137   FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
1138 }
1139
1140 \f
1141
1142 static pointer
1143 do_get_verbose (scheme *sc, pointer args)
1144 {
1145   FFI_PROLOG ();
1146   FFI_ARGS_DONE_OR_RETURN (sc, args);
1147   FFI_RETURN_INT (sc, verbose);
1148 }
1149
1150 static pointer
1151 do_set_verbose (scheme *sc, pointer args)
1152 {
1153   FFI_PROLOG ();
1154   int new_verbosity, old;
1155   FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args);
1156   FFI_ARGS_DONE_OR_RETURN (sc, args);
1157
1158   old = verbose;
1159   verbose = new_verbosity;
1160
1161   FFI_RETURN_INT (sc, old);
1162 }
1163
1164 \f
1165 gpg_error_t
1166 ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
1167 {
1168   int i;
1169
1170   *len = sc->vptr->list_length (sc, list);
1171   *argv = xtrycalloc (*len + 1, sizeof **argv);
1172   if (*argv == NULL)
1173     return gpg_error_from_syserror ();
1174
1175   for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
1176     {
1177       if (sc->vptr->is_string (sc->vptr->pair_car (list)))
1178         (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list));
1179       else if (sc->vptr->is_symbol (sc->vptr->pair_car (list)))
1180         (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list));
1181       else
1182         {
1183           xfree (*argv);
1184           *argv = NULL;
1185           *len = i;
1186           return gpg_error (GPG_ERR_INV_VALUE);
1187         }
1188     }
1189   (*argv)[i] = NULL;
1190   return 0;
1191 }
1192
1193 gpg_error_t
1194 ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len)
1195 {
1196   int i;
1197
1198   *len = sc->vptr->list_length (sc, list);
1199   *intv = xtrycalloc (*len, sizeof **intv);
1200   if (*intv == NULL)
1201     return gpg_error_from_syserror ();
1202
1203   for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
1204     {
1205       if (sc->vptr->is_number (sc->vptr->pair_car (list)))
1206         (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list));
1207       else
1208         {
1209           xfree (*intv);
1210           *intv = NULL;
1211           *len = i;
1212           return gpg_error (GPG_ERR_INV_VALUE);
1213         }
1214     }
1215
1216   return 0;
1217 }
1218
1219 \f
1220 char *
1221 ffi_schemify_name (const char *s, int macro)
1222 {
1223   /* Fixme: We should use xtrystrdup and return NULL.  However, this
1224    * requires a lot more changes.  Simply returning S as done
1225    * originally is not an option.  */
1226   char *n = xstrdup (s), *p;
1227   /* if (n == NULL) */
1228   /*   return s; */
1229
1230   for (p = n; *p; p++)
1231     {
1232       *p = (char) tolower (*p);
1233        /* We convert _ to - in identifiers.  We allow, however, for
1234           function names to start with a leading _.  The functions in
1235           this namespace are not yet finalized and might change or
1236           vanish without warning.  Use them with care.  */
1237       if (! macro
1238           && p != n
1239           && *p == '_')
1240         *p = '-';
1241     }
1242   return n;
1243 }
1244
1245 pointer
1246 ffi_sprintf (scheme *sc, const char *format, ...)
1247 {
1248   pointer result;
1249   va_list listp;
1250   char *expression;
1251   int size, written;
1252
1253   va_start (listp, format);
1254   size = vsnprintf (NULL, 0, format, listp);
1255   va_end (listp);
1256
1257   expression = xtrymalloc (size + 1);
1258   if (expression == NULL)
1259     return NULL;
1260
1261   va_start (listp, format);
1262   written = vsnprintf (expression, size + 1, format, listp);
1263   va_end (listp);
1264
1265   assert (size == written);
1266
1267   result = sc->vptr->mk_string (sc, expression);
1268   xfree (expression);
1269   return result;
1270 }
1271
1272 void
1273 ffi_scheme_eval (scheme *sc, const char *format, ...)
1274 {
1275   va_list listp;
1276   char *expression;
1277   int size, written;
1278
1279   va_start (listp, format);
1280   size = vsnprintf (NULL, 0, format, listp);
1281   va_end (listp);
1282
1283   expression = xtrymalloc (size + 1);
1284   if (expression == NULL)
1285     return;
1286
1287   va_start (listp, format);
1288   written = vsnprintf (expression, size + 1, format, listp);
1289   va_end (listp);
1290
1291   assert (size == written);
1292
1293   sc->vptr->load_string (sc, expression);
1294   xfree (expression);
1295 }
1296
1297 gpg_error_t
1298 ffi_init (scheme *sc, const char *argv0, const char *scriptname,
1299           int argc, const char **argv)
1300 {
1301   int i;
1302   pointer args = sc->NIL;
1303
1304   /* bitwise arithmetic */
1305   ffi_define_function (sc, logand);
1306   ffi_define_function (sc, logior);
1307   ffi_define_function (sc, logxor);
1308   ffi_define_function (sc, lognot);
1309
1310   /* libc.  */
1311   ffi_define_constant (sc, O_RDONLY);
1312   ffi_define_constant (sc, O_WRONLY);
1313   ffi_define_constant (sc, O_RDWR);
1314   ffi_define_constant (sc, O_CREAT);
1315   ffi_define_constant (sc, O_APPEND);
1316 #ifndef O_BINARY
1317 # define O_BINARY       0
1318 #endif
1319 #ifndef O_TEXT
1320 # define O_TEXT         0
1321 #endif
1322   ffi_define_constant (sc, O_BINARY);
1323   ffi_define_constant (sc, O_TEXT);
1324   ffi_define_constant (sc, STDIN_FILENO);
1325   ffi_define_constant (sc, STDOUT_FILENO);
1326   ffi_define_constant (sc, STDERR_FILENO);
1327   ffi_define_constant (sc, SEEK_SET);
1328   ffi_define_constant (sc, SEEK_CUR);
1329   ffi_define_constant (sc, SEEK_END);
1330
1331   ffi_define_function (sc, sleep);
1332   ffi_define_function (sc, usleep);
1333   ffi_define_function (sc, chdir);
1334   ffi_define_function (sc, strerror);
1335   ffi_define_function (sc, getenv);
1336   ffi_define_function (sc, setenv);
1337   ffi_define_function_name (sc, "_exit", exit);
1338   ffi_define_function (sc, open);
1339   ffi_define_function (sc, fdopen);
1340   ffi_define_function (sc, close);
1341   ffi_define_function (sc, seek);
1342   ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
1343   ffi_define_function (sc, unlink);
1344   ffi_define_function (sc, unlink_recursively);
1345   ffi_define_function (sc, rename);
1346   ffi_define_function (sc, getcwd);
1347   ffi_define_function (sc, mkdir);
1348   ffi_define_function (sc, rmdir);
1349   ffi_define_function (sc, get_isotime);
1350   ffi_define_function (sc, getpid);
1351
1352   /* Random numbers.  */
1353   ffi_define_function (sc, srandom);
1354   ffi_define_function (sc, random);
1355   ffi_define_function (sc, make_random_string);
1356
1357   /* Process management.  */
1358   ffi_define_function (sc, spawn_process);
1359   ffi_define_function (sc, spawn_process_fd);
1360   ffi_define_function (sc, wait_process);
1361   ffi_define_function (sc, wait_processes);
1362   ffi_define_function (sc, pipe);
1363   ffi_define_function (sc, inbound_pipe);
1364   ffi_define_function (sc, outbound_pipe);
1365
1366   /* estream functions.  */
1367   ffi_define_function_name (sc, "es-fclose", es_fclose);
1368   ffi_define_function_name (sc, "es-read", es_read);
1369   ffi_define_function_name (sc, "es-feof", es_feof);
1370   ffi_define_function_name (sc, "es-write", es_write);
1371
1372   /* Test helper functions.  */
1373   ffi_define_function (sc, file_equal);
1374   ffi_define_function (sc, splice);
1375   ffi_define_function (sc, string_index);
1376   ffi_define_function (sc, string_rindex);
1377   ffi_define_function_name (sc, "string-contains?", string_contains);
1378
1379   /* User interface.  */
1380   ffi_define_function (sc, flush_stdio);
1381   ffi_define_function (sc, prompt);
1382
1383   /* Configuration.  */
1384   ffi_define_function_name (sc, "*verbose*", get_verbose);
1385   ffi_define_function_name (sc, "*set-verbose!*", set_verbose);
1386
1387   ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0));
1388   ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname));
1389   for (i = argc - 1; i >= 0; i--)
1390     {
1391       pointer value = sc->vptr->mk_string (sc, argv[i]);
1392       args = (sc->vptr->cons) (sc, value, args);
1393     }
1394   ffi_define (sc, "*args*", args);
1395
1396 #if _WIN32
1397   ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';'));
1398 #else
1399   ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':'));
1400 #endif
1401
1402   ffi_define (sc, "*win32*",
1403 #if _WIN32
1404               sc->T
1405 #else
1406               sc->F
1407 #endif
1408               );
1409
1410
1411   ffi_define (sc, "*stdin*",
1412               sc->vptr->mk_port_from_file (sc, stdin, port_input));
1413   ffi_define (sc, "*stdout*",
1414               sc->vptr->mk_port_from_file (sc, stdout, port_output));
1415   ffi_define (sc, "*stderr*",
1416               sc->vptr->mk_port_from_file (sc, stderr, port_output));
1417
1418   return 0;
1419 }