libguile/procs.c

   1 /* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008 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/objects.h"
  27 #include "libguile/strings.h"
  28 #include "libguile/vectors.h"
  29 #include "libguile/smob.h"
  30 #include "libguile/deprecation.h"
  31
  32 #include "libguile/validate.h"
  33 #include "libguile/procs.h"
  34 \f
  35
  36
  37 /* {Procedures}
  38  */
  39
  40 scm_t_subr_entry *scm_subr_table;
  41
  42 /* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */
  43
  44 /* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on
  45    startup, 786 with guile-readline.  'martin */
  46
  47 long scm_subr_table_size = 0;
  48 long scm_subr_table_room = 800;
  49
  50 SCM
  51 scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
  52 {
  53   register SCM z;
  54   long entry;
  55
  56   if (scm_subr_table_size == scm_subr_table_room)
  57     {
  58       long new_size = scm_subr_table_room * 3 / 2;
  59       void *new_table
  60         = scm_realloc ((char *) scm_subr_table,
  61                        sizeof (scm_t_subr_entry) * new_size);
  62       scm_subr_table = new_table;
  63       scm_subr_table_room = new_size;
  64     }
  65
  66   entry = scm_subr_table_size;
  67   z = scm_immutable_cell ((entry << 8) + type, (scm_t_bits) fcn);
  68   scm_subr_table[entry].handle = z;
  69   scm_subr_table[entry].name = scm_from_locale_symbol (name);
  70   scm_subr_table[entry].generic = 0;
  71   scm_subr_table[entry].properties = SCM_EOL;
  72   scm_subr_table_size++;
  73
  74   return z;
  75 }
  76
  77 SCM
  78 scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
  79 {
  80   SCM subr = scm_c_make_subr (name, type, fcn);
  81   scm_define (SCM_SUBR_ENTRY(subr).name, subr);
  82   return subr;
  83 }
  84
  85 SCM
  86 scm_c_make_subr_with_generic (const char *name,
  87                               long type, SCM (*fcn) (), SCM *gf)
  88 {
  89   SCM subr = scm_c_make_subr (name, type, fcn);
  90   SCM_SUBR_ENTRY(subr).generic = gf;
  91   return subr;
  92 }
  93
  94 SCM
  95 scm_c_define_subr_with_generic (const char *name,
  96                                 long type, SCM (*fcn) (), SCM *gf)
  97 {
  98   SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
  99   scm_define (SCM_SUBR_ENTRY(subr).name, subr);
 100   return subr;
 101 }
 102
 103
 104 #ifdef CCLO
 105 SCM
 106 scm_makcclo (SCM proc, size_t len)
 107 {
 108   scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits),
 109                                     "compiled closure");
 110   unsigned long i;
 111   SCM s;
 112
 113   for (i = 0; i < len; ++i)
 114     base [i] = SCM_UNPACK (SCM_UNSPECIFIED);
 115
 116   s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base);
 117   SCM_SET_CCLO_SUBR (s, proc);
 118   return s;
 119 }
 120
 121 /* Undocumented debugging procedure */
 122 #ifdef GUILE_DEBUG
 123 SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0,
 124             (SCM proc, SCM len),
 125             "Create a compiled closure for @var{proc}, which reserves\n"
 126             "@var{len} objects for its usage.")
 127 #define FUNC_NAME s_scm_make_cclo
 128 {
 129   return scm_makcclo (proc, scm_to_size_t (len));
 130 }
 131 #undef FUNC_NAME
 132 #endif
 133 #endif
 134
 135
 136
 137 SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
 138             (SCM obj),
 139             "Return @code{#t} if @var{obj} is a procedure.")
 140 #define FUNC_NAME s_scm_procedure_p
 141 {
 142   if (SCM_NIMP (obj))
 143     switch (SCM_TYP7 (obj))
 144       {
 145       case scm_tcs_struct:
 146         if (!SCM_I_OPERATORP (obj))
 147           break;
 148       case scm_tcs_closures:
 149       case scm_tcs_subrs:
 150 #ifdef CCLO
 151       case scm_tc7_cclo:
 152 #endif
 153       case scm_tc7_pws:
 154         return SCM_BOOL_T;
 155       case scm_tc7_smob:
 156         return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
 157       default:
 158         return SCM_BOOL_F;
 159       }
 160   return SCM_BOOL_F;
 161 }
 162 #undef FUNC_NAME
 163
 164 SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
 165            (SCM obj),
 166             "Return @code{#t} if @var{obj} is a closure.")
 167 #define FUNC_NAME s_scm_closure_p
 168 {
 169   return scm_from_bool (SCM_CLOSUREP (obj));
 170 }
 171 #undef FUNC_NAME
 172
 173 SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
 174             (SCM obj),
 175             "Return @code{#t} if @var{obj} is a thunk.")
 176 #define FUNC_NAME s_scm_thunk_p
 177 {
 178   if (SCM_NIMP (obj))
 179     {
 180     again:
 181       switch (SCM_TYP7 (obj))
 182         {
 183         case scm_tcs_closures:
 184           return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
 185         case scm_tc7_subr_0:
 186         case scm_tc7_subr_1o:
 187         case scm_tc7_lsubr:
 188         case scm_tc7_rpsubr:
 189         case scm_tc7_asubr:
 190 #ifdef CCLO
 191         case scm_tc7_cclo:
 192 #endif
 193           return SCM_BOOL_T;
 194         case scm_tc7_pws:
 195           obj = SCM_PROCEDURE (obj);
 196           goto again;
 197         default:
 198           ;
 199         }
 200     }
 201   return SCM_BOOL_F;
 202 }
 203 #undef FUNC_NAME
 204
 205 /* Only used internally. */
 206 int
 207 scm_subr_p (SCM obj)
 208 {
 209   if (SCM_NIMP (obj))
 210     switch (SCM_TYP7 (obj))
 211       {
 212       case scm_tcs_subrs:
 213         return 1;
 214       default:
 215         ;
 216       }
 217   return 0;
 218 }
 219
 220 SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
 221            (SCM proc),
 222             "Return the documentation string associated with @code{proc}.  By\n"
 223             "convention, if a procedure contains more than one expression and the\n"
 224             "first expression is a string constant, that string is assumed to contain\n"
 225             "documentation for that procedure.")
 226 #define FUNC_NAME s_scm_procedure_documentation
 227 {
 228   SCM code;
 229   SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
 230               proc, SCM_ARG1, FUNC_NAME);
 231   switch (SCM_TYP7 (proc))
 232     {
 233     case scm_tcs_closures:
 234       code = SCM_CLOSURE_BODY (proc);
 235       if (scm_is_null (SCM_CDR (code)))
 236         return SCM_BOOL_F;
 237       code = SCM_CAR (code);
 238       if (scm_is_string (code))
 239         return code;
 240       else
 241         return SCM_BOOL_F;
 242     default:
 243       return SCM_BOOL_F;
 244 /*
 245   case scm_tcs_subrs:
 246 #ifdef CCLO
 247   case scm_tc7_cclo:
 248 #endif
 249 */
 250     }
 251 }
 252 #undef FUNC_NAME
 253
 254
 255 /* Procedure-with-setter
 256  */
 257
 258 SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
 259             (SCM obj),
 260             "Return @code{#t} if @var{obj} is a procedure with an\n"
 261             "associated setter procedure.")
 262 #define FUNC_NAME s_scm_procedure_with_setter_p
 263 {
 264   return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
 265 }
 266 #undef FUNC_NAME
 267
 268 SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
 269             (SCM procedure, SCM setter),
 270             "Create a new procedure which behaves like @var{procedure}, but\n"
 271             "with the associated setter @var{setter}.")
 272 #define FUNC_NAME s_scm_make_procedure_with_setter
 273 {
 274   SCM_VALIDATE_PROC (1, procedure);
 275   SCM_VALIDATE_PROC (2, setter);
 276   return scm_double_cell (scm_tc7_pws,
 277                           SCM_UNPACK (procedure),
 278                           SCM_UNPACK (setter), 0);
 279 }
 280 #undef FUNC_NAME
 281
 282 SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
 283             (SCM proc),
 284             "Return the procedure of @var{proc}, which must be either a\n"
 285             "procedure with setter, or an operator struct.")
 286 #define FUNC_NAME s_scm_procedure
 287 {
 288   SCM_VALIDATE_NIM (1, proc);
 289   if (SCM_PROCEDURE_WITH_SETTER_P (proc))
 290     return SCM_PROCEDURE (proc);
 291   else if (SCM_STRUCTP (proc))
 292     {
 293       SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
 294       return proc;
 295     }
 296   SCM_WRONG_TYPE_ARG (1, proc);
 297   return SCM_BOOL_F; /* not reached */
 298 }
 299 #undef FUNC_NAME
 300
 301 SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
 302
 303 SCM
 304 scm_setter (SCM proc)
 305 {
 306   SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
 307   if (SCM_PROCEDURE_WITH_SETTER_P (proc))
 308     return SCM_SETTER (proc);
 309   else if (SCM_STRUCTP (proc))
 310     {
 311       SCM setter;
 312       SCM_GASSERT1 (SCM_I_OPERATORP (proc),
 313                     g_setter, proc, SCM_ARG1, s_setter);
 314       setter = (SCM_I_ENTITYP (proc)
 315                 ? SCM_ENTITY_SETTER (proc)
 316                 : SCM_OPERATOR_SETTER (proc));
 317       if (SCM_NIMP (setter))
 318         return setter;
 319       /* fall through */
 320     }
 321   SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
 322   return SCM_BOOL_F; /* not reached */
 323 }
 324
 325
 326 void
 327 scm_init_subr_table ()
 328 {
 329   scm_subr_table
 330     = ((scm_t_subr_entry *)
 331        scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room));
 332 }
 333
 334 void
 335 scm_init_procs ()
 336 {
 337 #include "libguile/procs.x"
 338 }
 339
 340 /*
 341   Local Variables:
 342   c-file-style: "gnu"
 343   End:
 344 */