libguile/values.c

   1 /* Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 #include "libguile/_scm.h"
  19 #include "libguile/eval.h"
  20 #include "libguile/feature.h"
  21 #include "libguile/gc.h"
  22 #include "libguile/numbers.h"
  23 #include "libguile/ports.h"
  24 #include "libguile/root.h"
  25 #include "libguile/strings.h"
  26 #include "libguile/struct.h"
  27 #include "libguile/validate.h"
  28
  29 #include "libguile/values.h"
  30
  31 SCM scm_values_vtable;
  32
  33 static SCM
  34 print_values (SCM obj, SCM pwps)
  35 {
  36   SCM values = scm_struct_ref (obj, SCM_INUM0);
  37   SCM port = SCM_PORT_WITH_PS_PORT (pwps);
  38   scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
  39
  40   scm_puts ("#<values ", port);
  41   scm_iprin1 (values, port, ps);
  42   scm_puts (">", port);
  43
  44   return SCM_UNSPECIFIED;
  45 }
  46
  47 SCM_DEFINE (scm_values, "values", 0, 0, 1,
  48             (SCM args),
  49             "Delivers all of its arguments to its continuation.  Except for\n"
  50             "continuations created by the @code{call-with-values} procedure,\n"
  51             "all continuations take exactly one value.  The effect of\n"
  52             "passing no value or more than one value to continuations that\n"
  53             "were not created by @code{call-with-values} is unspecified.")
  54 #define FUNC_NAME s_scm_values
  55 {
  56   long n;
  57   SCM result;
  58
  59   SCM_VALIDATE_LIST_COPYLEN (1, args, n);
  60   if (n == 1)
  61     result = SCM_CAR (args);
  62   else
  63     {
  64       result = scm_make_struct (scm_values_vtable, SCM_INUM0,
  65                                 scm_list_1 (args));
  66     }
  67
  68   return result;
  69 }
  70 #undef FUNC_NAME
  71
  72 void
  73 scm_init_values (void)
  74 {
  75   SCM print = scm_c_define_subr ("%print-values", scm_tc7_subr_2,
  76                                  print_values);
  77
  78   scm_values_vtable
  79     = scm_permanent_object (
  80         scm_make_vtable_vtable (scm_from_locale_string ("pr"),
  81                                 SCM_INUM0, SCM_EOL));
  82
  83   SCM_SET_STRUCT_PRINTER (scm_values_vtable, print);
  84
  85   scm_add_feature ("values");
  86
  87 #include "libguile/values.x"
  88 }
  89
  90 /*
  91   Local Variables:
  92   c-file-style: "gnu"
  93   End:
  94 */