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) && !SCM_RTL_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 if (SCM_RTL_PROGRAM_P (proc))
 152     ret = scm_i_rtl_program_properties (proc);
 153   else
 154     ret = SCM_EOL;
 155
 156   if (scm_is_pair (user_props))
 157     for (user_props = scm_cdr (user_props);
 158          scm_is_pair (user_props);
 159          user_props = scm_cdr (user_props))
 160       ret = scm_assq_set_x (ret, scm_caar (user_props), scm_cdar (user_props));
 161
 162   return ret;
 163 }
 164 #undef FUNC_NAME
 165
 166 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 167            (SCM proc, SCM alist),
 168             "Set @var{proc}'s property list to @var{alist}.")
 169 #define FUNC_NAME s_scm_set_procedure_properties_x
 170 {
 171   SCM_VALIDATE_PROC (1, proc);
 172
 173   scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist));
 174
 175   return SCM_UNSPECIFIED;
 176 }
 177 #undef FUNC_NAME
 178
 179 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 180            (SCM proc, SCM key),
 181             "Return the property of @var{proc} with name @var{key}.")
 182 #define FUNC_NAME s_scm_procedure_property
 183 {
 184   SCM user_props;
 185
 186   SCM_VALIDATE_PROC (1, proc);
 187
 188   if (scm_is_eq (key, scm_sym_name))
 189     return scm_procedure_name (proc);
 190   if (scm_is_eq (key, scm_sym_documentation))
 191     return scm_procedure_documentation (proc);
 192
 193   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 194   if (scm_is_true (user_props))
 195     {
 196       SCM pair = scm_assq (key, scm_cdr (user_props));
 197       if (scm_is_pair (pair))
 198         return scm_cdr (pair);
 199       if (scm_is_true (scm_car (user_props)))
 200         return SCM_BOOL_F;
 201     }
 202
 203   return scm_assq_ref (scm_procedure_properties (proc), key);
 204 }
 205 #undef FUNC_NAME
 206
 207 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 208            (SCM proc, SCM key, SCM val),
 209             "In @var{proc}'s property list, set the property named @var{key} to\n"
 210             "@var{val}.")
 211 #define FUNC_NAME s_scm_set_procedure_property_x
 212 {
 213   SCM user_props, override_p;
 214
 215   SCM_VALIDATE_PROC (1, proc);
 216
 217   scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
 218   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 219   if (scm_is_false (user_props))
 220     {
 221       override_p = SCM_BOOL_F;
 222       user_props = SCM_EOL;
 223     }
 224   else
 225     {
 226       override_p = scm_car (user_props);
 227       user_props = scm_cdr (user_props);
 228     }
 229   scm_weak_table_putq_x (overrides, proc,
 230                          scm_cons (override_p,
 231                                    scm_assq_set_x (user_props, key, val)));
 232   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 233
 234   return SCM_UNSPECIFIED;
 235 }
 236 #undef FUNC_NAME
 237
 238
 239 \f
 240
 241 SCM_SYMBOL (scm_sym_source, "source");
 242
 243
 244 SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 245             (SCM proc),
 246             "Return the name of the procedure @var{proc}")
 247 #define FUNC_NAME s_scm_procedure_name
 248 {
 249   SCM user_props;
 250
 251   SCM_VALIDATE_PROC (1, proc);
 252
 253   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
 254   if (scm_is_true (user_props))
 255     {
 256       SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props));
 257       if (scm_is_pair (pair))
 258         return scm_cdr (pair);
 259       if (scm_is_true (scm_car (user_props)))
 260         return SCM_BOOL_F;
 261     }
 262
 263   if (SCM_RTL_PROGRAM_P (proc))
 264     return scm_i_rtl_program_name (proc);
 265   else if (SCM_PROGRAM_P (proc))
 266     return scm_assq_ref (scm_i_program_properties (proc), scm_sym_name);
 267   else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
 268     return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
 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   scm_init_vm_builtin_properties ();
 347 }
 348
 349
 350 /*
 351   Local Variables:
 352   c-file-style: "gnu"
 353   End:
 354 */