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