libguile/procprop.c

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