libguile/procs.c

   1 /* Copyright (C) 1995,1996,1997,1999,2000,2001, 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 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/objects.h"
  28 #include "libguile/strings.h"
  29 #include "libguile/vectors.h"
  30 #include "libguile/smob.h"
  31 #include "libguile/deprecation.h"
  32
  33 #include "libguile/validate.h"
  34 #include "libguile/procs.h"
  35 #include "libguile/procprop.h"
  36 #include "libguile/objcodes.h"
  37 #include "libguile/programs.h"
  38 \f
  39
  40
  41 /* {Procedures}
  42  */
  43
  44
  45 SCM
  46 scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
  47 {
  48   register SCM z;
  49   SCM sname;
  50   SCM *meta_info;
  51
  52   meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
  53   sname = scm_from_locale_symbol (name);
  54   meta_info[0] = sname;
  55   meta_info[1] = SCM_EOL;  /* properties */
  56
  57   z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn,
  58                        0 /* generic */, (scm_t_bits) meta_info);
  59
  60   scm_remember_upto_here_1 (sname);
  61
  62   return z;
  63 }
  64
  65 SCM
  66 scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
  67 {
  68   SCM subr = scm_c_make_subr (name, type, fcn);
  69   scm_define (SCM_SUBR_NAME (subr), subr);
  70   return subr;
  71 }
  72
  73 SCM
  74 scm_c_make_subr_with_generic (const char *name,
  75                               long type, SCM (*fcn) (), SCM *gf)
  76 {
  77   SCM subr = scm_c_make_subr (name, type, fcn);
  78   SCM_SET_SUBR_GENERIC_LOC (subr, gf);
  79   return subr;
  80 }
  81
  82 SCM
  83 scm_c_define_subr_with_generic (const char *name,
  84                                 long type, SCM (*fcn) (), SCM *gf)
  85 {
  86   SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
  87   scm_define (SCM_SUBR_NAME (subr), subr);
  88   return subr;
  89 }
  90
  91
  92 SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
  93             (SCM obj),
  94             "Return @code{#t} if @var{obj} is a procedure.")
  95 #define FUNC_NAME s_scm_procedure_p
  96 {
  97   if (SCM_NIMP (obj))
  98     switch (SCM_TYP7 (obj))
  99       {
 100       case scm_tcs_struct:
 101         if (!SCM_I_OPERATORP (obj))
 102           break;
 103       case scm_tcs_closures:
 104       case scm_tcs_subrs:
 105       case scm_tc7_pws:
 106       case scm_tc7_program:
 107         return SCM_BOOL_T;
 108       case scm_tc7_smob:
 109         return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
 110       default:
 111         return SCM_BOOL_F;
 112       }
 113   return SCM_BOOL_F;
 114 }
 115 #undef FUNC_NAME
 116
 117 SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
 118            (SCM obj),
 119             "Return @code{#t} if @var{obj} is a closure.")
 120 #define FUNC_NAME s_scm_closure_p
 121 {
 122   return scm_from_bool (SCM_CLOSUREP (obj));
 123 }
 124 #undef FUNC_NAME
 125
 126 SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
 127             (SCM obj),
 128             "Return @code{#t} if @var{obj} is a thunk.")
 129 #define FUNC_NAME s_scm_thunk_p
 130 {
 131   if (SCM_NIMP (obj))
 132     {
 133     again:
 134       switch (SCM_TYP7 (obj))
 135         {
 136         case scm_tcs_closures:
 137           return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
 138         case scm_tc7_subr_0:
 139         case scm_tc7_subr_1o:
 140         case scm_tc7_lsubr:
 141         case scm_tc7_rpsubr:
 142         case scm_tc7_asubr:
 143           return SCM_BOOL_T;
 144         case scm_tc7_gsubr:
 145           return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
 146         case scm_tc7_program:
 147           {
 148             int a, o, r;
 149             if (scm_i_program_arity (obj, &a, &o, &r))
 150               return scm_from_bool (a == 0);
 151             else
 152               return SCM_BOOL_F;
 153           }
 154         case scm_tc7_pws:
 155           obj = SCM_PROCEDURE (obj);
 156           goto again;
 157         default:
 158           return SCM_BOOL_F;
 159         }
 160     }
 161   return SCM_BOOL_F;
 162 }
 163 #undef FUNC_NAME
 164
 165 /* Only used internally. */
 166 int
 167 scm_subr_p (SCM obj)
 168 {
 169   if (SCM_NIMP (obj))
 170     switch (SCM_TYP7 (obj))
 171       {
 172       case scm_tcs_subrs:
 173         return 1;
 174       default:
 175         ;
 176       }
 177   return 0;
 178 }
 179
 180 SCM_SYMBOL (sym_documentation, "documentation");
 181
 182 SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
 183            (SCM proc),
 184             "Return the documentation string associated with @code{proc}.  By\n"
 185             "convention, if a procedure contains more than one expression and the\n"
 186             "first expression is a string constant, that string is assumed to contain\n"
 187             "documentation for that procedure.")
 188 #define FUNC_NAME s_scm_procedure_documentation
 189 {
 190   SCM code;
 191   SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
 192               proc, SCM_ARG1, FUNC_NAME);
 193   if (SCM_PROGRAM_P (proc))
 194     return scm_assq_ref (scm_program_properties (proc), sym_documentation);
 195   switch (SCM_TYP7 (proc))
 196     {
 197     case scm_tcs_closures:
 198       code = SCM_CLOSURE_BODY (proc);
 199       if (scm_is_null (SCM_CDR (code)))
 200         return SCM_BOOL_F;
 201       code = SCM_CAR (code);
 202       if (scm_is_string (code))
 203         return code;
 204       else
 205         return SCM_BOOL_F;
 206     default:
 207       return SCM_BOOL_F;
 208     }
 209 }
 210 #undef FUNC_NAME
 211
 212
 213 /* Procedure-with-setter
 214  */
 215
 216 SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
 217             (SCM obj),
 218             "Return @code{#t} if @var{obj} is a procedure with an\n"
 219             "associated setter procedure.")
 220 #define FUNC_NAME s_scm_procedure_with_setter_p
 221 {
 222   return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
 223 }
 224 #undef FUNC_NAME
 225
 226 SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
 227             (SCM procedure, SCM setter),
 228             "Create a new procedure which behaves like @var{procedure}, but\n"
 229             "with the associated setter @var{setter}.")
 230 #define FUNC_NAME s_scm_make_procedure_with_setter
 231 {
 232   SCM name, ret;
 233   SCM_VALIDATE_PROC (1, procedure);
 234   SCM_VALIDATE_PROC (2, setter);
 235   ret = scm_double_cell (scm_tc7_pws,
 236                          SCM_UNPACK (procedure),
 237                          SCM_UNPACK (setter), 0);
 238   /* don't use procedure_name, because don't care enough to do a reverse
 239      lookup */
 240   switch (SCM_TYP7 (procedure)) {
 241   case scm_tcs_subrs:
 242     name = SCM_SUBR_NAME (procedure);
 243     break;
 244   default:
 245     name = scm_procedure_property (procedure, scm_sym_name);
 246     break;
 247   }
 248   if (scm_is_true (name))
 249     scm_set_procedure_property_x (ret, scm_sym_name, name);
 250   return ret;
 251 }
 252 #undef FUNC_NAME
 253
 254 SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
 255             (SCM proc),
 256             "Return the procedure of @var{proc}, which must be either a\n"
 257             "procedure with setter, or an operator struct.")
 258 #define FUNC_NAME s_scm_procedure
 259 {
 260   SCM_VALIDATE_NIM (1, proc);
 261   if (SCM_PROCEDURE_WITH_SETTER_P (proc))
 262     return SCM_PROCEDURE (proc);
 263   else if (SCM_STRUCTP (proc))
 264     {
 265       SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
 266       return proc;
 267     }
 268   SCM_WRONG_TYPE_ARG (1, proc);
 269   return SCM_BOOL_F; /* not reached */
 270 }
 271 #undef FUNC_NAME
 272
 273 SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
 274
 275 SCM
 276 scm_setter (SCM proc)
 277 {
 278   SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
 279   if (SCM_PROCEDURE_WITH_SETTER_P (proc))
 280     return SCM_SETTER (proc);
 281   else if (SCM_STRUCTP (proc))
 282     {
 283       SCM setter;
 284       SCM_GASSERT1 (SCM_I_OPERATORP (proc),
 285                     g_setter, proc, SCM_ARG1, s_setter);
 286       setter = (SCM_I_ENTITYP (proc)
 287                 ? SCM_ENTITY_SETTER (proc)
 288                 : SCM_OPERATOR_SETTER (proc));
 289       if (SCM_NIMP (setter))
 290         return setter;
 291       /* fall through */
 292     }
 293   SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
 294   return SCM_BOOL_F; /* not reached */
 295 }
 296
 297 \f
 298 void
 299 scm_init_procs ()
 300 {
 301 #include "libguile/procs.x"
 302 }
 303
 304 /*
 305   Local Variables:
 306   c-file-style: "gnu"
 307   End:
 308 */