libguile/procprop.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012 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 License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * 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
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include "libguile/_scm.h"
  26
  27 #include "libguile/alist.h"
  28 #include "libguile/eval.h"
  29 #include "libguile/procs.h"
  30 #include "libguile/gsubr.h"
  31 #include "libguile/smob.h"
  32 #include "libguile/root.h"
  33 #include "libguile/vectors.h"
  34 #include "libguile/weak-table.h"
  35 #include "libguile/programs.h"
  36
  37 #include "libguile/validate.h"
  38 #include "libguile/procprop.h"
  39 \f
  40
  41 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
  42 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  43
  44 static SCM overrides;
  45
  46 static SCM arity_overrides;
  47
  48 int
  49 scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
  50 {
  51   SCM o;
  52
  53   o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
  54
  55   if (scm_is_true (o))
  56     {
  57       *req = scm_to_int (scm_car (o));
  58       *opt = scm_to_int (scm_cadr (o));
  59       *rest = scm_is_true (scm_caddr (o));
  60       return 1;
  61     }
  62
  63   while (!SCM_PROGRAM_P (proc))
  64     {
  65       if (SCM_STRUCTP (proc))
  66         {
  67           if (!SCM_STRUCT_APPLICABLE_P (proc))
  68             return 0;
  69           proc = SCM_STRUCT_PROCEDURE (proc);
  70         }
  71       else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
  72         {
  73           if (!SCM_SMOB_APPLICABLE_P (proc))
  74             return 0;
  75           if (!scm_i_program_arity (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline,
  76                                     req, opt, rest))
  77             return 0;
  78
  79           /* The trampoline gets the smob too, which users don't
  80              see.  */
  81           *req -= 1;
  82
  83           return 1;
  84         }
  85       else
  86         return 0;
  87     }
  88
  89   return scm_i_program_arity (proc, req, opt, rest);
  90 }
  91
  92 SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
  93             4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
  94             "")
  95 #define FUNC_NAME s_scm_set_procedure_minimum_arity_x
  96 {
  97   int t SCM_UNUSED;
  98
  99   SCM_VALIDATE_PROC (1, proc);
 100   SCM_VALIDATE_INT_COPY (2, req, t);
 101   SCM_VALIDATE_INT_COPY (3, opt, t);
 102   SCM_VALIDATE_BOOL (4, rest);
 103
 104   scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
 105   return SCM_UNDEFINED;
 106 }
 107 #undef FUNC_NAME
 108
 109 SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
 110            (SCM proc),
 111             "Return the \"minimum arity\" of a procedure.\n\n"
 112             "If the procedure has only one arity, that arity is returned\n"
 113             "as a list of three values: the number of required arguments,\n"
 114             "the number of optional arguments, and a boolean indicating\n"
 115             "whether or not the procedure takes rest arguments.\n\n"
 116             "For a case-lambda procedure, the arity returned is the one\n"
 117             "with the lowest minimum number of arguments, and the highest\n"
 118             "maximum number of arguments.\n\n"
 119             "If it was not possible to determine the arity of the procedure,\n"
 120             "@code{#f} is returned.")
 121 #define FUNC_NAME s_scm_procedure_minimum_arity
 122 {
 123   int req, opt, rest;
 124
 125   if (scm_i_procedure_arity (proc, &req, &opt, &rest))
 126     return scm_list_3 (scm_from_int (req),
 127                        scm_from_int (opt),
 128                        scm_from_bool (rest));
 129   else
 130     return SCM_BOOL_F;
 131 }
 132 #undef FUNC_NAME
 133
 134 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 135            (SCM proc),
 136             "Return @var{proc}'s property list.")
 137 #define FUNC_NAME s_scm_procedure_properties
 138 {
 139   SCM ret;
 140
 141   SCM_VALIDATE_PROC (1, proc);
 142
 143   ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 144
 145   if (scm_is_false (ret))
 146     {
 147       if (SCM_PROGRAM_P (proc))
 148         ret = scm_i_program_properties (proc);
 149       else
 150         ret = SCM_EOL;
 151     }
 152
 153   return ret;
 154 }
 155 #undef FUNC_NAME
 156
 157 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 158            (SCM proc, SCM alist),
 159             "Set @var{proc}'s property list to @var{alist}.")
 160 #define FUNC_NAME s_scm_set_procedure_properties_x
 161 {
 162   SCM_VALIDATE_PROC (1, proc);
 163
 164   scm_weak_table_putq_x (overrides, proc, alist);
 165
 166   return SCM_UNSPECIFIED;
 167 }
 168 #undef FUNC_NAME
 169
 170 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 171            (SCM proc, SCM key),
 172             "Return the property of @var{proc} with name @var{key}.")
 173 #define FUNC_NAME s_scm_procedure_property
 174 {
 175   SCM_VALIDATE_PROC (1, proc);
 176
 177   return scm_assq_ref (scm_procedure_properties (proc), key);
 178 }
 179 #undef FUNC_NAME
 180
 181 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 182            (SCM proc, SCM key, SCM val),
 183             "In @var{proc}'s property list, set the property named @var{key} to\n"
 184             "@var{val}.")
 185 #define FUNC_NAME s_scm_set_procedure_property_x
 186 {
 187   SCM props;
 188
 189   SCM_VALIDATE_PROC (1, proc);
 190
 191   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
 192   props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 193   if (scm_is_false (props))
 194     {
 195       if (SCM_PROGRAM_P (proc))
 196         props = scm_i_program_properties (proc);
 197       else
 198         props = SCM_EOL;
 199     }
 200   scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
 201   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 202
 203   return SCM_UNSPECIFIED;
 204 }
 205 #undef FUNC_NAME
 206
 207 \f
 208
 209
 210 void
 211 scm_init_procprop ()
 212 {
 213   overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 214   arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 215 #include "libguile/procprop.x"
 216 }
 217
 218
 219 /*
 220   Local Variables:
 221   c-file-style: "gnu"
 222   End:
 223 */