libguile/programs.c

   1 /* Copyright (C) 2001 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, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #if HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <string.h>
  47 #include "vm-bootstrap.h"
  48 #include "instructions.h"
  49 #include "modules.h"
  50 #include "programs.h"
  51 #include "procprop.h" // scm_sym_name
  52 #include "vm.h"
  53
  54 \f
  55 scm_t_bits scm_tc16_program;
  56
  57 static SCM write_program = SCM_BOOL_F;
  58
  59 SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
  60             (SCM objcode, SCM objtable, SCM external),
  61             "")
  62 #define FUNC_NAME s_scm_make_program
  63 {
  64   SCM_VALIDATE_OBJCODE (1, objcode);
  65   if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
  66     objtable = SCM_BOOL_F;
  67   else if (scm_is_true (objtable))
  68     SCM_VALIDATE_VECTOR (2, objtable);
  69   if (SCM_UNLIKELY (SCM_UNBNDP (external)))
  70     external = SCM_EOL;
  71   else
  72     SCM_VALIDATE_LIST (3, external);
  73
  74   SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
  75 }
  76 #undef FUNC_NAME
  77
  78 static SCM
  79 program_mark (SCM obj)
  80 {
  81   if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
  82     scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
  83   if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
  84     scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
  85   return SCM_PROGRAM_OBJCODE (obj);
  86 }
  87
  88 static SCM
  89 program_apply (SCM program, SCM args)
  90 {
  91   return scm_vm_apply (scm_the_vm (), program, args);
  92 }
  93
  94 static int
  95 program_print (SCM program, SCM port, scm_print_state *pstate)
  96 {
  97   static int print_error = 0;
  98
  99   if (SCM_FALSEP (write_program) && scm_module_system_booted_p)
 100     write_program = scm_module_local_variable
 101       (scm_c_resolve_module ("system vm program"),
 102        scm_from_locale_symbol ("write-program"));
 103
 104   if (SCM_FALSEP (write_program) || print_error)
 105     return scm_smob_print (program, port, pstate);
 106
 107   print_error = 1;
 108   scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
 109   print_error = 0;
 110   return 1;
 111 }
 112
 113 \f
 114 /*
 115  * Scheme interface
 116  */
 117
 118 SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 119             (SCM obj),
 120             "")
 121 #define FUNC_NAME s_scm_program_p
 122 {
 123   return SCM_BOOL (SCM_PROGRAM_P (obj));
 124 }
 125 #undef FUNC_NAME
 126
 127 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
 128             (SCM program),
 129             "")
 130 #define FUNC_NAME s_scm_program_base
 131 {
 132   SCM_VALIDATE_PROGRAM (1, program);
 133
 134   return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
 135 }
 136 #undef FUNC_NAME
 137
 138 SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
 139             (SCM program),
 140             "")
 141 #define FUNC_NAME s_scm_program_arity
 142 {
 143   struct scm_objcode *p;
 144
 145   SCM_VALIDATE_PROGRAM (1, program);
 146
 147   p = SCM_PROGRAM_DATA (program);
 148   return SCM_LIST4 (SCM_I_MAKINUM (p->nargs),
 149                     SCM_I_MAKINUM (p->nrest),
 150                     SCM_I_MAKINUM (p->nlocs),
 151                     SCM_I_MAKINUM (p->nexts));
 152 }
 153 #undef FUNC_NAME
 154
 155 SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
 156             (SCM program),
 157             "")
 158 #define FUNC_NAME s_scm_program_objects
 159 {
 160   SCM_VALIDATE_PROGRAM (1, program);
 161   return SCM_PROGRAM_OBJTABLE (program);
 162 }
 163 #undef FUNC_NAME
 164
 165 SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
 166             (SCM program),
 167             "")
 168 #define FUNC_NAME s_scm_program_module
 169 {
 170   SCM objs;
 171   SCM_VALIDATE_PROGRAM (1, program);
 172   objs = SCM_PROGRAM_OBJTABLE (program);
 173   return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
 174 }
 175 #undef FUNC_NAME
 176
 177 SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 178             (SCM program),
 179             "")
 180 #define FUNC_NAME s_scm_program_meta
 181 {
 182   SCM metaobj;
 183
 184   SCM_VALIDATE_PROGRAM (1, program);
 185
 186   metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
 187   if (scm_is_true (metaobj))
 188     return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
 189   else
 190     return SCM_BOOL_F;
 191 }
 192 #undef FUNC_NAME
 193
 194 SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
 195             (SCM program),
 196             "")
 197 #define FUNC_NAME s_scm_program_bindings
 198 {
 199   SCM meta;
 200
 201   SCM_VALIDATE_PROGRAM (1, program);
 202
 203   meta = scm_program_meta (program);
 204   if (scm_is_false (meta))
 205     return SCM_BOOL_F;
 206
 207   return scm_car (scm_call_0 (meta));
 208 }
 209 #undef FUNC_NAME
 210
 211 SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
 212             (SCM program),
 213             "")
 214 #define FUNC_NAME s_scm_program_sources
 215 {
 216   SCM meta;
 217
 218   SCM_VALIDATE_PROGRAM (1, program);
 219
 220   meta = scm_program_meta (program);
 221   if (scm_is_false (meta))
 222     return SCM_EOL;
 223
 224   return scm_cadr (scm_call_0 (meta));
 225 }
 226 #undef FUNC_NAME
 227
 228 SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
 229             (SCM program),
 230             "")
 231 #define FUNC_NAME s_scm_program_properties
 232 {
 233   SCM meta;
 234
 235   SCM_VALIDATE_PROGRAM (1, program);
 236
 237   meta = scm_program_meta (program);
 238   if (scm_is_false (meta))
 239     return SCM_EOL;
 240
 241   return scm_cddr (scm_call_0 (meta));
 242 }
 243 #undef FUNC_NAME
 244
 245 SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
 246             (SCM program),
 247             "")
 248 #define FUNC_NAME s_scm_program_name
 249 {
 250   SCM_VALIDATE_PROGRAM (1, program);
 251   return scm_assq_ref (scm_program_properties (program), scm_sym_name);
 252 }
 253 #undef FUNC_NAME
 254
 255 extern SCM
 256 scm_c_program_source (SCM program, size_t ip)
 257 {
 258   SCM sources, source;
 259
 260   sources = scm_program_sources (program);
 261   source = scm_assv (scm_from_size_t (ip), sources);
 262   if (scm_is_false (source))
 263     return SCM_BOOL_F;
 264
 265   return scm_cdr (source); /* a #(line column file) vector */
 266 }
 267
 268 SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
 269             (SCM program),
 270             "")
 271 #define FUNC_NAME s_scm_program_external
 272 {
 273   SCM_VALIDATE_PROGRAM (1, program);
 274   return SCM_PROGRAM_EXTERNALS (program);
 275 }
 276 #undef FUNC_NAME
 277
 278 SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
 279             (SCM program, SCM external),
 280             "Modify the list of closure variables of @var{program} (for "
 281             "debugging purposes).")
 282 #define FUNC_NAME s_scm_program_external_set_x
 283 {
 284   SCM_VALIDATE_PROGRAM (1, program);
 285   SCM_VALIDATE_LIST (2, external);
 286   SCM_PROGRAM_EXTERNALS (program) = external;
 287   return SCM_UNSPECIFIED;
 288 }
 289 #undef FUNC_NAME
 290
 291 SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
 292             (SCM program),
 293             "Return a @var{program}'s object code.")
 294 #define FUNC_NAME s_scm_program_objcode
 295 {
 296   SCM_VALIDATE_PROGRAM (1, program);
 297
 298   return SCM_PROGRAM_OBJCODE (program);
 299 }
 300 #undef FUNC_NAME
 301
 302
 303 \f
 304 void
 305 scm_bootstrap_programs (void)
 306 {
 307   scm_tc16_program = scm_make_smob_type ("program", 0);
 308   scm_set_smob_mark (scm_tc16_program, program_mark);
 309   scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
 310   scm_set_smob_print (scm_tc16_program, program_print);
 311 }
 312
 313 void
 314 scm_init_programs (void)
 315 {
 316   scm_bootstrap_vm ();
 317
 318 #ifndef SCM_MAGIC_SNARFER
 319 #include "programs.x"
 320 #endif
 321 }
 322
 323 /*
 324   Local Variables:
 325   c-file-style: "gnu"
 326   End:
 327 */