libguile/programs.c

   1 /* Copyright (C) 2001, 2009, 2010 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 "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 static SCM write_program = SCM_BOOL_F;
  34
  35 SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
  36             (SCM objcode, SCM objtable, SCM free_variables),
  37             "")
  38 #define FUNC_NAME s_scm_make_program
  39 {
  40   SCM_VALIDATE_OBJCODE (1, objcode);
  41   if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
  42     objtable = SCM_BOOL_F;
  43   else if (scm_is_true (objtable))
  44     SCM_VALIDATE_VECTOR (2, objtable);
  45   if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
  46     free_variables = SCM_BOOL_F;
  47   else if (free_variables != SCM_BOOL_F)
  48     SCM_VALIDATE_VECTOR (3, free_variables);
  49
  50   return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode,
  51                           (scm_t_bits)objtable, (scm_t_bits)free_variables);
  52 }
  53 #undef FUNC_NAME
  54
  55 void
  56 scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
  57 {
  58   static int print_error = 0;
  59
  60   if (scm_is_false (write_program) && scm_module_system_booted_p)
  61     write_program = scm_module_local_variable
  62       (scm_c_resolve_module ("system vm program"),
  63        scm_from_locale_symbol ("write-program"));
  64
  65   if (scm_is_false (write_program) || print_error)
  66     {
  67       scm_puts ("#<program ", port);
  68       scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
  69       scm_putc ('>', port);
  70     }
  71   else
  72     {
  73       print_error = 1;
  74       scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
  75       print_error = 0;
  76     }
  77 }
  78
  79 \f
  80 /*
  81  * Scheme interface
  82  */
  83
  84 SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
  85             (SCM obj),
  86             "")
  87 #define FUNC_NAME s_scm_program_p
  88 {
  89   return scm_from_bool (SCM_PROGRAM_P (obj));
  90 }
  91 #undef FUNC_NAME
  92
  93 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
  94             (SCM program),
  95             "")
  96 #define FUNC_NAME s_scm_program_base
  97 {
  98   const struct scm_objcode *c_objcode;
  99
 100   SCM_VALIDATE_PROGRAM (1, program);
 101
 102   c_objcode = SCM_PROGRAM_DATA (program);
 103   return scm_from_ulong ((unsigned long) SCM_C_OBJCODE_BASE (c_objcode));
 104 }
 105 #undef FUNC_NAME
 106
 107 SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
 108             (SCM program),
 109             "")
 110 #define FUNC_NAME s_scm_program_objects
 111 {
 112   SCM_VALIDATE_PROGRAM (1, program);
 113   return SCM_PROGRAM_OBJTABLE (program);
 114 }
 115 #undef FUNC_NAME
 116
 117 SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
 118             (SCM program),
 119             "")
 120 #define FUNC_NAME s_scm_program_module
 121 {
 122   SCM objs;
 123   SCM_VALIDATE_PROGRAM (1, program);
 124   objs = SCM_PROGRAM_OBJTABLE (program);
 125   return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
 126 }
 127 #undef FUNC_NAME
 128
 129 SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 130             (SCM program),
 131             "")
 132 #define FUNC_NAME s_scm_program_meta
 133 {
 134   SCM metaobj;
 135
 136   SCM_VALIDATE_PROGRAM (1, program);
 137
 138   metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
 139   if (scm_is_true (metaobj))
 140     return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
 141                              SCM_BOOL_F);
 142   else
 143     return SCM_BOOL_F;
 144 }
 145 #undef FUNC_NAME
 146
 147 SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
 148             (SCM program),
 149             "")
 150 #define FUNC_NAME s_scm_program_bindings
 151 {
 152   SCM meta;
 153
 154   SCM_VALIDATE_PROGRAM (1, program);
 155
 156   meta = scm_program_meta (program);
 157   if (scm_is_false (meta))
 158     return SCM_BOOL_F;
 159
 160   return scm_car (scm_call_0 (meta));
 161 }
 162 #undef FUNC_NAME
 163
 164 SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
 165             (SCM program),
 166             "")
 167 #define FUNC_NAME s_scm_program_sources
 168 {
 169   SCM meta, sources, ret, filename;
 170
 171   SCM_VALIDATE_PROGRAM (1, program);
 172
 173   meta = scm_program_meta (program);
 174   if (scm_is_false (meta))
 175     return SCM_EOL;
 176
 177   filename = SCM_BOOL_F;
 178   ret = SCM_EOL;
 179   for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
 180        sources = scm_cdr (sources))
 181     {
 182       SCM x = scm_car (sources);
 183       if (scm_is_pair (x))
 184         {
 185           if (scm_is_number (scm_car (x)))
 186             {
 187               SCM addr = scm_car (x);
 188               ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
 189                                ret);
 190             }
 191           else if (scm_is_eq (scm_car (x), scm_sym_filename))
 192             filename = scm_cdr (x);
 193         }
 194     }
 195   return scm_reverse_x (ret, SCM_UNDEFINED);
 196 }
 197 #undef FUNC_NAME
 198
 199 SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
 200             (SCM program),
 201             "")
 202 #define FUNC_NAME s_scm_program_arities
 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_caddr (scm_call_0 (meta));
 213 }
 214 #undef FUNC_NAME
 215
 216 SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
 217             (SCM program),
 218             "")
 219 #define FUNC_NAME s_scm_program_properties
 220 {
 221   SCM meta;
 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   return scm_cdddr (scm_call_0 (meta));
 230 }
 231 #undef FUNC_NAME
 232
 233 SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
 234             (SCM program),
 235             "")
 236 #define FUNC_NAME s_scm_program_name
 237 {
 238   SCM_VALIDATE_PROGRAM (1, program);
 239   return scm_assq_ref (scm_program_properties (program), scm_sym_name);
 240 }
 241 #undef FUNC_NAME
 242
 243 SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
 244             (SCM program, SCM ip),
 245             "")
 246 #define FUNC_NAME s_scm_program_source
 247 {
 248   SCM_VALIDATE_PROGRAM (1, program);
 249   return scm_c_program_source (program, scm_to_size_t (ip));
 250 }
 251 #undef FUNC_NAME
 252
 253 extern SCM
 254 scm_c_program_source (SCM program, size_t ip)
 255 {
 256   SCM sources, source = SCM_BOOL_F;
 257
 258   for (sources = scm_program_sources (program);
 259        !scm_is_null (sources)
 260          && scm_to_size_t (scm_caar (sources)) <= ip;
 261        sources = scm_cdr (sources))
 262     source = scm_car (sources);
 263
 264   return source; /* (addr . (filename . (line . column))) */
 265 }
 266
 267 SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
 268             (SCM program),
 269             "")
 270 #define FUNC_NAME s_scm_program_free_variables
 271 {
 272   SCM_VALIDATE_PROGRAM (1, program);
 273   return SCM_PROGRAM_FREE_VARIABLES (program);
 274 }
 275 #undef FUNC_NAME
 276
 277 SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
 278             (SCM program),
 279             "Return a @var{program}'s object code.")
 280 #define FUNC_NAME s_scm_program_objcode
 281 {
 282   SCM_VALIDATE_PROGRAM (1, program);
 283
 284   return SCM_PROGRAM_OBJCODE (program);
 285 }
 286 #undef FUNC_NAME
 287
 288 /* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
 289    can -- use program-arguments or the like. */
 290 static SCM sym_arglist;
 291 int
 292 scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
 293 {
 294   SCM arities, x;
 295
 296   arities = scm_program_arities (program);
 297   if (!scm_is_pair (arities))
 298     return 0;
 299   /* take the last arglist, it will be least specific */
 300   while (scm_is_pair (scm_cdr (arities)))
 301     arities = scm_cdr (arities);
 302   x = scm_cddar (arities);
 303   if (scm_is_pair (x))
 304     {
 305       *req = scm_to_int (scm_car (x));
 306       x = scm_cdr (x);
 307       if (scm_is_pair (x))
 308         {
 309           *opt = scm_to_int (scm_car (x));
 310           x = scm_cdr (x);
 311           if (scm_is_pair (x))
 312             *rest = scm_is_true (scm_car (x));
 313           else
 314             *rest = 0;
 315         }
 316       else
 317         *opt = *rest = 0;
 318     }
 319   else
 320     *req = *opt = *rest = 0;
 321
 322   return 1;
 323 }
 324
 325 \f
 326
 327 void
 328 scm_bootstrap_programs (void)
 329 {
 330   /* arglist can't be snarfed, because snarfage is only loaded when (system vm
 331      program) is loaded. perhaps static-alloc will fix this. */
 332   sym_arglist = scm_from_locale_symbol ("arglist");
 333   scm_c_register_extension ("libguile", "scm_init_programs",
 334                             (scm_t_extension_init_func)scm_init_programs, NULL);
 335 }
 336
 337 void
 338 scm_init_programs (void)
 339 {
 340 #ifndef SCM_MAGIC_SNARFER
 341 #include "libguile/programs.x"
 342 #endif
 343 }
 344
 345 /*
 346   Local Variables:
 347   c-file-style: "gnu"
 348   End:
 349 */