libguile/programs.c

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