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