libguile/procprop.c

   1 /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 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_gsubr:
  92       {
  93         unsigned int type = SCM_GSUBR_TYPE (proc);
  94         a = SCM_GSUBR_REQ (type);
  95         o = SCM_GSUBR_OPT (type);
  96         r = SCM_GSUBR_REST (type);
  97         break;
  98       }
  99     case scm_tc7_pws:
 100       proc = SCM_PROCEDURE (proc);
 101       goto loop;
 102     case scm_tcs_closures:
 103       proc = SCM_CLOSURE_FORMALS (proc);
 104       if (scm_is_null (proc))
 105         break;
 106       while (scm_is_pair (proc))
 107         {
 108           ++a;
 109           proc = SCM_CDR (proc);
 110         }
 111       if (!scm_is_null (proc))
 112         r = 1;
 113       break;
 114     case scm_tcs_struct:
 115       if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
 116         {
 117           r = 1;
 118           break;
 119         }
 120       else if (!SCM_I_OPERATORP (proc))
 121         return SCM_BOOL_F;
 122       proc = (SCM_I_ENTITYP (proc)
 123               ? SCM_ENTITY_PROCEDURE (proc)
 124               : SCM_OPERATOR_PROCEDURE (proc));
 125       a -= 1;
 126       goto loop;
 127     default:
 128       return SCM_BOOL_F;
 129     }
 130   return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
 131 }
 132
 133 /* XXX - instead of using a stand-in value for everything except
 134    closures, we should find other ways to store the procedure
 135    properties for those other kinds of procedures.  For example, subrs
 136    have their own property slot, which is unused at present.
 137 */
 138
 139 static SCM
 140 scm_stand_in_scm_proc(SCM proc)
 141 {
 142   SCM handle, answer;
 143   handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
 144   if (scm_is_false (handle))
 145     {
 146       answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
 147       scm_hashq_set_x (scm_stand_in_procs, proc, answer);
 148     }
 149   else
 150     answer = SCM_CDR (handle);
 151   return answer;
 152 }
 153
 154 SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
 155            (SCM proc),
 156             "Return @var{obj}'s property list.")
 157 #define FUNC_NAME s_scm_procedure_properties
 158 {
 159   SCM_VALIDATE_PROC (1, proc);
 160   return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
 161                     SCM_PROCPROPS (SCM_CLOSUREP (proc)
 162                                    ? proc
 163                                    : scm_stand_in_scm_proc (proc)));
 164 }
 165 #undef FUNC_NAME
 166
 167 SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
 168            (SCM proc, SCM new_val),
 169             "Set @var{obj}'s property list to @var{alist}.")
 170 #define FUNC_NAME s_scm_set_procedure_properties_x
 171 {
 172   if (!SCM_CLOSUREP (proc))
 173     proc = scm_stand_in_scm_proc(proc);
 174   SCM_VALIDATE_CLOSURE (1, proc);
 175   SCM_SETPROCPROPS (proc, new_val);
 176   return SCM_UNSPECIFIED;
 177 }
 178 #undef FUNC_NAME
 179
 180 SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
 181            (SCM p, SCM k),
 182             "Return the property of @var{obj} with name @var{key}.")
 183 #define FUNC_NAME s_scm_procedure_property
 184 {
 185   SCM assoc;
 186   if (scm_is_eq (k, scm_sym_arity))
 187     {
 188       SCM arity;
 189       SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
 190                   p, SCM_ARG1, FUNC_NAME);
 191       return arity;
 192     }
 193   SCM_VALIDATE_PROC (1, p);
 194   assoc = scm_sloppy_assq (k,
 195                            SCM_PROCPROPS (SCM_CLOSUREP (p)
 196                                           ? p
 197                                           : scm_stand_in_scm_proc (p)));
 198   return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
 199 }
 200 #undef FUNC_NAME
 201
 202 SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
 203            (SCM p, SCM k, SCM v),
 204             "In @var{obj}'s property list, set the property named @var{key} to\n"
 205             "@var{value}.")
 206 #define FUNC_NAME s_scm_set_procedure_property_x
 207 {
 208   SCM assoc;
 209   if (!SCM_CLOSUREP (p))
 210     p = scm_stand_in_scm_proc(p);
 211   SCM_VALIDATE_CLOSURE (1, p);
 212   if (scm_is_eq (k, scm_sym_arity))
 213     SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
 214   assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
 215   if (SCM_NIMP (assoc))
 216     SCM_SETCDR (assoc, v);
 217   else
 218     SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
 219   return SCM_UNSPECIFIED;
 220 }
 221 #undef FUNC_NAME
 222
 223 \f
 224
 225
 226 void
 227 scm_init_procprop ()
 228 {
 229 #include "libguile/procprop.x"
 230 }
 231
 232
 233 /*
 234   Local Variables:
 235   c-file-style: "gnu"
 236   End:
 237 */