libguile/programs.c

   1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 "modules.h"
  26 #include "programs.h"
  27 #include "procprop.h" /* scm_sym_name */
  28 #include "vm.h"
  29
  30 \f
  31 static SCM write_program = SCM_BOOL_F;
  32
  33 SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0,
  34             (SCM program),
  35             "")
  36 #define FUNC_NAME s_scm_rtl_program_code
  37 {
  38   SCM_VALIDATE_PROGRAM (1, program);
  39
  40   return scm_from_uintptr_t ((scm_t_uintptr) SCM_PROGRAM_CODE (program));
  41 }
  42 #undef FUNC_NAME
  43
  44 SCM
  45 scm_i_program_name (SCM program)
  46 {
  47   static SCM rtl_program_name = SCM_BOOL_F;
  48
  49   if (SCM_PRIMITIVE_P (program))
  50     return SCM_SUBR_NAME (program);
  51
  52   if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
  53     rtl_program_name =
  54         scm_c_private_variable ("system vm program", "rtl-program-name");
  55
  56   return scm_call_1 (scm_variable_ref (rtl_program_name), program);
  57 }
  58
  59 SCM
  60 scm_i_program_documentation (SCM program)
  61 {
  62   static SCM rtl_program_documentation = SCM_BOOL_F;
  63
  64   if (SCM_PRIMITIVE_P (program))
  65     return SCM_BOOL_F;
  66
  67   if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
  68     rtl_program_documentation =
  69       scm_c_private_variable ("system vm program",
  70                               "rtl-program-documentation");
  71
  72   return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
  73 }
  74
  75 SCM
  76 scm_i_program_properties (SCM program)
  77 {
  78   static SCM rtl_program_properties = SCM_BOOL_F;
  79
  80   if (SCM_PRIMITIVE_P (program))
  81     {
  82       SCM name = scm_i_program_name (program);
  83       if (scm_is_false (name))
  84         return SCM_EOL;
  85       return scm_acons (scm_sym_name, name, SCM_EOL);
  86     }
  87
  88   if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
  89     rtl_program_properties =
  90       scm_c_private_variable ("system vm program", "rtl-program-properties");
  91
  92   return scm_call_1 (scm_variable_ref (rtl_program_properties), program);
  93 }
  94
  95 void
  96 scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
  97 {
  98   static int print_error = 0;
  99
 100   if (scm_is_false (write_program) && scm_module_system_booted_p)
 101     write_program = scm_c_private_variable ("system vm program",
 102                                             "write-program");
 103
 104   if (SCM_PROGRAM_IS_CONTINUATION (program))
 105     {
 106       /* twingliness */
 107       scm_puts_unlocked ("#<continuation ", port);
 108       scm_uintprint (SCM_UNPACK (program), 16, port);
 109       scm_putc_unlocked ('>', port);
 110     }
 111   else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
 112     {
 113       /* twingliness */
 114       scm_puts_unlocked ("#<partial-continuation ", port);
 115       scm_uintprint (SCM_UNPACK (program), 16, port);
 116       scm_putc_unlocked ('>', port);
 117     }
 118   else if (scm_is_false (write_program) || print_error)
 119     {
 120       scm_puts_unlocked ("#<rtl-program ", port);
 121       scm_uintprint (SCM_UNPACK (program), 16, port);
 122       scm_putc_unlocked (' ', port);
 123       scm_uintprint ((scm_t_uintptr) SCM_PROGRAM_CODE (program), 16, port);
 124       scm_putc_unlocked ('>', port);
 125     }
 126   else
 127     {
 128       print_error = 1;
 129       scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
 130       print_error = 0;
 131     }
 132 }
 133
 134 \f
 135 /*
 136  * Scheme interface
 137  */
 138
 139 SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 140             (SCM obj),
 141             "")
 142 #define FUNC_NAME s_scm_program_p
 143 {
 144   return scm_from_bool (SCM_PROGRAM_P (obj));
 145 }
 146 #undef FUNC_NAME
 147
 148 SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0,
 149             (SCM obj),
 150             "")
 151 #define FUNC_NAME s_scm_primitive_p
 152 {
 153   return scm_from_bool (SCM_PRIMITIVE_P (obj));
 154 }
 155 #undef FUNC_NAME
 156
 157 SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
 158             (SCM prim),
 159             "")
 160 #define FUNC_NAME s_scm_primitive_p
 161 {
 162   SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
 163
 164   return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
 165 }
 166 #undef FUNC_NAME
 167
 168 SCM
 169 scm_find_source_for_addr (SCM ip)
 170 {
 171   static SCM source_for_addr = SCM_BOOL_F;
 172
 173   if (scm_is_false (source_for_addr)) {
 174     if (!scm_module_system_booted_p)
 175       return SCM_BOOL_F;
 176
 177     source_for_addr =
 178       scm_c_private_variable ("system vm program", "source-for-addr");
 179   }
 180
 181   return scm_call_1 (scm_variable_ref (source_for_addr), ip);
 182 }
 183
 184 SCM
 185 scm_program_source (SCM program, SCM ip, SCM sources)
 186 {
 187   static SCM program_source = SCM_BOOL_F;
 188
 189   if (scm_is_false (program_source)) {
 190     if (!scm_module_system_booted_p)
 191       return SCM_BOOL_F;
 192
 193     program_source =
 194       scm_c_private_variable ("system vm program", "program-source");
 195   }
 196
 197   if (SCM_UNBNDP (sources))
 198     return scm_call_2 (scm_variable_ref (program_source), program, ip);
 199   else
 200     return scm_call_3 (scm_variable_ref (program_source), program, ip, sources);
 201 }
 202
 203 SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
 204             (SCM program),
 205             "")
 206 #define FUNC_NAME s_scm_program_num_free_variables
 207 {
 208   SCM_VALIDATE_PROGRAM (1, program);
 209
 210   return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
 211 }
 212 #undef FUNC_NAME
 213
 214 SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
 215             (SCM program, SCM i),
 216             "")
 217 #define FUNC_NAME s_scm_program_free_variable_ref
 218 {
 219   unsigned long idx;
 220
 221   SCM_VALIDATE_PROGRAM (1, program);
 222   SCM_VALIDATE_ULONG_COPY (2, i, idx);
 223   if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
 224     SCM_OUT_OF_RANGE (2, i);
 225   return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
 226 }
 227 #undef FUNC_NAME
 228
 229 SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
 230             (SCM program, SCM i, SCM x),
 231             "")
 232 #define FUNC_NAME s_scm_program_free_variable_set_x
 233 {
 234   unsigned long idx;
 235
 236   SCM_VALIDATE_PROGRAM (1, program);
 237   SCM_VALIDATE_ULONG_COPY (2, i, idx);
 238   if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
 239     SCM_OUT_OF_RANGE (2, i);
 240   SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
 241   return SCM_UNSPECIFIED;
 242 }
 243 #undef FUNC_NAME
 244
 245 int
 246 scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
 247 {
 248   static SCM rtl_program_minimum_arity = SCM_BOOL_F;
 249   SCM l;
 250
 251   if (SCM_PRIMITIVE_P (program))
 252     return scm_i_primitive_arity (program, req, opt, rest);
 253
 254   if (SCM_PROGRAM_IS_FOREIGN (program))
 255     return scm_i_foreign_arity (program, req, opt, rest);
 256
 257   if (SCM_PROGRAM_IS_CONTINUATION (program)
 258       || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
 259     {
 260       *req = *opt = 0;
 261       *rest = 1;
 262       return 1;
 263     }
 264
 265   if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
 266     rtl_program_minimum_arity =
 267         scm_c_private_variable ("system vm program",
 268                                 "rtl-program-minimum-arity");
 269
 270   l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
 271   if (scm_is_false (l))
 272     return 0;
 273
 274   *req = scm_to_int (scm_car (l));
 275   *opt = scm_to_int (scm_cadr (l));
 276   *rest = scm_is_true (scm_caddr (l));
 277
 278   return 1;
 279 }
 280
 281 \f
 282
 283 void
 284 scm_bootstrap_programs (void)
 285 {
 286   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 287                             "scm_init_programs",
 288                             (scm_t_extension_init_func)scm_init_programs, NULL);
 289 }
 290
 291 void
 292 scm_init_programs (void)
 293 {
 294 #ifndef SCM_MAGIC_SNARFER
 295 #include "libguile/programs.x"
 296 #endif
 297 }
 298
 299 /*
 300   Local Variables:
 301   c-file-style: "gnu"
 302   End:
 303 */