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 "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
  46   if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
  47     {
  48       SCM ret = scm_words (scm_tc7_program, 3);
  49       SCM_SET_CELL_OBJECT_1 (ret, objcode);
  50       SCM_SET_CELL_OBJECT_2 (ret, objtable);
  51       return ret;
  52     }
  53   else
  54     {
  55       size_t i, len;
  56       SCM ret;
  57       SCM_VALIDATE_VECTOR (3, free_variables);
  58       len = scm_c_vector_length (free_variables);
  59       if (SCM_UNLIKELY (len >> 16))
  60         SCM_OUT_OF_RANGE (3, free_variables);
  61       ret = scm_words (scm_tc7_program | (len<<16), 3 + len);
  62       SCM_SET_CELL_OBJECT_1 (ret, objcode);
  63       SCM_SET_CELL_OBJECT_2 (ret, objtable);
  64       for (i = 0; i < len; i++)
  65         SCM_SET_CELL_OBJECT (ret, 3+i,
  66                              SCM_SIMPLE_VECTOR_REF (free_variables, i));
  67       return ret;
  68     }
  69 }
  70 #undef FUNC_NAME
  71
  72 SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2, 0,
  73             (SCM bytevector, SCM byte_offset, SCM free_variables),
  74             "")
  75 #define FUNC_NAME s_scm_make_rtl_program
  76 {
  77   scm_t_uint8 *code;
  78   scm_t_uint32 offset;
  79
  80   if (!scm_is_bytevector (bytevector))
  81     scm_wrong_type_arg (FUNC_NAME, 1, bytevector);
  82   if (SCM_UNBNDP (byte_offset))
  83     offset = 0;
  84   else
  85     {
  86       offset = scm_to_uint32 (byte_offset);
  87       if (offset > SCM_BYTEVECTOR_LENGTH (bytevector))
  88         SCM_OUT_OF_RANGE (2, byte_offset);
  89     }
  90
  91   code = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bytevector) + offset;
  92   if (((scm_t_uintptr) code) % 4)
  93     SCM_OUT_OF_RANGE (2, byte_offset);
  94
  95   if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
  96     return scm_cell (scm_tc7_rtl_program, (scm_t_bits) code);
  97   else
  98     abort ();
  99 }
 100 #undef FUNC_NAME
 101
 102 SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0,
 103             (SCM program),
 104             "")
 105 #define FUNC_NAME s_scm_rtl_program_code
 106 {
 107   SCM_VALIDATE_RTL_PROGRAM (1, program);
 108
 109   /* FIXME: we need scm_from_uintptr ().  */
 110   return scm_from_size_t ((size_t) SCM_RTL_PROGRAM_CODE (program));
 111 }
 112 #undef FUNC_NAME
 113
 114 SCM
 115 scm_i_rtl_program_name (SCM program)
 116 {
 117   static SCM rtl_program_name = SCM_BOOL_F;
 118
 119   if (scm_is_false (rtl_program_name) && scm_module_system_booted_p)
 120     rtl_program_name =
 121         scm_c_private_variable ("system vm program", "rtl-program-name");
 122
 123   return scm_call_1 (scm_variable_ref (rtl_program_name), program);
 124 }
 125
 126 SCM
 127 scm_i_rtl_program_documentation (SCM program)
 128 {
 129   static SCM rtl_program_documentation = SCM_BOOL_F;
 130
 131   if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
 132     rtl_program_documentation =
 133       scm_c_private_variable ("system vm program",
 134                               "rtl-program-documentation");
 135
 136   return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
 137 }
 138
 139 SCM
 140 scm_i_rtl_program_properties (SCM program)
 141 {
 142   static SCM rtl_program_properties = SCM_BOOL_F;
 143
 144   if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p)
 145     rtl_program_properties =
 146       scm_c_private_variable ("system vm program", "rtl-program-properties");
 147
 148   return scm_call_1 (scm_variable_ref (rtl_program_properties), program);
 149 }
 150
 151 void
 152 scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
 153 {
 154   static int print_error = 0;
 155
 156   if (scm_is_false (write_program) && scm_module_system_booted_p)
 157     write_program = scm_c_private_variable ("system vm program",
 158                                             "write-program");
 159
 160   if (SCM_PROGRAM_IS_CONTINUATION (program))
 161     {
 162       /* twingliness */
 163       scm_puts_unlocked ("#<continuation ", port);
 164       scm_uintprint (SCM_UNPACK (program), 16, port);
 165       scm_putc_unlocked ('>', port);
 166     }
 167   else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
 168     {
 169       /* twingliness */
 170       scm_puts_unlocked ("#<partial-continuation ", port);
 171       scm_uintprint (SCM_UNPACK (program), 16, port);
 172       scm_putc_unlocked ('>', port);
 173     }
 174   else if (scm_is_false (write_program) || print_error)
 175     {
 176       if (SCM_RTL_PROGRAM_P (program))
 177         {
 178           scm_puts_unlocked ("#<rtl-program ", port);
 179           scm_uintprint (SCM_UNPACK (program), 16, port);
 180           scm_putc_unlocked (' ', port);
 181           scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
 182           scm_putc_unlocked ('>', port);
 183         }
 184       else
 185         {
 186           scm_puts_unlocked ("#<program ", port);
 187           scm_uintprint (SCM_UNPACK (program), 16, port);
 188           scm_putc_unlocked ('>', port);
 189         }
 190     }
 191   else
 192     {
 193       print_error = 1;
 194       scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
 195       print_error = 0;
 196     }
 197 }
 198
 199 \f
 200 /*
 201  * Scheme interface
 202  */
 203
 204 SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 205             (SCM obj),
 206             "")
 207 #define FUNC_NAME s_scm_program_p
 208 {
 209   return scm_from_bool (SCM_PROGRAM_P (obj));
 210 }
 211 #undef FUNC_NAME
 212
 213 SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
 214             (SCM obj),
 215             "")
 216 #define FUNC_NAME s_scm_rtl_program_p
 217 {
 218   return scm_from_bool (SCM_RTL_PROGRAM_P (obj));
 219 }
 220 #undef FUNC_NAME
 221
 222 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
 223             (SCM program),
 224             "")
 225 #define FUNC_NAME s_scm_program_base
 226 {
 227   const struct scm_objcode *c_objcode;
 228
 229   SCM_VALIDATE_PROGRAM (1, program);
 230
 231   c_objcode = SCM_PROGRAM_DATA (program);
 232   return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode));
 233 }
 234 #undef FUNC_NAME
 235
 236 SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
 237             (SCM program),
 238             "")
 239 #define FUNC_NAME s_scm_program_objects
 240 {
 241   SCM_VALIDATE_PROGRAM (1, program);
 242   return SCM_PROGRAM_OBJTABLE (program);
 243 }
 244 #undef FUNC_NAME
 245
 246 SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
 247             (SCM program),
 248             "")
 249 #define FUNC_NAME s_scm_program_module
 250 {
 251   SCM objs, mod;
 252   SCM_VALIDATE_PROGRAM (1, program);
 253   objs = SCM_PROGRAM_OBJTABLE (program);
 254   /* If a program is the result of compiling GLIL to assembly, then if
 255      it has an objtable, the first entry will be a module.  But some
 256      programs are hand-coded trampolines, like boot programs and
 257      primitives and the like.  So if a program happens to have a
 258      non-module in the first slot of the objtable, assume that it is
 259      such a trampoline, and just return #f for the module.  */
 260   mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
 261   return SCM_MODULEP (mod) ? mod : SCM_BOOL_F;
 262 }
 263 #undef FUNC_NAME
 264
 265 SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
 266             (SCM program),
 267             "")
 268 #define FUNC_NAME s_scm_program_meta
 269 {
 270   SCM metaobj;
 271
 272   SCM_VALIDATE_PROGRAM (1, program);
 273
 274   metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
 275   if (scm_is_true (metaobj))
 276     return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
 277                              SCM_BOOL_F);
 278   else
 279     return SCM_BOOL_F;
 280 }
 281 #undef FUNC_NAME
 282
 283 SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
 284             (SCM program),
 285             "")
 286 #define FUNC_NAME s_scm_program_bindings
 287 {
 288   SCM meta;
 289
 290   SCM_VALIDATE_PROGRAM (1, program);
 291
 292   meta = scm_program_meta (program);
 293   if (scm_is_false (meta))
 294     return SCM_BOOL_F;
 295
 296   return scm_car (scm_call_0 (meta));
 297 }
 298 #undef FUNC_NAME
 299
 300 SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
 301             (SCM program),
 302             "")
 303 #define FUNC_NAME s_scm_program_sources
 304 {
 305   SCM meta, sources, ret, filename;
 306
 307   SCM_VALIDATE_PROGRAM (1, program);
 308
 309   meta = scm_program_meta (program);
 310   if (scm_is_false (meta))
 311     return SCM_EOL;
 312
 313   filename = SCM_BOOL_F;
 314   ret = SCM_EOL;
 315   for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
 316        sources = scm_cdr (sources))
 317     {
 318       SCM x = scm_car (sources);
 319       if (scm_is_pair (x))
 320         {
 321           if (scm_is_number (scm_car (x)))
 322             {
 323               SCM addr = scm_car (x);
 324               ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
 325                                ret);
 326             }
 327           else if (scm_is_eq (scm_car (x), scm_sym_filename))
 328             filename = scm_cdr (x);
 329         }
 330     }
 331   return scm_reverse_x (ret, SCM_UNDEFINED);
 332 }
 333 #undef FUNC_NAME
 334
 335 SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
 336             (SCM program),
 337             "")
 338 #define FUNC_NAME s_scm_program_arities
 339 {
 340   SCM meta;
 341
 342   SCM_VALIDATE_PROGRAM (1, program);
 343
 344   meta = scm_program_meta (program);
 345   if (scm_is_false (meta))
 346     return SCM_BOOL_F;
 347
 348   return scm_caddr (scm_call_0 (meta));
 349 }
 350 #undef FUNC_NAME
 351
 352 SCM
 353 scm_i_program_properties (SCM program)
 354 #define FUNC_NAME "%program-properties"
 355 {
 356   SCM meta;
 357
 358   SCM_VALIDATE_PROGRAM (1, program);
 359
 360   meta = scm_program_meta (program);
 361   if (scm_is_false (meta))
 362     return SCM_EOL;
 363
 364   return scm_cdddr (scm_call_0 (meta));
 365 }
 366 #undef FUNC_NAME
 367
 368 static SCM
 369 program_source (SCM program, size_t ip, SCM sources)
 370 {
 371   SCM source = SCM_BOOL_F;
 372
 373   while (!scm_is_null (sources)
 374          && scm_to_size_t (scm_caar (sources)) <= ip)
 375     {
 376       source = scm_car (sources);
 377       sources = scm_cdr (sources);
 378     }
 379
 380   return source; /* (addr . (filename . (line . column))) */
 381 }
 382
 383 SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0,
 384             (SCM program, SCM ip, SCM sources),
 385             "")
 386 #define FUNC_NAME s_scm_program_source
 387 {
 388   SCM_VALIDATE_PROGRAM (1, program);
 389   if (SCM_UNBNDP (sources))
 390     sources = scm_program_sources (program);
 391   return program_source (program, scm_to_size_t (ip), sources);
 392 }
 393 #undef FUNC_NAME
 394
 395 extern SCM
 396 scm_c_program_source (SCM program, size_t ip)
 397 {
 398   return program_source (program, ip, scm_program_sources (program));
 399 }
 400
 401 SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
 402             (SCM program),
 403             "")
 404 #define FUNC_NAME s_scm_program_num_free_variables
 405 {
 406   if (SCM_RTL_PROGRAM_P (program)) {
 407     return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program));
 408   }
 409
 410   SCM_VALIDATE_PROGRAM (1, program);
 411   return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
 412 }
 413 #undef FUNC_NAME
 414
 415 SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
 416             (SCM program, SCM i),
 417             "")
 418 #define FUNC_NAME s_scm_program_free_variable_ref
 419 {
 420   unsigned long idx;
 421
 422   if (SCM_RTL_PROGRAM_P (program)) {
 423     SCM_VALIDATE_ULONG_COPY (2, i, idx);
 424     if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
 425       SCM_OUT_OF_RANGE (2, i);
 426     return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx);
 427   }
 428
 429   SCM_VALIDATE_PROGRAM (1, program);
 430   SCM_VALIDATE_ULONG_COPY (2, i, idx);
 431   if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
 432     SCM_OUT_OF_RANGE (2, i);
 433   return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
 434 }
 435 #undef FUNC_NAME
 436
 437 SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
 438             (SCM program, SCM i, SCM x),
 439             "")
 440 #define FUNC_NAME s_scm_program_free_variable_set_x
 441 {
 442   unsigned long idx;
 443
 444   if (SCM_RTL_PROGRAM_P (program)) {
 445     SCM_VALIDATE_ULONG_COPY (2, i, idx);
 446     if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program))
 447       SCM_OUT_OF_RANGE (2, i);
 448     SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
 449     return SCM_UNSPECIFIED;
 450   }
 451
 452   SCM_VALIDATE_PROGRAM (1, program);
 453   SCM_VALIDATE_ULONG_COPY (2, i, idx);
 454   if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
 455     SCM_OUT_OF_RANGE (2, i);
 456   SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
 457   return SCM_UNSPECIFIED;
 458 }
 459 #undef FUNC_NAME
 460
 461 SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
 462             (SCM program),
 463             "Return a @var{program}'s object code.")
 464 #define FUNC_NAME s_scm_program_objcode
 465 {
 466   SCM_VALIDATE_PROGRAM (1, program);
 467
 468   return SCM_PROGRAM_OBJCODE (program);
 469 }
 470 #undef FUNC_NAME
 471
 472 /* procedure-minimum-arity support. */
 473 static void
 474 parse_arity (SCM arity, int *req, int *opt, int *rest)
 475 {
 476   SCM x = scm_cddr (arity);
 477
 478   if (scm_is_pair (x))
 479     {
 480       *req = scm_to_int (scm_car (x));
 481       x = scm_cdr (x);
 482       if (scm_is_pair (x))
 483         {
 484           *opt = scm_to_int (scm_car (x));
 485           x = scm_cdr (x);
 486           if (scm_is_pair (x))
 487             *rest = scm_is_true (scm_car (x));
 488           else
 489             *rest = 0;
 490         }
 491       else
 492         *opt = *rest = 0;
 493     }
 494   else
 495     *req = *opt = *rest = 0;
 496 }
 497
 498 static int
 499 scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest)
 500 {
 501   static SCM rtl_program_minimum_arity = SCM_BOOL_F;
 502   SCM l;
 503
 504   if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p)
 505     rtl_program_minimum_arity =
 506         scm_c_private_variable ("system vm program",
 507                                 "rtl-program-minimum-arity");
 508
 509   l = scm_call_1 (scm_variable_ref (rtl_program_minimum_arity), program);
 510   if (scm_is_false (l))
 511     return 0;
 512
 513   *req = scm_to_int (scm_car (l));
 514   *opt = scm_to_int (scm_cadr (l));
 515   *rest = scm_is_true (scm_caddr (l));
 516
 517   return 1;
 518 }
 519
 520 int
 521 scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
 522 {
 523   SCM arities;
 524
 525   if (SCM_RTL_PROGRAM_P (program))
 526     return scm_i_rtl_program_minimum_arity (program, req, opt, rest);
 527
 528   arities = scm_program_arities (program);
 529   if (!scm_is_pair (arities))
 530     return 0;
 531
 532   parse_arity (scm_car (arities), req, opt, rest);
 533   arities = scm_cdr (arities);
 534
 535   for (; scm_is_pair (arities); arities = scm_cdr (arities))
 536     {
 537       int thisreq, thisopt, thisrest;
 538
 539       parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest);
 540
 541       if (thisreq < *req
 542           || (thisreq == *req
 543               && ((thisrest && (!*rest || thisopt > *opt))
 544                   || (!thisrest && !*rest && thisopt > *opt))))
 545         {
 546           *req = thisreq;
 547           *opt = thisopt;
 548           *rest = thisrest;
 549         }
 550     }
 551
 552   return 1;
 553 }
 554
 555 \f
 556
 557 void
 558 scm_bootstrap_programs (void)
 559 {
 560   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
 561                             "scm_init_programs",
 562                             (scm_t_extension_init_func)scm_init_programs, NULL);
 563 }
 564
 565 void
 566 scm_init_programs (void)
 567 {
 568 #ifndef SCM_MAGIC_SNARFER
 569 #include "libguile/programs.x"
 570 #endif
 571 }
 572
 573 /*
 574   Local Variables:
 575   c-file-style: "gnu"
 576   End:
 577 */