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