libguile/procprop.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011 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           proc = scm_i_smob_apply_trampoline (proc);
  76         }
  77       else
  78         return 0;
  79     }
  80
  81   return scm_i_program_arity (proc, req, opt, rest);
  82 }
  83
  84 SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
  85             4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
  86             "")
  87 #define FUNC_NAME s_scm_set_procedure_minimum_arity_x
  88 {
  89   int t SCM_UNUSED;
  90
  91   SCM_VALIDATE_PROC (1, proc);
  92   SCM_VALIDATE_INT_COPY (2, req, t);
  93   SCM_VALIDATE_INT_COPY (3, opt, t);
  94   SCM_VALIDATE_BOOL (4, rest);
  95
  96   scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
  97   return SCM_UNDEFINED;
  98 }
  99 #undef FUNC_NAME
 100
 101 SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
 102            (SCM proc),
 103             "Return the \"minimum arity\" of a procedure.\n\n"
 104             "If the procedure has only one arity, that arity is returned\n"
 105             "as a list of three values: the number of required arguments,\n"
 106             "the number of optional arguments, and a boolean indicating\n"
 107             "whether or not the procedure takes rest arguments.\n\n"
 108             "For a case-lambda procedure, the arity returned is the one\n"
 109             "with the lowest minimum number of arguments, and the highest\n"
 110             "maximum number of arguments.\n\n"
 111             "If it was not possible to determine the arity of the procedure,\n"
 112             "@code{#f} is returned.")
 113 #define FUNC_NAME s_scm_procedure_minimum_arity
 114 {
 115   int req, opt, rest;
 116
 117   if (scm_i_procedure_arity (proc, &req, &opt, &rest))
 118     return scm_list_3 (scm_from_int (req),
 119                        scm_from_int (opt),
 120                        scm_from_bool (rest));
 121   else
 122     return SCM_BOOL_F;
 123 }
 124 #undef FUNC_NAME
 125
 126 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 127            (SCM proc),
 128             "Return @var{obj}'s property list.")
 129 #define FUNC_NAME s_scm_procedure_properties
 130 {
 131   SCM ret;
 132
 133   SCM_VALIDATE_PROC (1, proc);
 134
 135   ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 136
 137   if (scm_is_false (ret))
 138     {
 139       if (SCM_PROGRAM_P (proc))
 140         ret = scm_i_program_properties (proc);
 141       else
 142         ret = SCM_EOL;
 143     }
 144
 145   return ret;
 146 }
 147 #undef FUNC_NAME
 148
 149 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 150            (SCM proc, SCM alist),
 151             "Set @var{proc}'s property list to @var{alist}.")
 152 #define FUNC_NAME s_scm_set_procedure_properties_x
 153 {
 154   SCM_VALIDATE_PROC (1, proc);
 155
 156   scm_weak_table_putq_x (overrides, proc, alist);
 157
 158   return SCM_UNSPECIFIED;
 159 }
 160 #undef FUNC_NAME
 161
 162 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 163            (SCM proc, SCM key),
 164             "Return the property of @var{proc} with name @var{key}.")
 165 #define FUNC_NAME s_scm_procedure_property
 166 {
 167   SCM_VALIDATE_PROC (1, proc);
 168
 169   return scm_assq_ref (scm_procedure_properties (proc), key);
 170 }
 171 #undef FUNC_NAME
 172
 173 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 174            (SCM proc, SCM key, SCM val),
 175             "In @var{proc}'s property list, set the property named @var{key} to\n"
 176             "@var{val}.")
 177 #define FUNC_NAME s_scm_set_procedure_property_x
 178 {
 179   SCM props;
 180
 181   SCM_VALIDATE_PROC (1, proc);
 182
 183   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
 184   props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 185   if (scm_is_false (props))
 186     {
 187       if (SCM_PROGRAM_P (proc))
 188         props = scm_i_program_properties (proc);
 189       else
 190         props = SCM_EOL;
 191     }
 192   scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
 193   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 194
 195   return SCM_UNSPECIFIED;
 196 }
 197 #undef FUNC_NAME
 198
 199 \f
 200
 201
 202 void
 203 scm_init_procprop ()
 204 {
 205   overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 206   arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 207 #include "libguile/procprop.x"
 208 }
 209
 210
 211 /*
 212   Local Variables:
 213   c-file-style: "gnu"
 214   End:
 215 */