libguile/procprop.c

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