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 #define SCM_BUILDING_DEPRECATED_CODE
  26
  27 #include "libguile/_scm.h"
  28
  29 #include "libguile/alist.h"
  30 #include "libguile/deprecation.h"
  31 #include "libguile/deprecated.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/procs.h"
  34 #include "libguile/gsubr.h"
  35 #include "libguile/smob.h"
  36 #include "libguile/root.h"
  37 #include "libguile/vectors.h"
  38 #include "libguile/hashtab.h"
  39 #include "libguile/programs.h"
  40
  41 #include "libguile/validate.h"
  42 #include "libguile/procprop.h"
  43 \f
  44
  45 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
  46 #if (SCM_ENABLE_DEPRECATED == 1)
  47 SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
  48 #endif
  49 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  50
  51 static SCM overrides;
  52 static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  53
  54 int
  55 scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
  56 {
  57   while (!SCM_PROGRAM_P (proc))
  58     {
  59       if (SCM_IMP (proc))
  60         return 0;
  61       switch (SCM_TYP7 (proc))
  62         {
  63         case scm_tc7_smob:
  64           if (!SCM_SMOB_APPLICABLE_P (proc))
  65             return 0;
  66           proc = scm_i_smob_apply_trampoline (proc);
  67           break;
  68         case scm_tcs_struct:
  69           if (!SCM_STRUCT_APPLICABLE_P (proc))
  70             return 0;
  71           proc = SCM_STRUCT_PROCEDURE (proc);
  72           break;
  73         default:
  74           return 0;
  75         }
  76     }
  77   return scm_i_program_arity (proc, req, opt, rest);
  78 }
  79
  80 SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
  81            (SCM proc),
  82             "Return the \"minimum arity\" of a procedure.\n\n"
  83             "If the procedure has only one arity, that arity is returned\n"
  84             "as a list of three values: the number of required arguments,\n"
  85             "the number of optional arguments, and a boolean indicating\n"
  86             "whether or not the procedure takes rest arguments.\n\n"
  87             "For a case-lambda procedure, the arity returned is the one\n"
  88             "with the lowest minimum number of arguments, and the highest\n"
  89             "maximum number of arguments.\n\n"
  90             "If it was not possible to determine the arity of the procedure,\n"
  91             "@code{#f} is returned.")
  92 #define FUNC_NAME s_scm_procedure_minimum_arity
  93 {
  94   int req, opt, rest;
  95
  96   if (scm_i_procedure_arity (proc, &req, &opt, &rest))
  97     return scm_list_3 (scm_from_int (req),
  98                        scm_from_int (opt),
  99                        scm_from_bool (rest));
 100   else
 101     return SCM_BOOL_F;
 102 }
 103 #undef FUNC_NAME
 104
 105 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 106            (SCM proc),
 107             "Return @var{obj}'s property list.")
 108 #define FUNC_NAME s_scm_procedure_properties
 109 {
 110   SCM ret;
 111
 112   SCM_VALIDATE_PROC (1, proc);
 113
 114   scm_i_pthread_mutex_lock (&overrides_lock);
 115   ret = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
 116   scm_i_pthread_mutex_unlock (&overrides_lock);
 117
 118   if (scm_is_false (ret))
 119     {
 120       if (SCM_PROGRAM_P (proc))
 121         ret = scm_i_program_properties (proc);
 122       else
 123         ret = SCM_EOL;
 124     }
 125
 126 #if (SCM_ENABLE_DEPRECATED == 1)
 127   ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret);
 128 #endif
 129
 130   return ret;
 131 }
 132 #undef FUNC_NAME
 133
 134 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 135            (SCM proc, SCM alist),
 136             "Set @var{proc}'s property list to @var{alist}.")
 137 #define FUNC_NAME s_scm_set_procedure_properties_x
 138 {
 139   SCM_VALIDATE_PROC (1, proc);
 140
 141 #if (SCM_ENABLE_DEPRECATED == 1)
 142   if (scm_assq (alist, scm_sym_arity))
 143     SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
 144 #endif
 145
 146   scm_i_pthread_mutex_lock (&overrides_lock);
 147   scm_hashq_set_x (overrides, proc, alist);
 148   scm_i_pthread_mutex_unlock (&overrides_lock);
 149
 150   return SCM_UNSPECIFIED;
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 155            (SCM proc, SCM key),
 156             "Return the property of @var{proc} with name @var{key}.")
 157 #define FUNC_NAME s_scm_procedure_property
 158 {
 159   SCM_VALIDATE_PROC (1, proc);
 160
 161 #if (SCM_ENABLE_DEPRECATED == 1)
 162   if (scm_is_eq (key, scm_sym_arity))
 163     scm_c_issue_deprecation_warning
 164       ("Accessing a procedure's arity via `procedure-property' is deprecated.\n"
 165        "Use `procedure-minimum-arity instead.");
 166 #endif
 167
 168   return scm_assq_ref (scm_procedure_properties (proc), key);
 169 }
 170 #undef FUNC_NAME
 171
 172 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 173            (SCM proc, SCM key, SCM val),
 174             "In @var{proc}'s property list, set the property named @var{key} to\n"
 175             "@var{val}.")
 176 #define FUNC_NAME s_scm_set_procedure_property_x
 177 {
 178   SCM props;
 179
 180   SCM_VALIDATE_PROC (1, proc);
 181
 182 #if (SCM_ENABLE_DEPRECATED == 1)
 183   if (scm_is_eq (key, scm_sym_arity))
 184     SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL);
 185 #endif
 186
 187   scm_i_pthread_mutex_lock (&overrides_lock);
 188   props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
 189   if (scm_is_false (props))
 190     {
 191       if (SCM_PROGRAM_P (proc))
 192         props = scm_i_program_properties (proc);
 193       else
 194         props = SCM_EOL;
 195     }
 196   scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
 197   scm_i_pthread_mutex_unlock (&overrides_lock);
 198
 199   return SCM_UNSPECIFIED;
 200 }
 201 #undef FUNC_NAME
 202
 203 \f
 204
 205
 206 void
 207 scm_init_procprop ()
 208 {
 209   overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 210 #include "libguile/procprop.x"
 211 }
 212
 213
 214 /*
 215   Local Variables:
 216   c-file-style: "gnu"
 217   End:
 218 */