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 "srcprop.h" // scm_sym_filename
  53 #include "vm.h"
  54
  55 \f
  56 scm_t_bits scm_tc16_program;
  57
  58 static SCM write_program = SCM_BOOL_F;
  59
  60 SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
  61             (SCM objcode, SCM objtable, SCM external),
  62             "")
  63 #define FUNC_NAME s_scm_make_program
  64 {
  65   SCM_VALIDATE_OBJCODE (1, objcode);
  66   if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
  67     objtable = SCM_BOOL_F;
  68   else if (scm_is_true (objtable))
  69     SCM_VALIDATE_VECTOR (2, objtable);
  70   if (SCM_UNLIKELY (SCM_UNBNDP (external)))
  71     external = SCM_EOL;
  72   else
  73     /* FIXME: currently this test is quite expensive (can be 2-3% of total
  74        execution time in programs that make many closures). We could remove it,
  75        yes, but we'd get much better gains if we used some other method, like
  76        just capturing the variables that we need instead of all heap-allocated
  77        variables. Dunno. Keeping the check for now, as it's a user-callable
  78        function, and inlining the op in the vm's make-closure operation. */
  79     SCM_VALIDATE_LIST (3, external);
  80
  81   SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
  82 }
  83 #undef FUNC_NAME
  84
  85 static SCM
  86 program_mark (SCM obj)
  87 {
  88   if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
  89     scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
  90   if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
  91     scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
  92   return SCM_PROGRAM_OBJCODE (obj);
  93 }
  94
  95 static SCM
  96 program_apply (SCM program, SCM args)
  97 {
  98   return scm_vm_apply (scm_the_vm (), program, args);
  99 }
 100
 101 static SCM
 102 program_apply_0 (SCM program)
 103 {
 104   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 105 }
 106
 107 static SCM
 108 program_apply_1 (SCM program, SCM a)
 109 {
 110   return scm_c_vm_run (scm_the_vm (), program, &a, 1);
 111 }
 112
 113 static SCM
 114 program_apply_2 (SCM program, SCM a, SCM b)
 115 {
 116   SCM args[2];
 117   args[0] = a;
 118   args[1] = b;
 119   return scm_c_vm_run (scm_the_vm (), program, args, 2);
 120 }
 121
 122 static int
 123 program_print (SCM program, SCM port, scm_print_state *pstate)
 124 {
 125   static int print_error = 0;
 126
 127   if (SCM_FALSEP (write_program) && scm_module_system_booted_p)
 128     write_program = scm_module_local_variable
 129       (scm_c_resolve_module ("system vm program"),
 130        scm_from_locale_symbol ("write-program"));
 131
 132   if (SCM_FALSEP (write_program) || print_error)
 133     return scm_smob_print (program, port, pstate);
 134
 135   print_error = 1;
 136   scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
 137   print_error = 0;
 138   return 1;
 139 }
 140
 141 \f
 142 /*
 143  * Scheme interface
 144  */
 145
 146 SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 147             (SCM obj),
 148             "")
 149 #define FUNC_NAME s_scm_program_p
 150 {
 151   return SCM_BOOL (SCM_PROGRAM_P (obj));
 152 }
 153 #undef FUNC_NAME
 154
 155 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
 156             (SCM program),
 157             "")
 158 #define FUNC_NAME s_scm_program_base
 159 {
 160   SCM_VALIDATE_PROGRAM (1, program);
 161
 162   return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
 163 }
 164 #undef FUNC_NAME
 165
 166 SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
 167             (SCM program),
 168             "")
 169 #define FUNC_NAME s_scm_program_arity
 170 {
 171   struct scm_objcode *p;
 172
 173   SCM_VALIDATE_PROGRAM (1, program);
 174
 175   p = SCM_PROGRAM_DATA (program);
 176   return scm_list_4 (SCM_I_MAKINUM (p->nargs),
 177                      SCM_I_MAKINUM (p->nrest),
 178                      SCM_I_MAKINUM (p->nlocs),
 179                      SCM_I_MAKINUM (p->nexts));
 180 }
 181 #undef FUNC_NAME
 182
 183 SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
 184             (SCM program),
 185             "")
 186 #define FUNC_NAME s_scm_program_objects
 187 {
 188   SCM_VALIDATE_PROGRAM (1, program);
 189   return SCM_PROGRAM_OBJTABLE (program);
 190 }
 191 #undef FUNC_NAME
 192
 193 SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
 194             (SCM program),
 195             "")
 196 #define FUNC_NAME s_scm_program_module
 197 {
 198   SCM objs;
 199   SCM_VALIDATE_PROGRAM (1, program);
 200   objs = SCM_PROGRAM_OBJTABLE (program);
 201   return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
 202 }
 203 #undef FUNC_NAME
 204
 205 SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 206             (SCM program),
 207             "")
 208 #define FUNC_NAME s_scm_program_meta
 209 {
 210   SCM metaobj;
 211
 212   SCM_VALIDATE_PROGRAM (1, program);
 213
 214   metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
 215   if (scm_is_true (metaobj))
 216     return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
 217   else
 218     return SCM_BOOL_F;
 219 }
 220 #undef FUNC_NAME
 221
 222 SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
 223             (SCM program),
 224             "")
 225 #define FUNC_NAME s_scm_program_bindings
 226 {
 227   SCM meta;
 228
 229   SCM_VALIDATE_PROGRAM (1, program);
 230
 231   meta = scm_program_meta (program);
 232   if (scm_is_false (meta))
 233     return SCM_BOOL_F;
 234
 235   return scm_car (scm_call_0 (meta));
 236 }
 237 #undef FUNC_NAME
 238
 239 SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
 240             (SCM program),
 241             "")
 242 #define FUNC_NAME s_scm_program_sources
 243 {
 244   SCM meta, sources, ret, filename;
 245
 246   SCM_VALIDATE_PROGRAM (1, program);
 247
 248   meta = scm_program_meta (program);
 249   if (scm_is_false (meta))
 250     return SCM_EOL;
 251
 252   filename = SCM_BOOL_F;
 253   ret = SCM_EOL;
 254   for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
 255        sources = scm_cdr (sources))
 256     {
 257       SCM x = scm_car (sources);
 258       if (scm_is_pair (x))
 259         {
 260           if (scm_is_number (scm_car (x)))
 261             {
 262               SCM addr = scm_car (x);
 263               ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
 264                                ret);
 265             }
 266           else if (scm_is_eq (scm_car (x), scm_sym_filename))
 267             filename = scm_cdr (x);
 268         }
 269     }
 270   return scm_reverse_x (ret, SCM_UNDEFINED);
 271 }
 272 #undef FUNC_NAME
 273
 274 SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
 275             (SCM program),
 276             "")
 277 #define FUNC_NAME s_scm_program_properties
 278 {
 279   SCM meta;
 280
 281   SCM_VALIDATE_PROGRAM (1, program);
 282
 283   meta = scm_program_meta (program);
 284   if (scm_is_false (meta))
 285     return SCM_EOL;
 286
 287   return scm_cddr (scm_call_0 (meta));
 288 }
 289 #undef FUNC_NAME
 290
 291 SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
 292             (SCM program),
 293             "")
 294 #define FUNC_NAME s_scm_program_name
 295 {
 296   SCM_VALIDATE_PROGRAM (1, program);
 297   return scm_assq_ref (scm_program_properties (program), scm_sym_name);
 298 }
 299 #undef FUNC_NAME
 300
 301 SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
 302             (SCM program, SCM ip),
 303             "")
 304 #define FUNC_NAME s_scm_program_source
 305 {
 306   SCM_VALIDATE_PROGRAM (1, program);
 307   return scm_c_program_source (program, scm_to_size_t (ip));
 308 }
 309 #undef FUNC_NAME
 310
 311 extern SCM
 312 scm_c_program_source (SCM program, size_t ip)
 313 {
 314   SCM sources, source = SCM_BOOL_F;
 315
 316   for (sources = scm_program_sources (program);
 317        !scm_is_null (sources)
 318          && scm_to_size_t (scm_caar (sources)) <= ip;
 319        sources = scm_cdr (sources))
 320     source = scm_car (sources);
 321
 322   return source; /* (addr . (filename . (line . column))) */
 323 }
 324
 325 SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
 326             (SCM program),
 327             "")
 328 #define FUNC_NAME s_scm_program_external
 329 {
 330   SCM_VALIDATE_PROGRAM (1, program);
 331   return SCM_PROGRAM_EXTERNALS (program);
 332 }
 333 #undef FUNC_NAME
 334
 335 SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
 336             (SCM program, SCM external),
 337             "Modify the list of closure variables of @var{program} (for "
 338             "debugging purposes).")
 339 #define FUNC_NAME s_scm_program_external_set_x
 340 {
 341   SCM_VALIDATE_PROGRAM (1, program);
 342   SCM_VALIDATE_LIST (2, external);
 343   SCM_PROGRAM_EXTERNALS (program) = external;
 344   return SCM_UNSPECIFIED;
 345 }
 346 #undef FUNC_NAME
 347
 348 SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
 349             (SCM program),
 350             "Return a @var{program}'s object code.")
 351 #define FUNC_NAME s_scm_program_objcode
 352 {
 353   SCM_VALIDATE_PROGRAM (1, program);
 354
 355   return SCM_PROGRAM_OBJCODE (program);
 356 }
 357 #undef FUNC_NAME
 358
 359
 360 \f
 361 void
 362 scm_bootstrap_programs (void)
 363 {
 364   scm_tc16_program = scm_make_smob_type ("program", 0);
 365   scm_set_smob_mark (scm_tc16_program, program_mark);
 366   scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
 367   scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
 368   scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
 369   scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
 370   scm_set_smob_print (scm_tc16_program, program_print);
 371   scm_c_register_extension ("libguile", "scm_init_programs",
 372                             (scm_t_extension_init_func)scm_init_programs, NULL);
 373 }
 374
 375 void
 376 scm_init_programs (void)
 377 {
 378   scm_bootstrap_vm ();
 379
 380 #ifndef SCM_MAGIC_SNARFER
 381 #include "libguile/programs.x"
 382 #endif
 383 }
 384
 385 /*
 386   Local Variables:
 387   c-file-style: "gnu"
 388   End:
 389 */