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 /* This function isn't currently used since subrs are never freed. */
  74 /* *fixme* Need mutex here. */
  75 void
  76 scm_free_subr_entry (SCM subr)
  77 {
  78   scm_gc_free (SCM_SUBR_META_INFO (subr), 2 * sizeof (SCM),
  79                "subr meta-info");
  80 }
  81
  82 SCM
  83 scm_c_make_subr_with_generic (const char *name,
  84                               long type, SCM (*fcn) (), SCM *gf)
  85 {
  86   SCM subr = scm_c_make_subr (name, type, fcn);
  87   SCM_SET_SUBR_GENERIC_LOC (subr, gf);
  88   return subr;
  89 }
  90
  91 SCM
  92 scm_c_define_subr_with_generic (const char *name,
  93                                 long type, SCM (*fcn) (), SCM *gf)
  94 {
  95   SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
  96   scm_define (SCM_SUBR_NAME (subr), subr);
  97   return subr;
  98 }
  99
 100
 101 SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
 102             (SCM obj),
 103             "Return @code{#t} if @var{obj} is a procedure.")
 104 #define FUNC_NAME s_scm_procedure_p
 105 {
 106   if (SCM_NIMP (obj))
 107     switch (SCM_TYP7 (obj))
 108       {
 109       case scm_tcs_struct:
 110         if (!SCM_I_OPERATORP (obj))
 111           break;
 112       case scm_tcs_closures:
 113       case scm_tcs_subrs:
 114       case scm_tc7_pws:
 115         return SCM_BOOL_T;
 116       case scm_tc7_smob:
 117         return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
 118       default:
 119         return SCM_BOOL_F;
 120       }
 121   return SCM_BOOL_F;
 122 }
 123 #undef FUNC_NAME
 124
 125 SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
 126            (SCM obj),
 127             "Return @code{#t} if @var{obj} is a closure.")
 128 #define FUNC_NAME s_scm_closure_p
 129 {
 130   return scm_from_bool (SCM_CLOSUREP (obj));
 131 }
 132 #undef FUNC_NAME
 133
 134 SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
 135             (SCM obj),
 136             "Return @code{#t} if @var{obj} is a thunk.")
 137 #define FUNC_NAME s_scm_thunk_p
 138 {
 139   if (SCM_NIMP (obj))
 140     {
 141     again:
 142       switch (SCM_TYP7 (obj))
 143         {
 144         case scm_tcs_closures:
 145           return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
 146         case scm_tc7_subr_0:
 147         case scm_tc7_subr_1o:
 148         case scm_tc7_lsubr:
 149         case scm_tc7_rpsubr:
 150         case scm_tc7_asubr:
 151           return SCM_BOOL_T;
 152         case scm_tc7_gsubr:
 153           return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
 154         case scm_tc7_pws:
 155           obj = SCM_PROCEDURE (obj);
 156           goto again;
 157         default:
 158           if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
 159             return SCM_BOOL_T;
 160           /* otherwise fall through */
 161         }
 162     }
 163   return SCM_BOOL_F;
 164 }
 165 #undef FUNC_NAME
 166
 167 /* Only used internally. */
 168 int
 169 scm_subr_p (SCM obj)
 170 {
 171   if (SCM_NIMP (obj))
 172     switch (SCM_TYP7 (obj))
 173       {
 174       case scm_tcs_subrs:
 175         return 1;
 176       default:
 177         ;
 178       }
 179   return 0;
 180 }
 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   switch (SCM_TYP7 (proc))
 194     {
 195     case scm_tcs_closures:
 196       code = SCM_CLOSURE_BODY (proc);
 197       if (scm_is_null (SCM_CDR (code)))
 198         return SCM_BOOL_F;
 199       code = SCM_CAR (code);
 200       if (scm_is_string (code))
 201         return code;
 202       else
 203         return SCM_BOOL_F;
 204     default:
 205       return SCM_BOOL_F;
 206     }
 207 }
 208 #undef FUNC_NAME
 209
 210
 211 /* Procedure-with-setter
 212  */
 213
 214 SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
 215             (SCM obj),
 216             "Return @code{#t} if @var{obj} is a procedure with an\n"
 217             "associated setter procedure.")
 218 #define FUNC_NAME s_scm_procedure_with_setter_p
 219 {
 220   return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
 221 }
 222 #undef FUNC_NAME
 223
 224 SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
 225             (SCM procedure, SCM setter),
 226             "Create a new procedure which behaves like @var{procedure}, but\n"
 227             "with the associated setter @var{setter}.")
 228 #define FUNC_NAME s_scm_make_procedure_with_setter
 229 {
 230   SCM name, ret;
 231   SCM_VALIDATE_PROC (1, procedure);
 232   SCM_VALIDATE_PROC (2, setter);
 233   ret = scm_double_cell (scm_tc7_pws,
 234                          SCM_UNPACK (procedure),
 235                          SCM_UNPACK (setter), 0);
 236   /* don't use procedure_name, because don't care enough to do a reverse
 237      lookup */
 238   switch (SCM_TYP7 (procedure)) {
 239   case scm_tcs_subrs:
 240     name = SCM_SUBR_NAME (procedure);
 241     break;
 242   default:
 243     name = scm_procedure_property (procedure, scm_sym_name);
 244     break;
 245   }
 246   if (scm_is_true (name))
 247     scm_set_procedure_property_x (ret, scm_sym_name, name);
 248   return ret;
 249 }
 250 #undef FUNC_NAME
 251
 252 SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
 253             (SCM proc),
 254             "Return the procedure of @var{proc}, which must be either a\n"
 255             "procedure with setter, or an operator struct.")
 256 #define FUNC_NAME s_scm_procedure
 257 {
 258   SCM_VALIDATE_NIM (1, proc);
 259   if (SCM_PROCEDURE_WITH_SETTER_P (proc))
 260     return SCM_PROCEDURE (proc);
 261   else if (SCM_STRUCTP (proc))
 262     {
 263       SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
 264       return proc;
 265     }
 266   SCM_WRONG_TYPE_ARG (1, proc);
 267   return SCM_BOOL_F; /* not reached */
 268 }
 269 #undef FUNC_NAME
 270
 271 SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
 272
 273 SCM
 274 scm_setter (SCM proc)
 275 {
 276   SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
 277   if (SCM_PROCEDURE_WITH_SETTER_P (proc))
 278     return SCM_SETTER (proc);
 279   else if (SCM_STRUCTP (proc))
 280     {
 281       SCM setter;
 282       SCM_GASSERT1 (SCM_I_OPERATORP (proc),
 283                     g_setter, proc, SCM_ARG1, s_setter);
 284       setter = (SCM_I_ENTITYP (proc)
 285                 ? SCM_ENTITY_SETTER (proc)
 286                 : SCM_OPERATOR_SETTER (proc));
 287       if (SCM_NIMP (setter))
 288         return setter;
 289       /* fall through */
 290     }
 291   SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
 292   return SCM_BOOL_F; /* not reached */
 293 }
 294
 295 \f
 296 void
 297 scm_init_procs ()
 298 {
 299 #include "libguile/procs.x"
 300 }
 301
 302 /*
 303   Local Variables:
 304   c-file-style: "gnu"
 305   End:
 306 */