libguile/eval.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
   2  * Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include <alloca.h>
  27
  28 #include "libguile/__scm.h"
  29
  30 #include "libguile/_scm.h"
  31 #include "libguile/alist.h"
  32 #include "libguile/async.h"
  33 #include "libguile/continuations.h"
  34 #include "libguile/debug.h"
  35 #include "libguile/deprecation.h"
  36 #include "libguile/dynwind.h"
  37 #include "libguile/eq.h"
  38 #include "libguile/feature.h"
  39 #include "libguile/fluids.h"
  40 #include "libguile/goops.h"
  41 #include "libguile/hash.h"
  42 #include "libguile/hashtab.h"
  43 #include "libguile/lang.h"
  44 #include "libguile/list.h"
  45 #include "libguile/macros.h"
  46 #include "libguile/memoize.h"
  47 #include "libguile/modules.h"
  48 #include "libguile/ports.h"
  49 #include "libguile/print.h"
  50 #include "libguile/procprop.h"
  51 #include "libguile/programs.h"
  52 #include "libguile/root.h"
  53 #include "libguile/smob.h"
  54 #include "libguile/srcprop.h"
  55 #include "libguile/stackchk.h"
  56 #include "libguile/strings.h"
  57 #include "libguile/threads.h"
  58 #include "libguile/throw.h"
  59 #include "libguile/validate.h"
  60 #include "libguile/values.h"
  61 #include "libguile/vectors.h"
  62 #include "libguile/vm.h"
  63
  64 #include "libguile/eval.h"
  65 #include "libguile/private-options.h"
  66
  67 \f
  68
  69
  70 /* We have three levels of EVAL here:
  71
  72    - eval (exp, env)
  73
  74      evaluates EXP in environment ENV.  ENV is a lexical environment
  75      structure as used by the actual tree code evaluator.  When ENV is
  76      a top-level environment, then changes to the current module are
  77      tracked by updating ENV so that it continues to be in sync with
  78      the current module.
  79
  80    - scm_primitive_eval (exp)
  81
  82      evaluates EXP in the top-level environment as determined by the
  83      current module.  This is done by constructing a suitable
  84      environment and calling eval.  Thus, changes to the
  85      top-level module are tracked normally.
  86
  87    - scm_eval (exp, mod)
  88
  89      evaluates EXP while MOD is the current module. This is done
  90      by setting the current module to MOD_OR_STATE, invoking
  91      scm_primitive_eval on EXP, and then restoring the current module
  92      to the value it had previously.  That is, while EXP is evaluated,
  93      changes to the current module (or dynamic state) are tracked,
  94      but these changes do not persist when scm_eval returns.
  95
  96 */
  97
  98
  99 /* Boot closures. We only see these when compiling eval.scm, because once
 100    eval.scm is in the house, closures are standard VM closures.
 101  */
 102
 103 static scm_t_bits scm_tc16_boot_closure;
 104 #define RETURN_BOOT_CLOSURE(code, env) SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, (code), (env))
 105 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
 106 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
 107 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
 108 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) SCM_I_INUM (CAR (BOOT_CLOSURE_CODE (x)))
 109 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADR (BOOT_CLOSURE_CODE (x)))
 110 #define BOOT_CLOSURE_BODY(x) CDDR (BOOT_CLOSURE_CODE (x))
 111
 112
 113
 114 #if 0
 115 #define CAR(x)   SCM_CAR(x)
 116 #define CDR(x)   SCM_CDR(x)
 117 #define CAAR(x)  SCM_CAAR(x)
 118 #define CADR(x)  SCM_CADR(x)
 119 #define CDAR(x)  SCM_CDAR(x)
 120 #define CDDR(x)  SCM_CDDR(x)
 121 #define CADDR(x) SCM_CADDR(x)
 122 #define CDDDR(x) SCM_CDDDR(x)
 123 #else
 124 #define CAR(x)   scm_car(x)
 125 #define CDR(x)   scm_cdr(x)
 126 #define CAAR(x)  scm_caar(x)
 127 #define CADR(x)  scm_cadr(x)
 128 #define CDAR(x)  scm_cdar(x)
 129 #define CDDR(x)  scm_cddr(x)
 130 #define CADDR(x) scm_caddr(x)
 131 #define CDDDR(x) scm_cdddr(x)
 132 #endif
 133
 134
 135 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
 136
 137 static void error_used_before_defined (void)
 138 {
 139   scm_error (scm_unbound_variable_key, NULL,
 140              "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
 141 }
 142
 143 int
 144 scm_badargsp (SCM formals, SCM args)
 145 {
 146   while (!scm_is_null (formals))
 147     {
 148       if (!scm_is_pair (formals))
 149         return 0;
 150       if (scm_is_null (args))
 151         return 1;
 152       formals = CDR (formals);
 153       args = CDR (args);
 154     }
 155   return !scm_is_null (args) ? 1 : 0;
 156 }
 157
 158 /* the environment:
 159    (VAL ... . MOD)
 160    If MOD is #f, it means the environment was captured before modules were
 161    booted.
 162    If MOD is the literal value '(), we are evaluating at the top level, and so
 163    should track changes to the current module. You have to be careful in this
 164    case, because further lexical contours should capture the current module.
 165 */
 166 #define CAPTURE_ENV(env)                                        \
 167   ((env == SCM_EOL) ? scm_current_module () :                   \
 168    ((env == SCM_BOOL_F) ? scm_the_root_module () : env))
 169
 170 static SCM
 171 eval (SCM x, SCM env)
 172 {
 173   SCM mx;
 174   SCM proc = SCM_UNDEFINED, args = SCM_EOL;
 175
 176  loop:
 177   SCM_TICK;
 178   if (!SCM_MEMOIZED_P (x))
 179     abort ();
 180
 181   mx = SCM_MEMOIZED_ARGS (x);
 182   switch (SCM_MEMOIZED_TAG (x))
 183     {
 184     case SCM_M_BEGIN:
 185       for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
 186         eval (CAR (mx), env);
 187       x = CAR (mx);
 188       goto loop;
 189
 190     case SCM_M_IF:
 191       if (scm_is_true (eval (CAR (mx), env)))
 192         x = CADR (mx);
 193       else
 194         x = CDDR (mx);
 195       goto loop;
 196
 197     case SCM_M_LET:
 198       {
 199         SCM inits = CAR (mx);
 200         SCM new_env = CAPTURE_ENV (env);
 201         for (; scm_is_pair (inits); inits = CDR (inits))
 202           new_env = scm_cons (eval (CAR (inits), env), new_env);
 203         env = new_env;
 204         x = CDR (mx);
 205         goto loop;
 206       }
 207
 208     case SCM_M_LAMBDA:
 209       RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
 210
 211     case SCM_M_QUOTE:
 212       return mx;
 213
 214     case SCM_M_DEFINE:
 215       scm_define (CAR (mx), eval (CDR (mx), env));
 216       return SCM_UNSPECIFIED;
 217
 218     case SCM_M_APPLY:
 219       /* Evaluate the procedure to be applied.  */
 220       proc = eval (CAR (mx), env);
 221       /* Evaluate the argument holding the list of arguments */
 222       args = eval (CADR (mx), env);
 223
 224     apply_proc:
 225       /* Go here to tail-apply a procedure.  PROC is the procedure and
 226        * ARGS is the list of arguments. */
 227       if (BOOT_CLOSURE_P (proc))
 228         {
 229           int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 230           SCM new_env = BOOT_CLOSURE_ENV (proc);
 231           if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
 232             {
 233               if (SCM_UNLIKELY (scm_ilength (args) < nreq))
 234                 scm_wrong_num_args (proc);
 235               for (; nreq; nreq--, args = CDR (args))
 236                 new_env = scm_cons (CAR (args), new_env);
 237               new_env = scm_cons (args, new_env);
 238             }
 239           else
 240             {
 241               if (SCM_UNLIKELY (scm_ilength (args) != nreq))
 242                 scm_wrong_num_args (proc);
 243               for (; scm_is_pair (args); args = CDR (args))
 244                 new_env = scm_cons (CAR (args), new_env);
 245             }
 246           x = BOOT_CLOSURE_BODY (proc);
 247           env = new_env;
 248           goto loop;
 249         }
 250       else
 251         return scm_vm_apply (scm_the_vm (), proc, args);
 252
 253     case SCM_M_CALL:
 254       /* Evaluate the procedure to be applied.  */
 255       proc = eval (CAR (mx), env);
 256       /* int nargs = CADR (mx); */
 257       mx = CDDR (mx);
 258
 259       if (BOOT_CLOSURE_P (proc))
 260         {
 261           int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 262           SCM new_env = BOOT_CLOSURE_ENV (proc);
 263           if (BOOT_CLOSURE_HAS_REST_ARGS (proc))
 264             {
 265               if (SCM_UNLIKELY (scm_ilength (mx) < nreq))
 266                 scm_wrong_num_args (proc);
 267               for (; nreq; nreq--, mx = CDR (mx))
 268                 new_env = scm_cons (eval (CAR (mx), env), new_env);
 269               {
 270                 SCM rest = SCM_EOL;
 271                 for (; scm_is_pair (mx); mx = CDR (mx))
 272                   rest = scm_cons (eval (CAR (mx), env), rest);
 273                 new_env = scm_cons (scm_reverse (rest),
 274                                     new_env);
 275               }
 276             }
 277           else
 278             {
 279               for (; scm_is_pair (mx); mx = CDR (mx), nreq--)
 280                 new_env = scm_cons (eval (CAR (mx), env), new_env);
 281               if (SCM_UNLIKELY (nreq != 0))
 282                 scm_wrong_num_args (proc);
 283             }
 284           x = BOOT_CLOSURE_BODY (proc);
 285           env = new_env;
 286           goto loop;
 287         }
 288       else
 289         {
 290           SCM rest = SCM_EOL;
 291           /* FIXME: use alloca */
 292           for (; scm_is_pair (mx); mx = CDR (mx))
 293             rest = scm_cons (eval (CAR (mx), env), rest);
 294           return scm_vm_apply (scm_the_vm (), proc, scm_reverse (rest));
 295         }
 296
 297     case SCM_M_CONT:
 298       {
 299         int first;
 300         SCM val = scm_make_continuation (&first);
 301
 302         if (!first)
 303           return val;
 304         else
 305           {
 306             proc = eval (mx, env);
 307             args = scm_list_1 (val);
 308             goto apply_proc;
 309           }
 310       }
 311
 312     case SCM_M_CALL_WITH_VALUES:
 313       {
 314         SCM producer;
 315         SCM v;
 316
 317         producer = eval (CAR (mx), env);
 318         proc = eval (CDR (mx), env);  /* proc is the consumer. */
 319         v = scm_vm_apply (scm_the_vm (), producer, SCM_EOL);
 320         if (SCM_VALUESP (v))
 321           args = scm_struct_ref (v, SCM_INUM0);
 322         else
 323           args = scm_list_1 (v);
 324         goto apply_proc;
 325       }
 326
 327     case SCM_M_LEXICAL_REF:
 328       {
 329         int n;
 330         SCM ret;
 331         for (n = SCM_I_INUM (mx); n; n--)
 332           env = CDR (env);
 333         ret = CAR (env);
 334         if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
 335           /* we don't know what variable, though, because we don't have its
 336              name */
 337           error_used_before_defined ();
 338         return ret;
 339       }
 340
 341     case SCM_M_LEXICAL_SET:
 342       {
 343         int n;
 344         SCM val = eval (CDR (mx), env);
 345         for (n = SCM_I_INUM (CAR (mx)); n; n--)
 346           env = CDR (env);
 347         SCM_SETCAR (env, val);
 348         return SCM_UNSPECIFIED;
 349       }
 350
 351     case SCM_M_TOPLEVEL_REF:
 352       if (SCM_VARIABLEP (mx))
 353         return SCM_VARIABLE_REF (mx);
 354       else
 355         {
 356           while (scm_is_pair (env))
 357             env = scm_cdr (env);
 358           return SCM_VARIABLE_REF
 359             (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
 360         }
 361
 362     case SCM_M_TOPLEVEL_SET:
 363       {
 364         SCM var = CAR (mx);
 365         SCM val = eval (CDR (mx), env);
 366         if (SCM_VARIABLEP (var))
 367           {
 368             SCM_VARIABLE_SET (var, val);
 369             return SCM_UNSPECIFIED;
 370           }
 371         else
 372           {
 373             while (scm_is_pair (env))
 374               env = scm_cdr (env);
 375             SCM_VARIABLE_SET
 376               (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
 377                val);
 378             return SCM_UNSPECIFIED;
 379           }
 380       }
 381
 382     case SCM_M_MODULE_REF:
 383       if (SCM_VARIABLEP (mx))
 384         return SCM_VARIABLE_REF (mx);
 385       else
 386         return SCM_VARIABLE_REF
 387           (scm_memoize_variable_access_x (x, SCM_BOOL_F));
 388
 389     case SCM_M_MODULE_SET:
 390       if (SCM_VARIABLEP (CDR (mx)))
 391         {
 392           SCM_VARIABLE_SET (CDR (mx), eval (CAR (mx), env));
 393           return SCM_UNSPECIFIED;
 394         }
 395       else
 396         {
 397           SCM_VARIABLE_SET
 398             (scm_memoize_variable_access_x (x, SCM_BOOL_F),
 399              eval (CAR (mx), env));
 400           return SCM_UNSPECIFIED;
 401         }
 402
 403     default:
 404       abort ();
 405     }
 406 }
 407
 408 scm_t_option scm_eval_opts[] = {
 409   { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
 410   { 0 }
 411 };
 412
 413 scm_t_option scm_debug_opts[] = {
 414   { SCM_OPTION_BOOLEAN, "cheap", 1,
 415     "*This option is now obsolete.  Setting it has no effect." },
 416   { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
 417   { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
 418   { SCM_OPTION_BOOLEAN, "procnames", 1,
 419     "Record procedure names at definition." },
 420   { SCM_OPTION_BOOLEAN, "backwards", 0,
 421     "Display backtrace in anti-chronological order." },
 422   { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
 423   { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
 424   { SCM_OPTION_INTEGER, "frames", 3,
 425     "Maximum number of tail-recursive frames in backtrace." },
 426   { SCM_OPTION_INTEGER, "maxdepth", 1000,
 427     "Maximal number of stored backtrace frames." },
 428   { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
 429   { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
 430   { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
 431   /* This default stack limit will be overridden by debug.c:init_stack_limit(),
 432      if we have getrlimit() and the stack limit is not INFINITY. But it is still
 433      important, as some systems have both the soft and the hard limits set to
 434      INFINITY; in that case we fall back to this value.
 435
 436      The situation is aggravated by certain compilers, which can consume
 437      "beaucoup de stack", as they say in France.
 438
 439      See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
 440      more discussion. This setting is 640 KB on 32-bit arches (should be enough
 441      for anyone!) or a whoppin' 1280 KB on 64-bit arches.
 442   */
 443   { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
 444   { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
 445     "Show file names and line numbers "
 446     "in backtraces when not `#f'.  A value of `base' "
 447     "displays only base names, while `#t' displays full names."},
 448   { SCM_OPTION_BOOLEAN, "warn-deprecated", 0,
 449     "Warn when deprecated features are used." },
 450   { 0 },
 451 };
 452
 453
 454 /*
 455  * this ordering is awkward and illogical, but we maintain it for
 456  * compatibility. --hwn
 457  */
 458 scm_t_option scm_evaluator_trap_table[] = {
 459   { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
 460   { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
 461   { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
 462   { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
 463   { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
 464   { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
 465   { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." },
 466   { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
 467   { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." },
 468   { 0 }
 469 };
 470
 471
 472 SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
 473             (SCM setting),
 474             "Option interface for the evaluation options. Instead of using\n"
 475             "this procedure directly, use the procedures @code{eval-enable},\n"
 476             "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
 477 #define FUNC_NAME s_scm_eval_options_interface
 478 {
 479   SCM ans;
 480
 481   scm_dynwind_begin (0);
 482   scm_dynwind_critical_section (SCM_BOOL_F);
 483   ans = scm_options (setting,
 484                      scm_eval_opts,
 485                      FUNC_NAME);
 486   scm_dynwind_end ();
 487
 488   return ans;
 489 }
 490 #undef FUNC_NAME
 491
 492
 493 SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
 494             (SCM setting),
 495             "Option interface for the evaluator trap options.")
 496 #define FUNC_NAME s_scm_evaluator_traps
 497 {
 498   SCM ans;
 499
 500
 501   scm_options_try (setting,
 502                    scm_evaluator_trap_table,
 503                    FUNC_NAME, 1);
 504   SCM_CRITICAL_SECTION_START;
 505   ans = scm_options (setting,
 506                      scm_evaluator_trap_table,
 507                      FUNC_NAME);
 508
 509   /* njrev: same again. */
 510   SCM_CRITICAL_SECTION_END;
 511   return ans;
 512 }
 513 #undef FUNC_NAME
 514
 515
 516
 517 \f
 518
 519 /* Simple procedure calls
 520  */
 521
 522 SCM
 523 scm_call_0 (SCM proc)
 524 {
 525   return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
 526 }
 527
 528 SCM
 529 scm_call_1 (SCM proc, SCM arg1)
 530 {
 531   return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
 532 }
 533
 534 SCM
 535 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
 536 {
 537   SCM args[] = { arg1, arg2 };
 538   return scm_c_vm_run (scm_the_vm (), proc, args, 2);
 539 }
 540
 541 SCM
 542 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
 543 {
 544   SCM args[] = { arg1, arg2, arg3 };
 545   return scm_c_vm_run (scm_the_vm (), proc, args, 3);
 546 }
 547
 548 SCM
 549 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 550 {
 551   SCM args[] = { arg1, arg2, arg3, arg4 };
 552   return scm_c_vm_run (scm_the_vm (), proc, args, 4);
 553 }
 554
 555 SCM
 556 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 557 {
 558   return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
 559 }
 560
 561 /* Simple procedure applies
 562  */
 563
 564 SCM
 565 scm_apply_0 (SCM proc, SCM args)
 566 {
 567   return scm_apply (proc, args, SCM_EOL);
 568 }
 569
 570 SCM
 571 scm_apply_1 (SCM proc, SCM arg1, SCM args)
 572 {
 573   return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
 574 }
 575
 576 SCM
 577 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
 578 {
 579   return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
 580 }
 581
 582 SCM
 583 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
 584 {
 585   return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
 586                     SCM_EOL);
 587 }
 588
 589 /* This code processes the arguments to apply:
 590
 591    (apply PROC ARG1 ... ARGS)
 592
 593    Given a list (ARG1 ... ARGS), this function conses the ARG1
 594    ... arguments onto the front of ARGS, and returns the resulting
 595    list.  Note that ARGS is a list; thus, the argument to this
 596    function is a list whose last element is a list.
 597
 598    Apply calls this function, and applies PROC to the elements of the
 599    result.  apply:nconc2last takes care of building the list of
 600    arguments, given (ARG1 ... ARGS).
 601
 602    Rather than do new consing, apply:nconc2last destroys its argument.
 603    On that topic, this code came into my care with the following
 604    beautifully cryptic comment on that topic: "This will only screw
 605    you if you do (scm_apply scm_apply '( ... ))"  If you know what
 606    they're referring to, send me a patch to this comment.  */
 607
 608 SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
 609             (SCM lst),
 610             "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
 611             "conses the @var{arg1} @dots{} arguments onto the front of\n"
 612             "@var{args}, and returns the resulting list. Note that\n"
 613             "@var{args} is a list; thus, the argument to this function is\n"
 614             "a list whose last element is a list.\n"
 615             "Note: Rather than do new consing, @code{apply:nconc2last}\n"
 616             "destroys its argument, so use with care.")
 617 #define FUNC_NAME s_scm_nconc2last
 618 {
 619   SCM *lloc;
 620   SCM_VALIDATE_NONEMPTYLIST (1, lst);
 621   lloc = &lst;
 622   while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
 623                                           SCM_NULL_OR_NIL_P, but not
 624                                           needed in 99.99% of cases,
 625                                           and it could seriously hurt
 626                                           performance. - Neil */
 627     lloc = SCM_CDRLOC (*lloc);
 628   SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
 629   *lloc = SCM_CAR (*lloc);
 630   return lst;
 631 }
 632 #undef FUNC_NAME
 633
 634
 635
 636 /* Typechecking for multi-argument MAP and FOR-EACH.
 637
 638    Verify that each element of the vector ARGV, except for the first,
 639    is a proper list whose length is LEN.  Attribute errors to WHO,
 640    and claim that the i'th element of ARGV is WHO's i+2'th argument.  */
 641 static inline void
 642 check_map_args (SCM argv,
 643                 long len,
 644                 SCM gf,
 645                 SCM proc,
 646                 SCM args,
 647                 const char *who)
 648 {
 649   long i;
 650
 651   for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
 652     {
 653       SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
 654       long elt_len = scm_ilength (elt);
 655
 656       if (elt_len < 0)
 657         {
 658           if (gf)
 659             scm_apply_generic (gf, scm_cons (proc, args));
 660           else
 661             scm_wrong_type_arg (who, i + 2, elt);
 662         }
 663
 664       if (elt_len != len)
 665         scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
 666     }
 667 }
 668
 669
 670 SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
 671
 672 /* Note: Currently, scm_map applies PROC to the argument list(s)
 673    sequentially, starting with the first element(s).  This is used in
 674    evalext.c where the Scheme procedure `map-in-order', which guarantees
 675    sequential behaviour, is implemented using scm_map.  If the
 676    behaviour changes, we need to update `map-in-order'.
 677 */
 678
 679 SCM
 680 scm_map (SCM proc, SCM arg1, SCM args)
 681 #define FUNC_NAME s_map
 682 {
 683   long i, len;
 684   SCM res = SCM_EOL;
 685   SCM *pres = &res;
 686
 687   len = scm_ilength (arg1);
 688   SCM_GASSERTn (len >= 0,
 689                 g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
 690   SCM_VALIDATE_REST_ARGUMENT (args);
 691   if (scm_is_null (args))
 692     {
 693       SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_map);
 694       while (SCM_NIMP (arg1))
 695         {
 696           *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
 697           pres = SCM_CDRLOC (*pres);
 698           arg1 = SCM_CDR (arg1);
 699         }
 700       return res;
 701     }
 702   if (scm_is_null (SCM_CDR (args)))
 703     {
 704       SCM arg2 = SCM_CAR (args);
 705       int len2 = scm_ilength (arg2);
 706       SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map,
 707                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
 708       SCM_GASSERTn (len2 >= 0,
 709                     g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
 710       if (len2 != len)
 711         SCM_OUT_OF_RANGE (3, arg2);
 712       while (SCM_NIMP (arg1))
 713         {
 714           *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
 715           pres = SCM_CDRLOC (*pres);
 716           arg1 = SCM_CDR (arg1);
 717           arg2 = SCM_CDR (arg2);
 718         }
 719       return res;
 720     }
 721   arg1 = scm_cons (arg1, args);
 722   args = scm_vector (arg1);
 723   check_map_args (args, len, g_map, proc, arg1, s_map);
 724   while (1)
 725     {
 726       arg1 = SCM_EOL;
 727       for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
 728         {
 729           SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
 730           if (SCM_IMP (elt))
 731             return res;
 732           arg1 = scm_cons (SCM_CAR (elt), arg1);
 733           SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
 734         }
 735       *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
 736       pres = SCM_CDRLOC (*pres);
 737     }
 738 }
 739 #undef FUNC_NAME
 740
 741
 742 SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
 743
 744 SCM
 745 scm_for_each (SCM proc, SCM arg1, SCM args)
 746 #define FUNC_NAME s_for_each
 747 {
 748   long i, len;
 749   len = scm_ilength (arg1);
 750   SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
 751                 SCM_ARG2, s_for_each);
 752   SCM_VALIDATE_REST_ARGUMENT (args);
 753   if (scm_is_null (args))
 754     {
 755       SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each,
 756                     proc, arg1, SCM_ARG1, s_for_each);
 757       while (SCM_NIMP (arg1))
 758         {
 759           scm_call_1 (proc, SCM_CAR (arg1));
 760           arg1 = SCM_CDR (arg1);
 761         }
 762       return SCM_UNSPECIFIED;
 763     }
 764   if (scm_is_null (SCM_CDR (args)))
 765     {
 766       SCM arg2 = SCM_CAR (args);
 767       int len2 = scm_ilength (arg2);
 768       SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each,
 769                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
 770       SCM_GASSERTn (len2 >= 0, g_for_each,
 771                     scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
 772       if (len2 != len)
 773         SCM_OUT_OF_RANGE (3, arg2);
 774       while (SCM_NIMP (arg1))
 775         {
 776           scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
 777           arg1 = SCM_CDR (arg1);
 778           arg2 = SCM_CDR (arg2);
 779         }
 780       return SCM_UNSPECIFIED;
 781     }
 782   arg1 = scm_cons (arg1, args);
 783   args = scm_vector (arg1);
 784   check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
 785   while (1)
 786     {
 787       arg1 = SCM_EOL;
 788       for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
 789         {
 790           SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
 791           if (SCM_IMP (elt))
 792             return SCM_UNSPECIFIED;
 793           arg1 = scm_cons (SCM_CAR (elt), arg1);
 794           SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
 795         }
 796       scm_apply (proc, arg1, SCM_EOL);
 797     }
 798 }
 799 #undef FUNC_NAME
 800
 801
 802 static SCM
 803 scm_c_primitive_eval (SCM exp)
 804 {
 805   SCM transformer = scm_current_module_transformer ();
 806   if (scm_is_true (transformer))
 807     exp = scm_call_1 (transformer, exp);
 808   exp = scm_memoize_expression (exp);
 809   return eval (exp, SCM_EOL);
 810 }
 811
 812 static SCM var_primitive_eval;
 813 SCM
 814 scm_primitive_eval (SCM exp)
 815 {
 816   return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
 817                        &exp, 1);
 818 }
 819
 820
 821 /* Eval does not take the second arg optionally.  This is intentional
 822  * in order to be R5RS compatible, and to prepare for the new module
 823  * system, where we would like to make the choice of evaluation
 824  * environment explicit.  */
 825
 826 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
 827             (SCM exp, SCM module_or_state),
 828             "Evaluate @var{exp}, a list representing a Scheme expression,\n"
 829             "in the top-level environment specified by\n"
 830             "@var{module_or_state}.\n"
 831             "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
 832             "@var{module_or_state} is made the current module when\n"
 833             "it is a module, or the current dynamic state when it is\n"
 834             "a dynamic state."
 835             "Example: (eval '(+ 1 2) (interaction-environment))")
 836 #define FUNC_NAME s_scm_eval
 837 {
 838   SCM res;
 839
 840   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 841   if (scm_is_dynamic_state (module_or_state))
 842     scm_dynwind_current_dynamic_state (module_or_state);
 843   else if (scm_module_system_booted_p)
 844     {
 845       SCM_VALIDATE_MODULE (2, module_or_state);
 846       scm_dynwind_current_module (module_or_state);
 847     }
 848   /* otherwise if the module system isn't booted, ignore the module arg */
 849
 850   res = scm_primitive_eval (exp);
 851
 852   scm_dynwind_end ();
 853   return res;
 854 }
 855 #undef FUNC_NAME
 856
 857
 858 static SCM f_apply;
 859
 860 /* Apply a function to a list of arguments.
 861
 862    This function is exported to the Scheme level as taking two
 863    required arguments and a tail argument, as if it were:
 864         (lambda (proc arg1 . args) ...)
 865    Thus, if you just have a list of arguments to pass to a procedure,
 866    pass the list as ARG1, and '() for ARGS.  If you have some fixed
 867    args, pass the first as ARG1, then cons any remaining fixed args
 868    onto the front of your argument list, and pass that as ARGS.  */
 869
 870 SCM
 871 scm_apply (SCM proc, SCM arg1, SCM args)
 872 {
 873   /* Fix things up so that args contains all args. */
 874   if (scm_is_null (args))
 875     args = arg1;
 876   else
 877     args = scm_cons_star (arg1, args);
 878
 879   return scm_vm_apply (scm_the_vm (), proc, args);
 880 }
 881
 882
 883 static SCM
 884 boot_closure_apply (SCM closure, SCM args)
 885 {
 886   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
 887   SCM new_env = BOOT_CLOSURE_ENV (closure);
 888   if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
 889     {
 890       if (SCM_UNLIKELY (scm_ilength (args) < nreq))
 891         scm_wrong_num_args (closure);
 892       for (; nreq; nreq--, args = CDR (args))
 893         new_env = scm_cons (CAR (args), new_env);
 894       new_env = scm_cons (args, new_env);
 895     }
 896   else
 897     {
 898       if (SCM_UNLIKELY (scm_ilength (args) != nreq))
 899         scm_wrong_num_args (closure);
 900       for (; scm_is_pair (args); args = CDR (args))
 901         new_env = scm_cons (CAR (args), new_env);
 902     }
 903   return eval (BOOT_CLOSURE_BODY (closure), new_env);
 904 }
 905
 906 static int
 907 boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
 908 {
 909   SCM args;
 910   scm_puts ("#<boot-closure ", port);
 911   scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
 912   scm_putc (' ', port);
 913   args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
 914                         scm_from_locale_symbol ("_"));
 915   if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
 916     args = scm_cons_star (scm_from_locale_symbol ("_"), args);
 917   scm_display (args, port);
 918   scm_putc ('>', port);
 919   return 1;
 920 }
 921
 922 void
 923 scm_init_eval ()
 924 {
 925   SCM primitive_eval;
 926
 927   scm_init_opts (scm_evaluator_traps,
 928                  scm_evaluator_trap_table);
 929   scm_init_opts (scm_eval_options_interface,
 930                  scm_eval_opts);
 931
 932   f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
 933
 934   scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
 935   scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
 936   scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
 937
 938   primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
 939                                      scm_c_primitive_eval);
 940   var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
 941                                    primitive_eval);
 942
 943 #include "libguile/eval.x"
 944 }
 945
 946 /*
 947   Local Variables:
 948   c-file-style: "gnu"
 949   End:
 950 */
 951