libguile/procs.c

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