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 #include "libguile/vm-builtins.h"
  37
  38 #include "libguile/validate.h"
  39 #include "libguile/procprop.h"
  40 \f
  41
  42 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
  43 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  44
  45 static SCM overrides;
  46
  47 static SCM arity_overrides;
  48
  49 int
  50 scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
  51 {
  52   SCM o;
  53
  54   o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
  55
  56   if (scm_is_true (o))
  57     {
  58       *req = scm_to_int (scm_car (o));
  59       *opt = scm_to_int (scm_cadr (o));
  60       *rest = scm_is_true (scm_caddr (o));
  61       return 1;
  62     }
  63
  64   while (!SCM_PROGRAM_P (proc))
  65     {
  66       if (SCM_STRUCTP (proc))
  67         {
  68           if (!SCM_STRUCT_APPLICABLE_P (proc))
  69             return 0;
  70           proc = SCM_STRUCT_PROCEDURE (proc);
  71         }
  72       else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
  73         {
  74           if (!SCM_SMOB_APPLICABLE_P (proc))
  75             return 0;
  76           if (!scm_i_program_arity (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline,
  77                                     req, opt, rest))
  78             return 0;
  79
  80           /* The trampoline gets the smob too, which users don't
  81              see.  */
  82           *req -= 1;
  83
  84           return 1;
  85         }
  86       else
  87         return 0;
  88     }
  89
  90   return scm_i_program_arity (proc, req, opt, rest);
  91 }
  92
  93 SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
  94             4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
  95             "")
  96 #define FUNC_NAME s_scm_set_procedure_minimum_arity_x
  97 {
  98   int t SCM_UNUSED;
  99
 100   SCM_VALIDATE_PROC (1, proc);
 101   SCM_VALIDATE_INT_COPY (2, req, t);
 102   SCM_VALIDATE_INT_COPY (3, opt, t);
 103   SCM_VALIDATE_BOOL (4, rest);
 104
 105   scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
 106   return SCM_UNDEFINED;
 107 }
 108 #undef FUNC_NAME
 109
 110 SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
 111            (SCM proc),
 112             "Return the \"minimum arity\" of a procedure.\n\n"
 113             "If the procedure has only one arity, that arity is returned\n"
 114             "as a list of three values: the number of required arguments,\n"
 115             "the number of optional arguments, and a boolean indicating\n"
 116             "whether or not the procedure takes rest arguments.\n\n"
 117             "For a case-lambda procedure, the arity returned is the one\n"
 118             "with the lowest minimum number of arguments, and the highest\n"
 119             "maximum number of arguments.\n\n"
 120             "If it was not possible to determine the arity of the procedure,\n"
 121             "@code{#f} is returned.")
 122 #define FUNC_NAME s_scm_procedure_minimum_arity
 123 {
 124   int req, opt, rest;
 125
 126   if (scm_i_procedure_arity (proc, &req, &opt, &rest))
 127     return scm_list_3 (scm_from_int (req),
 128                        scm_from_int (opt),
 129                        scm_from_bool (rest));
 130   else
 131     return SCM_BOOL_F;
 132 }
 133 #undef FUNC_NAME
 134
 135 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 136            (SCM proc),
 137             "Return @var{proc}'s property list.")
 138 #define FUNC_NAME s_scm_procedure_properties
 139 {
 140   SCM ret, user_props;
 141
 142   SCM_VALIDATE_PROC (1, proc);
 143
 144   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 145
 146   if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
 147     return scm_cdr (user_props);
 148
 149   if (SCM_PROGRAM_P (proc))
 150     ret = scm_i_program_properties (proc);
 151   else
 152     ret = SCM_EOL;
 153
 154   if (scm_is_pair (user_props))
 155     for (user_props = scm_cdr (user_props);
 156          scm_is_pair (user_props);
 157          user_props = scm_cdr (user_props))
 158       ret = scm_assq_set_x (ret, scm_caar (user_props), scm_cdar (user_props));
 159
 160   return ret;
 161 }
 162 #undef FUNC_NAME
 163
 164 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 165            (SCM proc, SCM alist),
 166             "Set @var{proc}'s property list to @var{alist}.")
 167 #define FUNC_NAME s_scm_set_procedure_properties_x
 168 {
 169   SCM_VALIDATE_PROC (1, proc);
 170
 171   scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist));
 172
 173   return SCM_UNSPECIFIED;
 174 }
 175 #undef FUNC_NAME
 176
 177 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 178            (SCM proc, SCM key),
 179             "Return the property of @var{proc} with name @var{key}.")
 180 #define FUNC_NAME s_scm_procedure_property
 181 {
 182   SCM user_props;
 183
 184   SCM_VALIDATE_PROC (1, proc);
 185
 186   if (scm_is_eq (key, scm_sym_name))
 187     return scm_procedure_name (proc);
 188   if (scm_is_eq (key, scm_sym_documentation))
 189     return scm_procedure_documentation (proc);
 190
 191   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 192   if (scm_is_true (user_props))
 193     {
 194       SCM pair = scm_assq (key, scm_cdr (user_props));
 195       if (scm_is_pair (pair))
 196         return scm_cdr (pair);
 197       if (scm_is_true (scm_car (user_props)))
 198         return SCM_BOOL_F;
 199     }
 200
 201   return scm_assq_ref (scm_procedure_properties (proc), key);
 202 }
 203 #undef FUNC_NAME
 204
 205 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 206            (SCM proc, SCM key, SCM val),
 207             "In @var{proc}'s property list, set the property named @var{key} to\n"
 208             "@var{val}.")
 209 #define FUNC_NAME s_scm_set_procedure_property_x
 210 {
 211   SCM user_props, override_p;
 212
 213   SCM_VALIDATE_PROC (1, proc);
 214
 215   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
 216   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 217   if (scm_is_false (user_props))
 218     {
 219       override_p = SCM_BOOL_F;
 220       user_props = SCM_EOL;
 221     }
 222   else
 223     {
 224       override_p = scm_car (user_props);
 225       user_props = scm_cdr (user_props);
 226     }
 227   scm_weak_table_putq_x (overrides, proc,
 228                          scm_cons (override_p,
 229                                    scm_assq_set_x (user_props, key, val)));
 230   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 231
 232   return SCM_UNSPECIFIED;
 233 }
 234 #undef FUNC_NAME
 235
 236
 237 \f
 238
 239 SCM_SYMBOL (scm_sym_source, "source");
 240
 241
 242 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 243             (SCM proc),
 244             "Return the name of the procedure @var{proc}")
 245 #define FUNC_NAME s_scm_procedure_name
 246 {
 247   SCM user_props;
 248
 249   SCM_VALIDATE_PROC (1, proc);
 250
 251   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 252   if (scm_is_true (user_props))
 253     {
 254       SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props));
 255       if (scm_is_pair (pair))
 256         return scm_cdr (pair);
 257       if (scm_is_true (scm_car (user_props)))
 258         return SCM_BOOL_F;
 259     }
 260
 261   if (SCM_PROGRAM_P (proc))
 262     return scm_i_program_name (proc);
 263   else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 264     return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
 265   else
 266     return SCM_BOOL_F;
 267 }
 268 #undef FUNC_NAME
 269
 270
 271 SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
 272
 273 SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
 274            (SCM proc),
 275             "Return the documentation string associated with @code{proc}.  By\n"
 276             "convention, if a procedure contains more than one expression and the\n"
 277             "first expression is a string constant, that string is assumed to contain\n"
 278             "documentation for that procedure.")
 279 #define FUNC_NAME s_scm_procedure_documentation
 280 {
 281   SCM user_props;
 282
 283   SCM_VALIDATE_PROC (1, proc);
 284
 285   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 286     proc = SCM_STRUCT_PROCEDURE (proc);
 287
 288   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 289   if (scm_is_true (user_props))
 290     {
 291       SCM pair = scm_assq (scm_sym_documentation, scm_cdr (user_props));
 292       if (scm_is_pair (pair))
 293         return scm_cdr (pair);
 294       if (scm_is_true (scm_car (user_props)))
 295         return SCM_BOOL_F;
 296     }
 297
 298   if (SCM_PROGRAM_P (proc))
 299     return scm_i_program_documentation (proc);
 300   else
 301     return SCM_BOOL_F;
 302 }
 303 #undef FUNC_NAME
 304
 305
 306 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 307             (SCM proc),
 308             "Return the source of the procedure @var{proc}.")
 309 #define FUNC_NAME s_scm_procedure_source
 310 {
 311   SCM src;
 312   SCM_VALIDATE_PROC (1, proc);
 313
 314   do
 315     {
 316       src = scm_procedure_property (proc, scm_sym_source);
 317       if (scm_is_true (src))
 318         return src;
 319
 320       if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
 321           && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
 322         continue;
 323     }
 324   while (0);
 325
 326   return SCM_BOOL_F;
 327 }
 328 #undef FUNC_NAME
 329
 330
 331 \f
 332
 333 void
 334 scm_init_procprop ()
 335 {
 336   overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 337   arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 338 #include "libguile/procprop.x"
 339   scm_init_vm_builtin_properties ();
 340 }
 341
 342
 343 /*
 344   Local Variables:
 345   c-file-style: "gnu"
 346   End:
 347 */