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
 106 /* Undocumented debugging procedure */
 107 #ifdef GUILE_DEBUG
 108 SCM_PROC (s_make_cclo, "make-cclo", 2, 0, 0, scm_make_cclo);
 109
 110 SCM
 111 scm_make_cclo (proc, len)
 112      SCM proc;
 113      SCM len;
 114 {
 115   return scm_makcclo (proc, SCM_INUM (len));
 116 }
 117 #endif
 118 #endif
 119
 120
 121
 122 SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p);
 123
 124 SCM
 125 scm_procedure_p (obj)
 126      SCM obj;
 127 {
 128   if (SCM_NIMP (obj))
 129     switch (SCM_TYP7 (obj))
 130       {
 131       case scm_tcs_closures:
 132       case scm_tc7_contin:
 133       case scm_tcs_subrs:
 134 #ifdef CCLO
 135       case scm_tc7_cclo:
 136 #endif
 137         return SCM_BOOL_T;
 138       default:
 139         return SCM_BOOL_F;
 140       }
 141   return SCM_BOOL_F;
 142 }
 143
 144 SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p);
 145
 146 SCM
 147 scm_closure_p (obj)
 148      SCM obj;
 149 {
 150   if (SCM_NIMP (obj))
 151     switch (SCM_TYP7 (obj))
 152       {
 153       case scm_tcs_closures:
 154         return SCM_BOOL_T;
 155       default: ;
 156       }
 157   return SCM_BOOL_F;
 158 }
 159
 160 SCM_PROC(s_thunk_p, "thunk?", 1, 0, 0, scm_thunk_p);
 161
 162 #ifdef __STDC__
 163 SCM
 164 scm_thunk_p (SCM obj)
 165 #else
 166 SCM
 167 scm_thunk_p (obj)
 168      SCM obj;
 169 #endif
 170 {
 171   if (SCM_NIMP (obj))
 172     switch (SCM_TYP7 (obj))
 173       {
 174       case scm_tcs_closures:
 175         if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
 176           return SCM_BOOL_T;
 177       case scm_tc7_subr_0:
 178       case scm_tc7_subr_1o:
 179       case scm_tc7_lsubr:
 180       case scm_tc7_rpsubr:
 181       case scm_tc7_asubr:
 182 #ifdef CCLO
 183       case scm_tc7_cclo:
 184 #endif
 185         return SCM_BOOL_T;
 186       default:
 187         ;
 188       }
 189   return SCM_BOOL_F;
 190 }
 191
 192
 193
 194 void
 195 scm_init_iprocs(subra, type)
 196      scm_iproc *subra;
 197      int type;
 198 {
 199   for(;subra->scm_string; subra++)
 200     scm_make_subr(subra->scm_string,
 201                   type,
 202                   subra->cproc);
 203 }
 204
 205
 206
 207
 208
 209 void
 210 scm_init_procs ()
 211 {
 212 #include "procs.x"
 213 }
 214