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 /* Simple procedure applies
 556  */
 557
 558 SCM
 559 scm_apply_0 (SCM proc, SCM args)
 560 {
 561   return scm_apply (proc, args, SCM_EOL);
 562 }
 563
 564 SCM
 565 scm_apply_1 (SCM proc, SCM arg1, SCM args)
 566 {
 567   return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
 568 }
 569
 570 SCM
 571 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
 572 {
 573   return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
 574 }
 575
 576 SCM
 577 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
 578 {
 579   return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
 580                     SCM_EOL);
 581 }
 582
 583 /* This code processes the arguments to apply:
 584
 585    (apply PROC ARG1 ... ARGS)
 586
 587    Given a list (ARG1 ... ARGS), this function conses the ARG1
 588    ... arguments onto the front of ARGS, and returns the resulting
 589    list.  Note that ARGS is a list; thus, the argument to this
 590    function is a list whose last element is a list.
 591
 592    Apply calls this function, and applies PROC to the elements of the
 593    result.  apply:nconc2last takes care of building the list of
 594    arguments, given (ARG1 ... ARGS).
 595
 596    Rather than do new consing, apply:nconc2last destroys its argument.
 597    On that topic, this code came into my care with the following
 598    beautifully cryptic comment on that topic: "This will only screw
 599    you if you do (scm_apply scm_apply '( ... ))"  If you know what
 600    they're referring to, send me a patch to this comment.  */
 601
 602 SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
 603             (SCM lst),
 604             "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
 605             "conses the @var{arg1} @dots{} arguments onto the front of\n"
 606             "@var{args}, and returns the resulting list. Note that\n"
 607             "@var{args} is a list; thus, the argument to this function is\n"
 608             "a list whose last element is a list.\n"
 609             "Note: Rather than do new consing, @code{apply:nconc2last}\n"
 610             "destroys its argument, so use with care.")
 611 #define FUNC_NAME s_scm_nconc2last
 612 {
 613   SCM *lloc;
 614   SCM_VALIDATE_NONEMPTYLIST (1, lst);
 615   lloc = &lst;
 616   while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
 617                                           SCM_NULL_OR_NIL_P, but not
 618                                           needed in 99.99% of cases,
 619                                           and it could seriously hurt
 620                                           performance. - Neil */
 621     lloc = SCM_CDRLOC (*lloc);
 622   SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
 623   *lloc = SCM_CAR (*lloc);
 624   return lst;
 625 }
 626 #undef FUNC_NAME
 627
 628
 629
 630 /* Typechecking for multi-argument MAP and FOR-EACH.
 631
 632    Verify that each element of the vector ARGV, except for the first,
 633    is a proper list whose length is LEN.  Attribute errors to WHO,
 634    and claim that the i'th element of ARGV is WHO's i+2'th argument.  */
 635 static inline void
 636 check_map_args (SCM argv,
 637                 long len,
 638                 SCM gf,
 639                 SCM proc,
 640                 SCM args,
 641                 const char *who)
 642 {
 643   long i;
 644
 645   for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
 646     {
 647       SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
 648       long elt_len = scm_ilength (elt);
 649
 650       if (elt_len < 0)
 651         {
 652           if (gf)
 653             scm_apply_generic (gf, scm_cons (proc, args));
 654           else
 655             scm_wrong_type_arg (who, i + 2, elt);
 656         }
 657
 658       if (elt_len != len)
 659         scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
 660     }
 661 }
 662
 663
 664 SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
 665
 666 /* Note: Currently, scm_map applies PROC to the argument list(s)
 667    sequentially, starting with the first element(s).  This is used in
 668    evalext.c where the Scheme procedure `map-in-order', which guarantees
 669    sequential behaviour, is implemented using scm_map.  If the
 670    behaviour changes, we need to update `map-in-order'.
 671 */
 672
 673 SCM
 674 scm_map (SCM proc, SCM arg1, SCM args)
 675 #define FUNC_NAME s_map
 676 {
 677   long i, len;
 678   SCM res = SCM_EOL;
 679   SCM *pres = &res;
 680
 681   len = scm_ilength (arg1);
 682   SCM_GASSERTn (len >= 0,
 683                 g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
 684   SCM_VALIDATE_REST_ARGUMENT (args);
 685   if (scm_is_null (args))
 686     {
 687       SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_map, proc, arg1, SCM_ARG1, s_map);
 688       while (SCM_NIMP (arg1))
 689         {
 690           *pres = scm_list_1 (scm_call_1 (proc, SCM_CAR (arg1)));
 691           pres = SCM_CDRLOC (*pres);
 692           arg1 = SCM_CDR (arg1);
 693         }
 694       return res;
 695     }
 696   if (scm_is_null (SCM_CDR (args)))
 697     {
 698       SCM arg2 = SCM_CAR (args);
 699       int len2 = scm_ilength (arg2);
 700       SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_map,
 701                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
 702       SCM_GASSERTn (len2 >= 0,
 703                     g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
 704       if (len2 != len)
 705         SCM_OUT_OF_RANGE (3, arg2);
 706       while (SCM_NIMP (arg1))
 707         {
 708           *pres = scm_list_1 (scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
 709           pres = SCM_CDRLOC (*pres);
 710           arg1 = SCM_CDR (arg1);
 711           arg2 = SCM_CDR (arg2);
 712         }
 713       return res;
 714     }
 715   arg1 = scm_cons (arg1, args);
 716   args = scm_vector (arg1);
 717   check_map_args (args, len, g_map, proc, arg1, s_map);
 718   while (1)
 719     {
 720       arg1 = SCM_EOL;
 721       for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
 722         {
 723           SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
 724           if (SCM_IMP (elt))
 725             return res;
 726           arg1 = scm_cons (SCM_CAR (elt), arg1);
 727           SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
 728         }
 729       *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
 730       pres = SCM_CDRLOC (*pres);
 731     }
 732 }
 733 #undef FUNC_NAME
 734
 735
 736 SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
 737
 738 SCM
 739 scm_for_each (SCM proc, SCM arg1, SCM args)
 740 #define FUNC_NAME s_for_each
 741 {
 742   long i, len;
 743   len = scm_ilength (arg1);
 744   SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
 745                 SCM_ARG2, s_for_each);
 746   SCM_VALIDATE_REST_ARGUMENT (args);
 747   if (scm_is_null (args))
 748     {
 749       SCM_GASSERT2 (scm_is_true (scm_procedure_p (proc)), g_for_each,
 750                     proc, arg1, SCM_ARG1, s_for_each);
 751       while (SCM_NIMP (arg1))
 752         {
 753           scm_call_1 (proc, SCM_CAR (arg1));
 754           arg1 = SCM_CDR (arg1);
 755         }
 756       return SCM_UNSPECIFIED;
 757     }
 758   if (scm_is_null (SCM_CDR (args)))
 759     {
 760       SCM arg2 = SCM_CAR (args);
 761       int len2 = scm_ilength (arg2);
 762       SCM_GASSERTn (scm_is_true (scm_procedure_p (proc)), g_for_each,
 763                     scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
 764       SCM_GASSERTn (len2 >= 0, g_for_each,
 765                     scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
 766       if (len2 != len)
 767         SCM_OUT_OF_RANGE (3, arg2);
 768       while (SCM_NIMP (arg1))
 769         {
 770           scm_call_2 (proc, SCM_CAR (arg1), SCM_CAR (arg2));
 771           arg1 = SCM_CDR (arg1);
 772           arg2 = SCM_CDR (arg2);
 773         }
 774       return SCM_UNSPECIFIED;
 775     }
 776   arg1 = scm_cons (arg1, args);
 777   args = scm_vector (arg1);
 778   check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
 779   while (1)
 780     {
 781       arg1 = SCM_EOL;
 782       for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
 783         {
 784           SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
 785           if (SCM_IMP (elt))
 786             return SCM_UNSPECIFIED;
 787           arg1 = scm_cons (SCM_CAR (elt), arg1);
 788           SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
 789         }
 790       scm_apply (proc, arg1, SCM_EOL);
 791     }
 792 }
 793 #undef FUNC_NAME
 794
 795
 796 static SCM
 797 scm_c_primitive_eval (SCM exp)
 798 {
 799   SCM transformer = scm_current_module_transformer ();
 800   if (scm_is_true (transformer))
 801     exp = scm_call_1 (transformer, exp);
 802   exp = scm_memoize_expression (exp);
 803   return eval (exp, SCM_EOL);
 804 }
 805
 806 static SCM var_primitive_eval;
 807 SCM
 808 scm_primitive_eval (SCM exp)
 809 {
 810   return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
 811                        &exp, 1);
 812 }
 813
 814
 815 /* Eval does not take the second arg optionally.  This is intentional
 816  * in order to be R5RS compatible, and to prepare for the new module
 817  * system, where we would like to make the choice of evaluation
 818  * environment explicit.  */
 819
 820 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
 821             (SCM exp, SCM module_or_state),
 822             "Evaluate @var{exp}, a list representing a Scheme expression,\n"
 823             "in the top-level environment specified by\n"
 824             "@var{module_or_state}.\n"
 825             "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
 826             "@var{module_or_state} is made the current module when\n"
 827             "it is a module, or the current dynamic state when it is\n"
 828             "a dynamic state."
 829             "Example: (eval '(+ 1 2) (interaction-environment))")
 830 #define FUNC_NAME s_scm_eval
 831 {
 832   SCM res;
 833
 834   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 835   if (scm_is_dynamic_state (module_or_state))
 836     scm_dynwind_current_dynamic_state (module_or_state);
 837   else if (scm_module_system_booted_p)
 838     {
 839       SCM_VALIDATE_MODULE (2, module_or_state);
 840       scm_dynwind_current_module (module_or_state);
 841     }
 842   /* otherwise if the module system isn't booted, ignore the module arg */
 843
 844   res = scm_primitive_eval (exp);
 845
 846   scm_dynwind_end ();
 847   return res;
 848 }
 849 #undef FUNC_NAME
 850
 851
 852 static SCM f_apply;
 853
 854 /* Apply a function to a list of arguments.
 855
 856    This function is exported to the Scheme level as taking two
 857    required arguments and a tail argument, as if it were:
 858         (lambda (proc arg1 . args) ...)
 859    Thus, if you just have a list of arguments to pass to a procedure,
 860    pass the list as ARG1, and '() for ARGS.  If you have some fixed
 861    args, pass the first as ARG1, then cons any remaining fixed args
 862    onto the front of your argument list, and pass that as ARGS.  */
 863
 864 SCM
 865 scm_apply (SCM proc, SCM arg1, SCM args)
 866 {
 867   /* Fix things up so that args contains all args. */
 868   if (scm_is_null (args))
 869     args = arg1;
 870   else
 871     args = scm_cons_star (arg1, args);
 872
 873   return scm_vm_apply (scm_the_vm (), proc, args);
 874 }
 875
 876
 877 static SCM
 878 boot_closure_apply (SCM closure, SCM args)
 879 {
 880   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure);
 881   SCM new_env = BOOT_CLOSURE_ENV (closure);
 882   if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
 883     {
 884       if (SCM_UNLIKELY (scm_ilength (args) < nreq))
 885         scm_wrong_num_args (closure);
 886       for (; nreq; nreq--, args = CDR (args))
 887         new_env = scm_cons (CAR (args), new_env);
 888       new_env = scm_cons (args, new_env);
 889     }
 890   else
 891     {
 892       if (SCM_UNLIKELY (scm_ilength (args) != nreq))
 893         scm_wrong_num_args (closure);
 894       for (; scm_is_pair (args); args = CDR (args))
 895         new_env = scm_cons (CAR (args), new_env);
 896     }
 897   return eval (BOOT_CLOSURE_BODY (closure), new_env);
 898 }
 899
 900 static int
 901 boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
 902 {
 903   SCM args;
 904   scm_puts ("#<boot-closure ", port);
 905   scm_uintprint ((unsigned long)SCM2PTR (closure), 16, port);
 906   scm_putc (' ', port);
 907   args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
 908                         scm_from_locale_symbol ("_"));
 909   if (BOOT_CLOSURE_HAS_REST_ARGS (closure))
 910     args = scm_cons_star (scm_from_locale_symbol ("_"), args);
 911   scm_display (args, port);
 912   scm_putc ('>', port);
 913   return 1;
 914 }
 915
 916 void
 917 scm_init_eval ()
 918 {
 919   SCM primitive_eval;
 920
 921   scm_init_opts (scm_evaluator_traps,
 922                  scm_evaluator_trap_table);
 923   scm_init_opts (scm_eval_options_interface,
 924                  scm_eval_opts);
 925
 926   f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
 927
 928   scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
 929   scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
 930   scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
 931
 932   primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
 933                                      scm_c_primitive_eval);
 934   var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
 935                                    primitive_eval);
 936
 937 #include "libguile/eval.x"
 938 }
 939
 940 /*
 941   Local Variables:
 942   c-file-style: "gnu"
 943   End:
 944 */
 945