libguile/procprop.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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) && !SCM_RTL_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 if (SCM_RTL_PROGRAM_P (proc))
 150         ret = scm_i_rtl_program_properties (proc);
 151       else
 152         ret = SCM_EOL;
 153     }
 154
 155   return ret;
 156 }
 157 #undef FUNC_NAME
 158
 159 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 160            (SCM proc, SCM alist),
 161             "Set @var{proc}'s property list to @var{alist}.")
 162 #define FUNC_NAME s_scm_set_procedure_properties_x
 163 {
 164   SCM_VALIDATE_PROC (1, proc);
 165
 166   scm_weak_table_putq_x (overrides, proc, alist);
 167
 168   return SCM_UNSPECIFIED;
 169 }
 170 #undef FUNC_NAME
 171
 172 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 173            (SCM proc, SCM key),
 174             "Return the property of @var{proc} with name @var{key}.")
 175 #define FUNC_NAME s_scm_procedure_property
 176 {
 177   SCM_VALIDATE_PROC (1, proc);
 178
 179   return scm_assq_ref (scm_procedure_properties (proc), key);
 180 }
 181 #undef FUNC_NAME
 182
 183 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 184            (SCM proc, SCM key, SCM val),
 185             "In @var{proc}'s property list, set the property named @var{key} to\n"
 186             "@var{val}.")
 187 #define FUNC_NAME s_scm_set_procedure_property_x
 188 {
 189   SCM props;
 190
 191   SCM_VALIDATE_PROC (1, proc);
 192
 193   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
 194   props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 195   if (scm_is_false (props))
 196     {
 197       if (SCM_PROGRAM_P (proc))
 198         props = scm_i_program_properties (proc);
 199       else
 200         props = SCM_EOL;
 201     }
 202   scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
 203   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 204
 205   return SCM_UNSPECIFIED;
 206 }
 207 #undef FUNC_NAME
 208
 209
 210 \f
 211
 212 SCM_SYMBOL (scm_sym_source, "source");
 213
 214
 215 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 216             (SCM proc),
 217             "Return the name of the procedure @var{proc}")
 218 #define FUNC_NAME s_scm_procedure_name
 219 {
 220   SCM props, ret;
 221
 222   SCM_VALIDATE_PROC (1, proc);
 223
 224   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 225     proc = SCM_STRUCT_PROCEDURE (proc);
 226
 227   props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 228
 229   if (scm_is_pair (props))
 230     ret = scm_assq_ref (props, scm_sym_name);
 231   else if (SCM_RTL_PROGRAM_P (proc))
 232     ret = scm_i_rtl_program_name (proc);
 233   else if (SCM_PROGRAM_P (proc))
 234     ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
 235   else
 236     ret = SCM_BOOL_F;
 237
 238   return ret;
 239 }
 240 #undef FUNC_NAME
 241
 242
 243 SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
 244
 245 SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
 246            (SCM proc),
 247             "Return the documentation string associated with @code{proc}.  By\n"
 248             "convention, if a procedure contains more than one expression and the\n"
 249             "first expression is a string constant, that string is assumed to contain\n"
 250             "documentation for that procedure.")
 251 #define FUNC_NAME s_scm_procedure_documentation
 252 {
 253   SCM props, ret;
 254
 255   SCM_VALIDATE_PROC (1, proc);
 256
 257   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 258     proc = SCM_STRUCT_PROCEDURE (proc);
 259
 260   props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 261
 262   if (scm_is_pair (props))
 263     ret = scm_assq_ref (props, scm_sym_documentation);
 264   else if (SCM_RTL_PROGRAM_P (proc))
 265     ret = scm_i_rtl_program_documentation (proc);
 266   else if (SCM_PROGRAM_P (proc))
 267     ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_documentation);
 268   else
 269     ret = SCM_BOOL_F;
 270
 271   return ret;
 272 }
 273 #undef FUNC_NAME
 274
 275
 276 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 277             (SCM proc),
 278             "Return the source of the procedure @var{proc}.")
 279 #define FUNC_NAME s_scm_procedure_source
 280 {
 281   SCM src;
 282   SCM_VALIDATE_PROC (1, proc);
 283
 284   do
 285     {
 286       src = scm_procedure_property (proc, scm_sym_source);
 287       if (scm_is_true (src))
 288         return src;
 289
 290       if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
 291           && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
 292         continue;
 293     }
 294   while (0);
 295
 296   return SCM_BOOL_F;
 297 }
 298 #undef FUNC_NAME
 299
 300
 301 \f
 302
 303 void
 304 scm_init_procprop ()
 305 {
 306   overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 307   arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 308 #include "libguile/procprop.x"
 309 }
 310
 311
 312 /*
 313   Local Variables:
 314   c-file-style: "gnu"
 315   End:
 316 */