libguile/procs.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45
  46 #include "procs.h"
  47 \f
  48
  49
  50 /* {Procedures}
  51  */
  52
  53
  54 SCM
  55 scm_make_subr_opt (name, type, fcn, set)
  56      char *name;
  57      int type;
  58      SCM (*fcn) ();
  59      int set;
  60 {
  61   SCM symcell;
  62   long tmp;
  63   register SCM z;
  64   symcell = scm_sysintern (name, SCM_UNDEFINED);
  65   tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
  66   if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org))
  67     tmp = 0;
  68   SCM_NEWCELL (z);
  69   SCM_SUBRF (z) = fcn;
  70   SCM_SETCAR (z, tmp + type);
  71   if (set)
  72     SCM_SETCDR (symcell, z);
  73   return z;
  74 }
  75
  76
  77
  78 SCM
  79 scm_make_subr (name, type, fcn)
  80      char *name;
  81      int type;
  82      SCM (*fcn) ();
  83 {
  84   return scm_make_subr_opt (name, type, fcn, 1);
  85 }
  86
  87 #ifdef CCLO
  88
  89 SCM
  90 scm_makcclo (proc, len)
  91      SCM proc;
  92      long len;
  93 {
  94   SCM s;
  95   SCM_NEWCELL (s);
  96   SCM_DEFER_INTS;
  97   SCM_SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure"));
  98   SCM_SETLENGTH (s, len, scm_tc7_cclo);
  99   while (--len)
 100     SCM_VELTS (s)[len] = SCM_UNSPECIFIED;
 101   SCM_CCLO_SUBR (s) = proc;
 102   SCM_ALLOW_INTS;
 103   return s;
 104 }
 105 #endif
 106
 107
 108
 109 SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p);
 110
 111 SCM
 112 scm_procedure_p (obj)
 113      SCM obj;
 114 {
 115   if (SCM_NIMP (obj))
 116     switch (SCM_TYP7 (obj))
 117       {
 118       case scm_tcs_closures:
 119       case scm_tc7_contin:
 120       case scm_tcs_subrs:
 121 #ifdef CCLO
 122       case scm_tc7_cclo:
 123 #endif
 124         return SCM_BOOL_T;
 125       default:
 126         return SCM_BOOL_F;
 127       }
 128   return SCM_BOOL_F;
 129 }
 130
 131 SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p);
 132
 133 SCM
 134 scm_closure_p (obj)
 135      SCM obj;
 136 {
 137   if (SCM_NIMP (obj))
 138     switch (SCM_TYP7 (obj))
 139       {
 140       case scm_tcs_closures:
 141         return SCM_BOOL_T;
 142       default: ;
 143       }
 144   return SCM_BOOL_F;
 145 }
 146
 147 SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p);
 148
 149 #ifdef __STDC__
 150 SCM
 151 scm_thunk_p (SCM obj)
 152 #else
 153 SCM
 154 scm_thunk_p (obj)
 155      SCM obj;
 156 #endif
 157 {
 158   if (SCM_NIMP (obj))
 159     switch (SCM_TYP7 (obj))
 160       {
 161       case scm_tcs_closures:
 162         if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
 163           return SCM_BOOL_T;
 164       case scm_tc7_subr_0:
 165       case scm_tc7_subr_1o:
 166       case scm_tc7_lsubr:
 167       case scm_tc7_rpsubr:
 168       case scm_tc7_asubr:
 169 #ifdef CCLO
 170       case scm_tc7_cclo:
 171 #endif
 172         return SCM_BOOL_T;
 173       default:
 174         ;
 175       }
 176   return SCM_BOOL_F;
 177 }
 178
 179
 180
 181 void
 182 scm_init_iprocs(subra, type)
 183      scm_iproc *subra;
 184      int type;
 185 {
 186   for(;subra->scm_string; subra++)
 187     scm_make_subr(subra->scm_string,
 188                   type,
 189                   subra->cproc);
 190 }
 191
 192
 193
 194
 195
 196 void
 197 scm_init_procs ()
 198 {
 199 #include "procs.x"
 200 }
 201