libguile/programs.c

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