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   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 253     proc = SCM_STRUCT_PROCEDURE (proc);
 254
 255   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 256   if (scm_is_true (user_props))
 257     {
 258       SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props));
 259       if (scm_is_pair (pair))
 260         return scm_cdr (pair);
 261       if (scm_is_true (scm_car (user_props)))
 262         return SCM_BOOL_F;
 263     }
 264
 265   if (SCM_RTL_PROGRAM_P (proc))
 266     return scm_i_rtl_program_name (proc);
 267   else if (SCM_PROGRAM_P (proc))
 268     return scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
 269   else
 270     return SCM_BOOL_F;
 271 }
 272 #undef FUNC_NAME
 273
 274
 275 SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
 276
 277 SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
 278            (SCM proc),
 279             "Return the documentation string associated with @code{proc}.  By\n"
 280             "convention, if a procedure contains more than one expression and the\n"
 281             "first expression is a string constant, that string is assumed to contain\n"
 282             "documentation for that procedure.")
 283 #define FUNC_NAME s_scm_procedure_documentation
 284 {
 285   SCM user_props;
 286
 287   SCM_VALIDATE_PROC (1, proc);
 288
 289   while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 290     proc = SCM_STRUCT_PROCEDURE (proc);
 291
 292   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 293   if (scm_is_true (user_props))
 294     {
 295       SCM pair = scm_assq (scm_sym_documentation, scm_cdr (user_props));
 296       if (scm_is_pair (pair))
 297         return scm_cdr (pair);
 298       if (scm_is_true (scm_car (user_props)))
 299         return SCM_BOOL_F;
 300     }
 301
 302   if (SCM_RTL_PROGRAM_P (proc))
 303     return scm_i_rtl_program_documentation (proc);
 304   else if (SCM_PROGRAM_P (proc))
 305     return scm_assq_ref (scm_i_program_properties (proc),
 306                          scm_sym_documentation);
 307   else
 308     return SCM_BOOL_F;
 309 }
 310 #undef FUNC_NAME
 311
 312
 313 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
 314             (SCM proc),
 315             "Return the source of the procedure @var{proc}.")
 316 #define FUNC_NAME s_scm_procedure_source
 317 {
 318   SCM src;
 319   SCM_VALIDATE_PROC (1, proc);
 320
 321   do
 322     {
 323       src = scm_procedure_property (proc, scm_sym_source);
 324       if (scm_is_true (src))
 325         return src;
 326
 327       if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
 328           && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
 329         continue;
 330     }
 331   while (0);
 332
 333   return SCM_BOOL_F;
 334 }
 335 #undef FUNC_NAME
 336
 337
 338 \f
 339
 340 void
 341 scm_init_procprop ()
 342 {
 343   overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 344   arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
 345 #include "libguile/procprop.x"
 346 }
 347
 348
 349 /*
 350   Local Variables:
 351   c-file-style: "gnu"
 352   End:
 353 */