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