libguile/procprop.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but 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 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25
  26 #include "libguile/alist.h"
  27 #include "libguile/eval.h"
  28 #include "libguile/procs.h"
  29 #include "libguile/gsubr.h"
  30 #include "libguile/objects.h"
  31 #include "libguile/smob.h"
  32 #include "libguile/root.h"
  33 #include "libguile/vectors.h"
  34 #include "libguile/hashtab.h"
  35
  36 #include "libguile/validate.h"
  37 #include "libguile/procprop.h"
  38 \f
  39
  40 SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
  41 SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
  42
  43 SCM
  44 scm_i_procedure_arity (SCM proc)
  45 {
  46   int a = 0, o = 0, r = 0;
  47   if (SCM_IMP (proc))
  48     return SCM_BOOL_F;
  49  loop:
  50   switch (SCM_TYP7 (proc))
  51     {
  52     case scm_tc7_subr_1o:
  53       o = 1;
  54     case scm_tc7_subr_0:
  55       break;
  56     case scm_tc7_subr_2o:
  57       o = 1;
  58     case scm_tc7_subr_1:
  59     case scm_tc7_dsubr:
  60     case scm_tc7_cxr:
  61       a += 1;
  62       break;
  63     case scm_tc7_subr_2:
  64       a += 2;
  65       break;
  66     case scm_tc7_subr_3:
  67       a += 3;
  68       break;
  69     case scm_tc7_asubr:
  70     case scm_tc7_rpsubr:
  71     case scm_tc7_lsubr:
  72       r = 1;
  73       break;
  74     case scm_tc7_lsubr_2:
  75       a += 2;
  76       r = 1;
  77       break;
  78     case scm_tc7_smob:
  79       if (SCM_SMOB_APPLICABLE_P (proc))
  80         {
  81           int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
  82           a += SCM_GSUBR_REQ (type);
  83           o = SCM_GSUBR_OPT (type);
  84           r = SCM_GSUBR_REST (type);
  85           break;
  86         }
  87       else
  88         {
  89           return SCM_BOOL_F;
  90         }
  91     case scm_tc7_cclo:
  92       if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply))
  93         {
  94           int type = scm_to_int (SCM_GSUBR_TYPE (proc));
  95           a += SCM_GSUBR_REQ (type);
  96           o = SCM_GSUBR_OPT (type);
  97           r = SCM_GSUBR_REST (type);
  98           break;
  99         }
 100       else
 101         {
 102           proc = SCM_CCLO_SUBR (proc);
 103           a -= 1;
 104           goto loop;
 105         }
 106     case scm_tc7_pws:
 107       proc = SCM_PROCEDURE (proc);
 108       goto loop;
 109     case scm_tcs_closures:
 110       proc = SCM_CLOSURE_FORMALS (proc);
 111       if (scm_is_null (proc))
 112         break;
 113       while (scm_is_pair (proc))
 114         {
 115           ++a;
 116           proc = SCM_CDR (proc);
 117         }
 118       if (!scm_is_null (proc))
 119         r = 1;
 120       break;
 121     case scm_tcs_struct:
 122       if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
 123         {
 124           r = 1;
 125           break;
 126         }
 127       else if (!SCM_I_OPERATORP (proc))
 128         return SCM_BOOL_F;
 129       proc = (SCM_I_ENTITYP (proc)
 130               ? SCM_ENTITY_PROCEDURE (proc)
 131               : SCM_OPERATOR_PROCEDURE (proc));
 132       a -= 1;
 133       goto loop;
 134     default:
 135       return SCM_BOOL_F;
 136     }
 137   return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
 138 }
 139
 140 /* XXX - instead of using a stand-in value for everything except
 141    closures, we should find other ways to store the procedure
 142    properties for those other kinds of procedures.  For example, subrs
 143    have their own property slot, which is unused at present.
 144 */
 145
 146 static SCM
 147 scm_stand_in_scm_proc(SCM proc)
 148 {
 149   SCM handle, answer;
 150   handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
 151   if (scm_is_false (handle))
 152     {
 153       answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
 154       scm_hashq_set_x (scm_stand_in_procs, proc, answer);
 155     }
 156   else
 157     answer = SCM_CDR (handle);
 158   return answer;
 159 }
 160
 161 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 162            (SCM proc),
 163             "Return @var{obj}'s property list.")
 164 #define FUNC_NAME s_scm_procedure_properties
 165 {
 166   SCM_VALIDATE_PROC (1, proc);
 167   return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
 168                     SCM_PROCPROPS (SCM_CLOSUREP (proc)
 169                                    ? proc
 170                                    : scm_stand_in_scm_proc (proc)));
 171 }
 172 #undef FUNC_NAME
 173
 174 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 175            (SCM proc, SCM new_val),
 176             "Set @var{obj}'s property list to @var{alist}.")
 177 #define FUNC_NAME s_scm_set_procedure_properties_x
 178 {
 179   if (!SCM_CLOSUREP (proc))
 180     proc = scm_stand_in_scm_proc(proc);
 181   SCM_VALIDATE_CLOSURE (1, proc);
 182   SCM_SETPROCPROPS (proc, new_val);
 183   return SCM_UNSPECIFIED;
 184 }
 185 #undef FUNC_NAME
 186
 187 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 188            (SCM p, SCM k),
 189             "Return the property of @var{obj} with name @var{key}.")
 190 #define FUNC_NAME s_scm_procedure_property
 191 {
 192   SCM assoc;
 193   if (scm_is_eq (k, scm_sym_arity))
 194     {
 195       SCM arity;
 196       SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
 197                   p, SCM_ARG1, FUNC_NAME);
 198       return arity;
 199     }
 200   SCM_VALIDATE_PROC (1, p);
 201   assoc = scm_sloppy_assq (k,
 202                            SCM_PROCPROPS (SCM_CLOSUREP (p)
 203                                           ? p
 204                                           : scm_stand_in_scm_proc (p)));
 205   return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
 206 }
 207 #undef FUNC_NAME
 208
 209 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 210            (SCM p, SCM k, SCM v),
 211             "In @var{obj}'s property list, set the property named @var{key} to\n"
 212             "@var{value}.")
 213 #define FUNC_NAME s_scm_set_procedure_property_x
 214 {
 215   SCM assoc;
 216   if (!SCM_CLOSUREP (p))
 217     p = scm_stand_in_scm_proc(p);
 218   SCM_VALIDATE_CLOSURE (1, p);
 219   if (scm_is_eq (k, scm_sym_arity))
 220     SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
 221   assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
 222   if (SCM_NIMP (assoc))
 223     SCM_SETCDR (assoc, v);
 224   else
 225     SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
 226   return SCM_UNSPECIFIED;
 227 }
 228 #undef FUNC_NAME
 229
 230 \f
 231
 232
 233 void
 234 scm_init_procprop ()
 235 {
 236 #include "libguile/procprop.x"
 237 }
 238
 239
 240 /*
 241   Local Variables:
 242   c-file-style: "gnu"
 243   End:
 244 */