libguile/procprop.c

   1 /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006,
   2  *   2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #define SCM_BUILDING_DEPRECATED_CODE
  27
  28 #include "libguile/_scm.h"
  29
  30 #include "libguile/alist.h"
  31 #include "libguile/deprecation.h"
  32 #include "libguile/deprecated.h"
  33 #include "libguile/eval.h"
  34 #include "libguile/procs.h"
  35 #include "libguile/gsubr.h"
  36 #include "libguile/smob.h"
  37 #include "libguile/root.h"
  38 #include "libguile/vectors.h"
  39 #include "libguile/hashtab.h"
  40 #include "libguile/programs.h"
  41
  42 #include "libguile/validate.h"
  43 #include "libguile/procprop.h"
  44 \f
  45
  46 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
  47 #if (SCM_ENABLE_DEPRECATED == 1)
  48 SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
  49 #endif
  50 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  51
  52 static SCM overrides;
  53 static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  54
  55 static SCM arity_overrides;
  56
  57 int
  58 scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
  59 {
  60   SCM o;
  61
  62   scm_i_pthread_mutex_lock (&overrides_lock);
  63   o = scm_hashq_ref (arity_overrides, proc, SCM_BOOL_F);
  64   scm_i_pthread_mutex_unlock (&overrides_lock);
  65
  66   if (scm_is_true (o))
  67     {
  68       *req = scm_to_int (scm_car (o));
  69       *opt = scm_to_int (scm_cadr (o));
  70       *rest = scm_is_true (scm_caddr (o));
  71       return 1;
  72     }
  73
  74   while (!SCM_PROGRAM_P (proc))
  75     {
  76       if (SCM_IMP (proc))
  77         return 0;
  78       switch (SCM_TYP7 (proc))
  79         {
  80         case scm_tc7_smob:
  81           if (!SCM_SMOB_APPLICABLE_P (proc))
  82             return 0;
  83           if (!scm_i_program_arity
  84               (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline_objcode,
  85                req, opt, rest))
  86             return 0;
  87
  88           /* The trampoline gets the smob too, which users don't
  89              see.  */
  90           *req -= 1;
  91
  92           return 1;
  93         case scm_tcs_struct:
  94           if (!SCM_STRUCT_APPLICABLE_P (proc))
  95             return 0;
  96           proc = SCM_STRUCT_PROCEDURE (proc);
  97           break;
  98         default:
  99           return 0;
 100         }
 101     }
 102
 103   return scm_i_program_arity (proc, req, opt, rest);
 104 }
 105
 106 SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
 107             4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
 108             "")
 109 #define FUNC_NAME s_scm_set_procedure_minimum_arity_x
 110 {
 111   int t SCM_UNUSED;
 112
 113   SCM_VALIDATE_PROC (1, proc);
 114   SCM_VALIDATE_INT_COPY (2, req, t);
 115   SCM_VALIDATE_INT_COPY (3, opt, t);
 116   SCM_VALIDATE_BOOL (4, rest);
 117
 118   scm_i_pthread_mutex_lock (&overrides_lock);
 119   scm_hashq_set_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
 120   scm_i_pthread_mutex_unlock (&overrides_lock);
 121   return SCM_UNDEFINED;
 122 }
 123 #undef FUNC_NAME
 124
 125 SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
 126            (SCM proc),
 127             "Return the \"minimum arity\" of a procedure.\n\n"
 128             "If the procedure has only one arity, that arity is returned\n"
 129             "as a list of three values: the number of required arguments,\n"
 130             "the number of optional arguments, and a boolean indicating\n"
 131             "whether or not the procedure takes rest arguments.\n\n"
 132             "For a case-lambda procedure, the arity returned is the one\n"
 133             "with the lowest minimum number of arguments, and the highest\n"
 134             "maximum number of arguments.\n\n"
 135             "If it was not possible to determine the arity of the procedure,\n"
 136             "@code{#f} is returned.")
 137 #define FUNC_NAME s_scm_procedure_minimum_arity
 138 {
 139   int req, opt, rest;
 140
 141   if (scm_i_procedure_arity (proc, &req, &opt, &rest))
 142     return scm_list_3 (scm_from_int (req),
 143                        scm_from_int (opt),
 144                        scm_from_bool (rest));
 145   else
 146     return SCM_BOOL_F;
 147 }
 148 #undef FUNC_NAME
 149
 150 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 151            (SCM proc),
 152             "Return @var{proc}'s property list.")
 153 #define FUNC_NAME s_scm_procedure_properties
 154 {
 155   SCM ret;
 156
 157   SCM_VALIDATE_PROC (1, proc);
 158
 159   scm_i_pthread_mutex_lock (&overrides_lock);
 160   ret = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
 161   scm_i_pthread_mutex_unlock (&overrides_lock);
 162
 163   if (scm_is_false (ret))
 164     {
 165       if (SCM_PROGRAM_P (proc))
 166         ret = scm_i_program_properties (proc);
 167       else
 168         ret = SCM_EOL;
 169     }
 170
 171 #if (SCM_ENABLE_DEPRECATED == 1)
 172   ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret);
 173 #endif
 174
 175   return ret;
 176 }
 177 #undef FUNC_NAME
 178
 179 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 180            (SCM proc, SCM alist),
 181             "Set @var{proc}'s property list to @var{alist}.")
 182 #define FUNC_NAME s_scm_set_procedure_properties_x
 183 {
 184   SCM_VALIDATE_PROC (1, proc);
 185
 186 #if (SCM_ENABLE_DEPRECATED == 1)
 187   if (scm_is_true (scm_assq (scm_sym_arity, alist)))
 188     SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
 189 #endif
 190
 191   scm_i_pthread_mutex_lock (&overrides_lock);
 192   scm_hashq_set_x (overrides, proc, alist);
 193   scm_i_pthread_mutex_unlock (&overrides_lock);
 194
 195   return SCM_UNSPECIFIED;
 196 }
 197 #undef FUNC_NAME
 198
 199 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 200            (SCM proc, SCM key),
 201             "Return the property of @var{proc} with name @var{key}.")
 202 #define FUNC_NAME s_scm_procedure_property
 203 {
 204   SCM_VALIDATE_PROC (1, proc);
 205
 206 #if (SCM_ENABLE_DEPRECATED == 1)
 207   if (scm_is_eq (key, scm_sym_arity))
 208     scm_c_issue_deprecation_warning
 209       ("Accessing a procedure's arity via `procedure-property' is deprecated.\n"
 210        "Use `procedure-minimum-arity instead.");
 211 #endif
 212
 213   return scm_assq_ref (scm_procedure_properties (proc), key);
 214 }
 215 #undef FUNC_NAME
 216
 217 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 218            (SCM proc, SCM key, SCM val),
 219             "In @var{proc}'s property list, set the property named @var{key} to\n"
 220             "@var{val}.")
 221 #define FUNC_NAME s_scm_set_procedure_property_x
 222 {
 223   SCM props;
 224
 225   SCM_VALIDATE_PROC (1, proc);
 226
 227 #if (SCM_ENABLE_DEPRECATED == 1)
 228   if (scm_is_eq (key, scm_sym_arity))
 229     SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL);
 230 #endif
 231
 232   scm_dynwind_begin (0);
 233   /* Here we must block asyncs while overrides_lock is held, to avoid
 234      deadlocks which can happen as follows: scm_i_program_properties
 235      calls out to the VM, which will run asyncs.  Asyncs are permitted
 236      to run VM code, which sometimes checks procedure properties, which
 237      locks overrides_lock. */
 238   scm_i_dynwind_pthread_mutex_lock_block_asyncs (&overrides_lock);
 239   props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
 240   if (scm_is_false (props))
 241     {
 242       if (SCM_PROGRAM_P (proc))
 243         props = scm_i_program_properties (proc);
 244       else
 245         props = SCM_EOL;
 246     }
 247   scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
 248   scm_dynwind_end ();
 249
 250   return SCM_UNSPECIFIED;
 251 }
 252 #undef FUNC_NAME
 253
 254 \f
 255
 256
 257 void
 258 scm_init_procprop ()
 259 {
 260   overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 261   arity_overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
 262 #include "libguile/procprop.x"
 263 }
 264
 265
 266 /*
 267   Local Variables:
 268   c-file-style: "gnu"
 269   End:
 270 */