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_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_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
 184             (SCM program),
 185             "")
 186 #define FUNC_NAME s_scm_program_num_free_variables
 187 {
 188   SCM_VALIDATE_PROGRAM (1, program);
 189
 190   return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
 191 }
 192 #undef FUNC_NAME
 193
 194 SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
 195             (SCM program, SCM i),
 196             "")
 197 #define FUNC_NAME s_scm_program_free_variable_ref
 198 {
 199   unsigned long idx;
 200
 201   SCM_VALIDATE_PROGRAM (1, program);
 202   SCM_VALIDATE_ULONG_COPY (2, i, idx);
 203   if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
 204     SCM_OUT_OF_RANGE (2, i);
 205   return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
 206 }
 207 #undef FUNC_NAME
 208
 209 SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
 210             (SCM program, SCM i, SCM x),
 211             "")
 212 #define FUNC_NAME s_scm_program_free_variable_set_x
 213 {
 214   unsigned long idx;
 215
 216   SCM_VALIDATE_PROGRAM (1, program);
 217   SCM_VALIDATE_ULONG_COPY (2, i, idx);
 218   if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
 219     SCM_OUT_OF_RANGE (2, i);
 220   SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
 221   return SCM_UNSPECIFIED;
 222 }
 223 #undef FUNC_NAME
 224
 225 int
 226 scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
 227 {
 228   static SCM program_minimum_arity = SCM_BOOL_F;
 229   SCM l;
 230
 231   if (SCM_PRIMITIVE_P (program))
 232     return scm_i_primitive_arity (program, req, opt, rest);
 233
 234   if (SCM_PROGRAM_IS_FOREIGN (program))
 235     return scm_i_foreign_arity (program, req, opt, rest);
 236
 237   if (SCM_PROGRAM_IS_CONTINUATION (program)
 238       || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
 239     {
 240       *req = *opt = 0;
 241       *rest = 1;
 242       return 1;
 243     }
 244
 245   if (scm_is_false (program_minimum_arity) && scm_module_system_booted_p)
 246     program_minimum_arity =
 247         scm_c_private_variable ("system vm program", "program-minimum-arity");
 248
 249   l = scm_call_1 (scm_variable_ref (program_minimum_arity), program);
 250   if (scm_is_false (l))
 251     return 0;
 252
 253   *req = scm_to_int (scm_car (l));
 254   *opt = scm_to_int (scm_cadr (l));
 255   *rest = scm_is_true (scm_caddr (l));
 256
 257   return 1;
 258 }
 259
 260 \f
 261
 262 void
 263 scm_bootstrap_programs (void)
 264 {
 265   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 266                             "scm_init_programs",
 267                             (scm_t_extension_init_func)scm_init_programs, NULL);
 268 }
 269
 270 void
 271 scm_init_programs (void)
 272 {
 273 #ifndef SCM_MAGIC_SNARFER
 274 #include "libguile/programs.x"
 275 #endif
 276 }
 277
 278 /*
 279   Local Variables:
 280   c-file-style: "gnu"
 281   End:
 282 */