libguile/programs.c

   1 /* Copyright (C) 2001, 2009 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 License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * 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
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include <string.h>
  24 #include "_scm.h"
  25 #include "vm-bootstrap.h"
  26 #include "instructions.h"
  27 #include "modules.h"
  28 #include "programs.h"
  29 #include "procprop.h" // scm_sym_name
  30 #include "srcprop.h" // scm_sym_filename
  31 #include "vm.h"
  32
  33 \f
  34 scm_t_bits scm_tc16_program;
  35
  36 static SCM write_program = SCM_BOOL_F;
  37
  38 SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
  39             (SCM objcode, SCM objtable, SCM free_variables),
  40             "")
  41 #define FUNC_NAME s_scm_make_program
  42 {
  43   SCM_VALIDATE_OBJCODE (1, objcode);
  44   if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
  45     objtable = SCM_BOOL_F;
  46   else if (scm_is_true (objtable))
  47     SCM_VALIDATE_VECTOR (2, objtable);
  48   if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
  49     free_variables = SCM_BOOL_F;
  50   else if (free_variables != SCM_BOOL_F)
  51     SCM_VALIDATE_VECTOR (3, free_variables);
  52
  53   SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
  54 }
  55 #undef FUNC_NAME
  56
  57 static SCM
  58 program_mark (SCM obj)
  59 {
  60   if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
  61     scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
  62   if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj)))
  63     scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj));
  64   return SCM_PROGRAM_OBJCODE (obj);
  65 }
  66
  67 static SCM
  68 program_apply (SCM program, SCM args)
  69 {
  70   return scm_vm_apply (scm_the_vm (), program, args);
  71 }
  72
  73 static SCM
  74 program_apply_0 (SCM program)
  75 {
  76   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
  77 }
  78
  79 static SCM
  80 program_apply_1 (SCM program, SCM a)
  81 {
  82   return scm_c_vm_run (scm_the_vm (), program, &a, 1);
  83 }
  84
  85 static SCM
  86 program_apply_2 (SCM program, SCM a, SCM b)
  87 {
  88   SCM args[2];
  89   args[0] = a;
  90   args[1] = b;
  91   return scm_c_vm_run (scm_the_vm (), program, args, 2);
  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_list_3 (SCM_I_MAKINUM (p->nargs),
 149                      SCM_I_MAKINUM (p->nrest),
 150                      SCM_I_MAKINUM (p->nlocs));
 151 }
 152 #undef FUNC_NAME
 153
 154 SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
 155             (SCM program),
 156             "")
 157 #define FUNC_NAME s_scm_program_objects
 158 {
 159   SCM_VALIDATE_PROGRAM (1, program);
 160   return SCM_PROGRAM_OBJTABLE (program);
 161 }
 162 #undef FUNC_NAME
 163
 164 SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
 165             (SCM program),
 166             "")
 167 #define FUNC_NAME s_scm_program_module
 168 {
 169   SCM objs;
 170   SCM_VALIDATE_PROGRAM (1, program);
 171   objs = SCM_PROGRAM_OBJTABLE (program);
 172   return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
 173 }
 174 #undef FUNC_NAME
 175
 176 SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 177             (SCM program),
 178             "")
 179 #define FUNC_NAME s_scm_program_meta
 180 {
 181   SCM metaobj;
 182
 183   SCM_VALIDATE_PROGRAM (1, program);
 184
 185   metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
 186   if (scm_is_true (metaobj))
 187     return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F);
 188   else
 189     return SCM_BOOL_F;
 190 }
 191 #undef FUNC_NAME
 192
 193 SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
 194             (SCM program),
 195             "")
 196 #define FUNC_NAME s_scm_program_bindings
 197 {
 198   SCM meta;
 199
 200   SCM_VALIDATE_PROGRAM (1, program);
 201
 202   meta = scm_program_meta (program);
 203   if (scm_is_false (meta))
 204     return SCM_BOOL_F;
 205
 206   return scm_car (scm_call_0 (meta));
 207 }
 208 #undef FUNC_NAME
 209
 210 SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
 211             (SCM program),
 212             "")
 213 #define FUNC_NAME s_scm_program_sources
 214 {
 215   SCM meta, sources, ret, filename;
 216
 217   SCM_VALIDATE_PROGRAM (1, program);
 218
 219   meta = scm_program_meta (program);
 220   if (scm_is_false (meta))
 221     return SCM_EOL;
 222
 223   filename = SCM_BOOL_F;
 224   ret = SCM_EOL;
 225   for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
 226        sources = scm_cdr (sources))
 227     {
 228       SCM x = scm_car (sources);
 229       if (scm_is_pair (x))
 230         {
 231           if (scm_is_number (scm_car (x)))
 232             {
 233               SCM addr = scm_car (x);
 234               ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
 235                                ret);
 236             }
 237           else if (scm_is_eq (scm_car (x), scm_sym_filename))
 238             filename = scm_cdr (x);
 239         }
 240     }
 241   return scm_reverse_x (ret, SCM_UNDEFINED);
 242 }
 243 #undef FUNC_NAME
 244
 245 SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
 246             (SCM program),
 247             "")
 248 #define FUNC_NAME s_scm_program_properties
 249 {
 250   SCM meta;
 251
 252   SCM_VALIDATE_PROGRAM (1, program);
 253
 254   meta = scm_program_meta (program);
 255   if (scm_is_false (meta))
 256     return SCM_EOL;
 257
 258   return scm_cddr (scm_call_0 (meta));
 259 }
 260 #undef FUNC_NAME
 261
 262 SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
 263             (SCM program),
 264             "")
 265 #define FUNC_NAME s_scm_program_name
 266 {
 267   SCM_VALIDATE_PROGRAM (1, program);
 268   return scm_assq_ref (scm_program_properties (program), scm_sym_name);
 269 }
 270 #undef FUNC_NAME
 271
 272 SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
 273             (SCM program, SCM ip),
 274             "")
 275 #define FUNC_NAME s_scm_program_source
 276 {
 277   SCM_VALIDATE_PROGRAM (1, program);
 278   return scm_c_program_source (program, scm_to_size_t (ip));
 279 }
 280 #undef FUNC_NAME
 281
 282 extern SCM
 283 scm_c_program_source (SCM program, size_t ip)
 284 {
 285   SCM sources, source = SCM_BOOL_F;
 286
 287   for (sources = scm_program_sources (program);
 288        !scm_is_null (sources)
 289          && scm_to_size_t (scm_caar (sources)) <= ip;
 290        sources = scm_cdr (sources))
 291     source = scm_car (sources);
 292
 293   return source; /* (addr . (filename . (line . column))) */
 294 }
 295
 296 SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
 297             (SCM program),
 298             "")
 299 #define FUNC_NAME s_scm_program_free_variables
 300 {
 301   SCM_VALIDATE_PROGRAM (1, program);
 302   return SCM_PROGRAM_FREE_VARIABLES (program);
 303 }
 304 #undef FUNC_NAME
 305
 306 SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
 307             (SCM program),
 308             "Return a @var{program}'s object code.")
 309 #define FUNC_NAME s_scm_program_objcode
 310 {
 311   SCM_VALIDATE_PROGRAM (1, program);
 312
 313   return SCM_PROGRAM_OBJCODE (program);
 314 }
 315 #undef FUNC_NAME
 316
 317
 318 \f
 319 void
 320 scm_bootstrap_programs (void)
 321 {
 322   scm_tc16_program = scm_make_smob_type ("program", 0);
 323   scm_set_smob_mark (scm_tc16_program, program_mark);
 324   scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
 325   scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
 326   scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
 327   scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
 328   scm_set_smob_print (scm_tc16_program, program_print);
 329   scm_c_register_extension ("libguile", "scm_init_programs",
 330                             (scm_t_extension_init_func)scm_init_programs, NULL);
 331 }
 332
 333 void
 334 scm_init_programs (void)
 335 {
 336   scm_bootstrap_vm ();
 337
 338 #ifndef SCM_MAGIC_SNARFER
 339 #include "libguile/programs.x"
 340 #endif
 341 }
 342
 343 /*
 344   Local Variables:
 345   c-file-style: "gnu"
 346   End:
 347 */