libguile/eval.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
   2  *   2005,2006,2007,2008,2009,2010,2011,2012,2013
   3  * Free Software Foundation, Inc.
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public License
   7  * as published by the Free Software Foundation; either version 3 of
   8  * the License, or (at your option) any later version.
   9  *
  10  * This library is distributed in the hope that it will be useful, but
  11  * WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18  * 02110-1301 USA
  19  */
  20
  21 \f
  22
  23 #ifdef HAVE_CONFIG_H
  24 #  include <config.h>
  25 #endif
  26
  27 #include <alloca.h>
  28 #include <stdarg.h>
  29
  30 #include "libguile/__scm.h"
  31
  32 #include "libguile/_scm.h"
  33 #include "libguile/alist.h"
  34 #include "libguile/async.h"
  35 #include "libguile/continuations.h"
  36 #include "libguile/control.h"
  37 #include "libguile/debug.h"
  38 #include "libguile/deprecation.h"
  39 #include "libguile/dynwind.h"
  40 #include "libguile/eq.h"
  41 #include "libguile/expand.h"
  42 #include "libguile/feature.h"
  43 #include "libguile/goops.h"
  44 #include "libguile/hash.h"
  45 #include "libguile/hashtab.h"
  46 #include "libguile/list.h"
  47 #include "libguile/macros.h"
  48 #include "libguile/memoize.h"
  49 #include "libguile/modules.h"
  50 #include "libguile/ports.h"
  51 #include "libguile/print.h"
  52 #include "libguile/procprop.h"
  53 #include "libguile/programs.h"
  54 #include "libguile/root.h"
  55 #include "libguile/smob.h"
  56 #include "libguile/srcprop.h"
  57 #include "libguile/stackchk.h"
  58 #include "libguile/strings.h"
  59 #include "libguile/threads.h"
  60 #include "libguile/throw.h"
  61 #include "libguile/validate.h"
  62 #include "libguile/values.h"
  63 #include "libguile/vectors.h"
  64 #include "libguile/vm.h"
  65
  66 #include "libguile/eval.h"
  67 #include "libguile/private-options.h"
  68
  69 \f
  70
  71
  72 /* We have three levels of EVAL here:
  73
  74    - eval (exp, env)
  75
  76      evaluates EXP in environment ENV.  ENV is a lexical environment
  77      structure as used by the actual tree code evaluator.  When ENV is
  78      a top-level environment, then changes to the current module are
  79      tracked by updating ENV so that it continues to be in sync with
  80      the current module.
  81
  82    - scm_primitive_eval (exp)
  83
  84      evaluates EXP in the top-level environment as determined by the
  85      current module.  This is done by constructing a suitable
  86      environment and calling eval.  Thus, changes to the
  87      top-level module are tracked normally.
  88
  89    - scm_eval (exp, mod)
  90
  91      evaluates EXP while MOD is the current module. This is done
  92      by setting the current module to MOD_OR_STATE, invoking
  93      scm_primitive_eval on EXP, and then restoring the current module
  94      to the value it had previously.  That is, while EXP is evaluated,
  95      changes to the current module (or dynamic state) are tracked,
  96      but these changes do not persist when scm_eval returns.
  97
  98 */
  99
 100
 101 /* Boot closures. We only see these when compiling eval.scm, because once
 102    eval.scm is in the house, closures are standard VM closures.
 103  */
 104
 105 static scm_t_bits scm_tc16_boot_closure;
 106 #define RETURN_BOOT_CLOSURE(code, env) \
 107   SCM_RETURN_NEWSMOB2 (scm_tc16_boot_closure, SCM_UNPACK (code), SCM_UNPACK (env))
 108 #define BOOT_CLOSURE_P(obj) SCM_TYP16_PREDICATE (scm_tc16_boot_closure, (obj))
 109 #define BOOT_CLOSURE_CODE(x) SCM_SMOB_OBJECT (x)
 110 #define BOOT_CLOSURE_ENV(x) SCM_SMOB_OBJECT_2 (x)
 111 #define BOOT_CLOSURE_BODY(x) CAR (BOOT_CLOSURE_CODE (x))
 112 #define BOOT_CLOSURE_NUM_REQUIRED_ARGS(x) (SCM_I_INUM (CADDR (BOOT_CLOSURE_CODE (x))))
 113 #define BOOT_CLOSURE_IS_FIXED(x)  (scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))))
 114 /* NB: One may only call the following accessors if the closure is not FIXED. */
 115 #define BOOT_CLOSURE_HAS_REST_ARGS(x) scm_is_true (CADDR (SCM_CDR (BOOT_CLOSURE_CODE (x))))
 116 #define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
 117 /* NB: One may only call the following accessors if the closure is not REST. */
 118 #define BOOT_CLOSURE_IS_FULL(x) (1)
 119 #define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt)    \
 120   do { SCM fu = fu_;                                            \
 121     body = CAR (fu); fu = CDDR (fu);                            \
 122                                                                 \
 123     rest = kw = alt = SCM_BOOL_F;                               \
 124     inits = SCM_EOL;                                            \
 125     nopt = 0;                                                   \
 126                                                                 \
 127     nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu);                \
 128     if (scm_is_pair (fu))                                       \
 129       {                                                         \
 130         rest = CAR (fu); fu = CDR (fu);                         \
 131         if (scm_is_pair (fu))                                   \
 132           {                                                     \
 133             nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu);        \
 134             kw = CAR (fu); fu = CDR (fu);                       \
 135             inits = CAR (fu); fu = CDR (fu);                    \
 136             alt = CAR (fu);                                     \
 137           }                                                     \
 138       }                                                         \
 139   } while (0)
 140 static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
 141                                                 SCM *out_body, SCM *out_env);
 142 static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
 143                                                SCM exps, SCM *out_body,
 144                                                SCM *inout_env);
 145
 146
 147 #define CAR(x)   SCM_CAR(x)
 148 #define CDR(x)   SCM_CDR(x)
 149 #define CAAR(x)  SCM_CAAR(x)
 150 #define CADR(x)  SCM_CADR(x)
 151 #define CDAR(x)  SCM_CDAR(x)
 152 #define CDDR(x)  SCM_CDDR(x)
 153 #define CADDR(x) SCM_CADDR(x)
 154 #define CDDDR(x) SCM_CDDDR(x)
 155
 156 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
 157 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
 158 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
 159
 160 static SCM
 161 make_env (int n, SCM init, SCM next)
 162 {
 163   SCM env = scm_c_make_vector (n + 1, init);
 164   VECTOR_SET (env, 0, next);
 165   return env;
 166 }
 167
 168 static SCM
 169 next_rib (SCM env)
 170 {
 171   return VECTOR_REF (env, 0);
 172 }
 173
 174 static SCM
 175 env_tail (SCM env)
 176 {
 177   while (SCM_I_IS_VECTOR (env))
 178     env = next_rib (env);
 179   return env;
 180 }
 181
 182 static SCM
 183 env_ref (SCM env, int depth, int width)
 184 {
 185   while (depth--)
 186     env = next_rib (env);
 187   return VECTOR_REF (env, width + 1);
 188 }
 189
 190 static void
 191 env_set (SCM env, int depth, int width, SCM val)
 192 {
 193   while (depth--)
 194     env = next_rib (env);
 195   VECTOR_SET (env, width + 1, val);
 196 }
 197
 198
 199 SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
 200
 201 static void error_used_before_defined (void)
 202 {
 203   scm_error (scm_unbound_variable_key, NULL,
 204              "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
 205 }
 206
 207 static void error_invalid_keyword (SCM proc, SCM obj)
 208 {
 209   scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
 210                  scm_from_locale_string ("Invalid keyword"), SCM_EOL,
 211                  scm_list_1 (obj));
 212 }
 213
 214 static void error_unrecognized_keyword (SCM proc, SCM kw)
 215 {
 216   scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
 217                  scm_from_locale_string ("Unrecognized keyword"), SCM_EOL,
 218                  scm_list_1 (kw));
 219 }
 220
 221
 222 /* Multiple values truncation.  */
 223 static SCM
 224 truncate_values (SCM x)
 225 {
 226   if (SCM_LIKELY (!SCM_VALUESP (x)))
 227     return x;
 228   else
 229     {
 230       SCM l = scm_struct_ref (x, SCM_INUM0);
 231       if (SCM_LIKELY (scm_is_pair (l)))
 232         return scm_car (l);
 233       else
 234         {
 235           scm_ithrow (scm_from_latin1_symbol ("vm-run"),
 236                       scm_list_3 (scm_from_latin1_symbol ("vm-run"),
 237                                   scm_from_locale_string
 238                                   ("Too few values returned to continuation"),
 239                                   SCM_EOL),
 240                       1);
 241           /* Not reached.  */
 242           return SCM_BOOL_F;
 243         }
 244     }
 245 }
 246 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
 247
 248 static SCM
 249 eval (SCM x, SCM env)
 250 {
 251   SCM mx;
 252   SCM proc = SCM_UNDEFINED, args = SCM_EOL;
 253   unsigned int argc;
 254
 255  loop:
 256   SCM_TICK;
 257
 258   mx = SCM_MEMOIZED_ARGS (x);
 259   switch (SCM_I_INUM (SCM_CAR (x)))
 260     {
 261     case SCM_M_SEQ:
 262       eval (CAR (mx), env);
 263       x = CDR (mx);
 264       goto loop;
 265
 266     case SCM_M_IF:
 267       if (scm_is_true (EVAL1 (CAR (mx), env)))
 268         x = CADR (mx);
 269       else
 270         x = CDDR (mx);
 271       goto loop;
 272
 273     case SCM_M_LET:
 274       {
 275         SCM inits = CAR (mx);
 276         SCM new_env;
 277         int i;
 278
 279         new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
 280         for (i = 0; i < VECTOR_LENGTH (inits); i++)
 281           env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
 282         env = new_env;
 283         x = CDR (mx);
 284         goto loop;
 285       }
 286
 287     case SCM_M_LAMBDA:
 288       RETURN_BOOT_CLOSURE (mx, env);
 289
 290     case SCM_M_QUOTE:
 291       return mx;
 292
 293     case SCM_M_DEFINE:
 294       scm_define (CAR (mx), EVAL1 (CDR (mx), env));
 295       return SCM_UNSPECIFIED;
 296
 297     case SCM_M_CAPTURE_MODULE:
 298       return eval (mx, scm_current_module ());
 299
 300     case SCM_M_APPLY:
 301       /* Evaluate the procedure to be applied.  */
 302       proc = EVAL1 (CAR (mx), env);
 303       /* Evaluate the argument holding the list of arguments */
 304       args = EVAL1 (CADR (mx), env);
 305
 306     apply_proc:
 307       /* Go here to tail-apply a procedure.  PROC is the procedure and
 308        * ARGS is the list of arguments. */
 309       if (BOOT_CLOSURE_P (proc))
 310         {
 311           prepare_boot_closure_env_for_apply (proc, args, &x, &env);
 312           goto loop;
 313         }
 314       else
 315         return scm_apply_0 (proc, args);
 316
 317     case SCM_M_CALL:
 318       /* Evaluate the procedure to be applied.  */
 319       proc = EVAL1 (CAR (mx), env);
 320       argc = SCM_I_INUM (CADR (mx));
 321       mx = CDDR (mx);
 322
 323       if (BOOT_CLOSURE_P (proc))
 324         {
 325           prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
 326           goto loop;
 327         }
 328       else
 329         {
 330           SCM *argv;
 331           unsigned int i;
 332
 333           argv = alloca (argc * sizeof (SCM));
 334           for (i = 0; i < argc; i++, mx = CDR (mx))
 335             argv[i] = EVAL1 (CAR (mx), env);
 336
 337           return scm_call_n (proc, argv, argc);
 338         }
 339
 340     case SCM_M_CONT:
 341       return scm_i_call_with_current_continuation (EVAL1 (mx, env));
 342
 343     case SCM_M_CALL_WITH_VALUES:
 344       {
 345         SCM producer;
 346         SCM v;
 347
 348         producer = EVAL1 (CAR (mx), env);
 349         /* `proc' is the consumer.  */
 350         proc = EVAL1 (CDR (mx), env);
 351         v = scm_call_0 (producer);
 352         if (SCM_VALUESP (v))
 353           args = scm_struct_ref (v, SCM_INUM0);
 354         else
 355           args = scm_list_1 (v);
 356         goto apply_proc;
 357       }
 358
 359     case SCM_M_LEXICAL_REF:
 360       {
 361         SCM pos, ret;
 362         int depth, width;
 363
 364         pos = mx;
 365         depth = SCM_I_INUM (CAR (pos));
 366         width = SCM_I_INUM (CDR (pos));
 367
 368         ret = env_ref (env, depth, width);
 369
 370         if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
 371           /* we don't know what variable, though, because we don't have its
 372              name */
 373           error_used_before_defined ();
 374         return ret;
 375       }
 376
 377     case SCM_M_LEXICAL_SET:
 378       {
 379         SCM pos;
 380         int depth, width;
 381         SCM val = EVAL1 (CDR (mx), env);
 382
 383         pos = CAR (mx);
 384         depth = SCM_I_INUM (CAR (pos));
 385         width = SCM_I_INUM (CDR (pos));
 386
 387         env_set (env, depth, width, val);
 388
 389         return SCM_UNSPECIFIED;
 390       }
 391
 392     case SCM_M_TOPLEVEL_REF:
 393       if (SCM_VARIABLEP (mx))
 394         return SCM_VARIABLE_REF (mx);
 395       else
 396         {
 397           env = env_tail (env);
 398           return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
 399         }
 400
 401     case SCM_M_TOPLEVEL_SET:
 402       {
 403         SCM var = CAR (mx);
 404         SCM val = EVAL1 (CDR (mx), env);
 405         if (SCM_VARIABLEP (var))
 406           {
 407             SCM_VARIABLE_SET (var, val);
 408             return SCM_UNSPECIFIED;
 409           }
 410         else
 411           {
 412             env = env_tail (env);
 413             SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
 414             return SCM_UNSPECIFIED;
 415           }
 416       }
 417
 418     case SCM_M_MODULE_REF:
 419       if (SCM_VARIABLEP (mx))
 420         return SCM_VARIABLE_REF (mx);
 421       else
 422         return SCM_VARIABLE_REF
 423           (scm_memoize_variable_access_x (x, SCM_BOOL_F));
 424
 425     case SCM_M_MODULE_SET:
 426       if (SCM_VARIABLEP (CDR (mx)))
 427         {
 428           SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
 429           return SCM_UNSPECIFIED;
 430         }
 431       else
 432         {
 433           SCM_VARIABLE_SET
 434             (scm_memoize_variable_access_x (x, SCM_BOOL_F),
 435              EVAL1 (CAR (mx), env));
 436           return SCM_UNSPECIFIED;
 437         }
 438
 439     case SCM_M_CALL_WITH_PROMPT:
 440       {
 441         struct scm_vm *vp;
 442         SCM k, res;
 443         scm_i_jmp_buf registers;
 444         /* We need the handler after nonlocal return to the setjmp, so
 445            make sure it is volatile.  */
 446         volatile SCM handler;
 447
 448         k = EVAL1 (CAR (mx), env);
 449         handler = EVAL1 (CDDR (mx), env);
 450         vp = scm_the_vm ();
 451
 452         /* Push the prompt onto the dynamic stack. */
 453         scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
 454                                   SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
 455                                   | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
 456                                   k,
 457                                   vp->fp - vp->stack_base,
 458                                   vp->sp - vp->stack_base,
 459                                   vp->ip,
 460                                   &registers);
 461
 462         if (SCM_I_SETJMP (registers))
 463           {
 464             /* The prompt exited nonlocally. */
 465             proc = handler;
 466             vp = scm_the_vm ();
 467             args = scm_i_prompt_pop_abort_args_x (vp);
 468             goto apply_proc;
 469           }
 470
 471         res = scm_call_0 (eval (CADR (mx), env));
 472         scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
 473         return res;
 474       }
 475
 476     default:
 477       abort ();
 478     }
 479 }
 480
 481 \f
 482
 483 /* Simple procedure calls
 484  */
 485
 486 SCM
 487 scm_call_0 (SCM proc)
 488 {
 489   return scm_call_n (proc, NULL, 0);
 490 }
 491
 492 SCM
 493 scm_call_1 (SCM proc, SCM arg1)
 494 {
 495   return scm_call_n (proc, &arg1, 1);
 496 }
 497
 498 SCM
 499 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
 500 {
 501   SCM args[] = { arg1, arg2 };
 502   return scm_call_n (proc, args, 2);
 503 }
 504
 505 SCM
 506 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
 507 {
 508   SCM args[] = { arg1, arg2, arg3 };
 509   return scm_call_n (proc, args, 3);
 510 }
 511
 512 SCM
 513 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 514 {
 515   SCM args[] = { arg1, arg2, arg3, arg4 };
 516   return scm_call_n (proc, args, 4);
 517 }
 518
 519 SCM
 520 scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
 521 {
 522   SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
 523   return scm_call_n (proc, args, 5);
 524 }
 525
 526 SCM
 527 scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 528             SCM arg6)
 529 {
 530   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
 531   return scm_call_n (proc, args, 6);
 532 }
 533
 534 SCM
 535 scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 536             SCM arg6, SCM arg7)
 537 {
 538   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
 539   return scm_call_n (proc, args, 7);
 540 }
 541
 542 SCM
 543 scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 544             SCM arg6, SCM arg7, SCM arg8)
 545 {
 546   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
 547   return scm_call_n (proc, args, 8);
 548 }
 549
 550 SCM
 551 scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 552             SCM arg6, SCM arg7, SCM arg8, SCM arg9)
 553 {
 554   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
 555   return scm_call_n (proc, args, 9);
 556 }
 557
 558 /* scm_call_n defined in vm.c */
 559
 560 SCM
 561 scm_call (SCM proc, ...)
 562 {
 563   va_list argp;
 564   SCM *argv = NULL;
 565   size_t i, nargs = 0;
 566
 567   va_start (argp, proc);
 568   while (!SCM_UNBNDP (va_arg (argp, SCM)))
 569     nargs++;
 570   va_end (argp);
 571
 572   argv = alloca (nargs * sizeof (SCM));
 573   va_start (argp, proc);
 574   for (i = 0; i < nargs; i++)
 575     argv[i] = va_arg (argp, SCM);
 576   va_end (argp);
 577
 578   return scm_call_n (proc, argv, nargs);
 579 }
 580
 581 /* Simple procedure applies
 582  */
 583
 584 SCM
 585 scm_apply_0 (SCM proc, SCM args)
 586 {
 587   SCM *argv;
 588   int i, nargs;
 589
 590   nargs = scm_ilength (args);
 591   if (SCM_UNLIKELY (nargs < 0))
 592     scm_wrong_type_arg_msg ("apply", 2, args, "list");
 593
 594   /* FIXME: Use vm_builtin_apply instead of alloca.  */
 595   argv = alloca (nargs * sizeof(SCM));
 596   for (i = 0; i < nargs; i++)
 597     {
 598       argv[i] = SCM_CAR (args);
 599       args = SCM_CDR (args);
 600     }
 601
 602   return scm_call_n (proc, argv, nargs);
 603 }
 604
 605 SCM
 606 scm_apply_1 (SCM proc, SCM arg1, SCM args)
 607 {
 608   return scm_apply_0 (proc, scm_cons (arg1, args));
 609 }
 610
 611 SCM
 612 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
 613 {
 614   return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
 615 }
 616
 617 SCM
 618 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
 619 {
 620   return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
 621 }
 622
 623
 624 SCM
 625 scm_map (SCM proc, SCM arg1, SCM args)
 626 {
 627   static SCM var = SCM_BOOL_F;
 628
 629   if (scm_is_false (var))
 630     var = scm_private_variable (scm_the_root_module (),
 631                                 scm_from_latin1_symbol ("map"));
 632
 633   return scm_apply_0 (scm_variable_ref (var),
 634                       scm_cons (proc, scm_cons (arg1, args)));
 635 }
 636
 637 SCM
 638 scm_for_each (SCM proc, SCM arg1, SCM args)
 639 {
 640   static SCM var = SCM_BOOL_F;
 641
 642   if (scm_is_false (var))
 643     var = scm_private_variable (scm_the_root_module (),
 644                                 scm_from_latin1_symbol ("for-each"));
 645
 646   return scm_apply_0 (scm_variable_ref (var),
 647                       scm_cons (proc, scm_cons (arg1, args)));
 648 }
 649
 650
 651 static SCM
 652 scm_c_primitive_eval (SCM exp)
 653 {
 654   if (!SCM_EXPANDED_P (exp))
 655     exp = scm_call_1 (scm_current_module_transformer (), exp);
 656   return eval (scm_memoize_expression (exp), SCM_BOOL_F);
 657 }
 658
 659 static SCM var_primitive_eval;
 660 SCM
 661 scm_primitive_eval (SCM exp)
 662 {
 663   return scm_call_n (scm_variable_ref (var_primitive_eval),
 664                      &exp, 1);
 665 }
 666
 667
 668 /* Eval does not take the second arg optionally.  This is intentional
 669  * in order to be R5RS compatible, and to prepare for the new module
 670  * system, where we would like to make the choice of evaluation
 671  * environment explicit.  */
 672
 673 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
 674             (SCM exp, SCM module_or_state),
 675             "Evaluate @var{exp}, a list representing a Scheme expression,\n"
 676             "in the top-level environment specified by\n"
 677             "@var{module_or_state}.\n"
 678             "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
 679             "@var{module_or_state} is made the current module when\n"
 680             "it is a module, or the current dynamic state when it is\n"
 681             "a dynamic state."
 682             "Example: (eval '(+ 1 2) (interaction-environment))")
 683 #define FUNC_NAME s_scm_eval
 684 {
 685   SCM res;
 686
 687   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 688   if (scm_is_dynamic_state (module_or_state))
 689     scm_dynwind_current_dynamic_state (module_or_state);
 690   else if (scm_module_system_booted_p)
 691     {
 692       SCM_VALIDATE_MODULE (2, module_or_state);
 693       scm_dynwind_current_module (module_or_state);
 694     }
 695   /* otherwise if the module system isn't booted, ignore the module arg */
 696
 697   res = scm_primitive_eval (exp);
 698
 699   scm_dynwind_end ();
 700   return res;
 701 }
 702 #undef FUNC_NAME
 703
 704
 705 static SCM f_apply;
 706
 707 /* Apply a function to a list of arguments.
 708
 709    This function's interface is a bit wonly.  It takes two required
 710    arguments and a tail argument, as if it were:
 711
 712         (lambda (proc arg1 . args) ...)
 713
 714    Usually you want to use scm_apply_0 or one of its cousins.  */
 715
 716 SCM
 717 scm_apply (SCM proc, SCM arg1, SCM args)
 718 {
 719   return scm_apply_0 (proc,
 720                       scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
 721 }
 722
 723 static void
 724 prepare_boot_closure_env_for_apply (SCM proc, SCM args,
 725                                     SCM *out_body, SCM *out_env)
 726 {
 727   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 728   SCM env = BOOT_CLOSURE_ENV (proc);
 729   int i;
 730
 731   if (BOOT_CLOSURE_IS_FIXED (proc)
 732       || (BOOT_CLOSURE_IS_REST (proc)
 733           && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
 734     {
 735       if (SCM_UNLIKELY (scm_ilength (args) != nreq))
 736         scm_wrong_num_args (proc);
 737
 738       env = make_env (nreq, SCM_UNDEFINED, env);
 739       for (i = 0; i < nreq; args = CDR (args), i++)
 740         env_set (env, 0, i, CAR (args));
 741       *out_body = BOOT_CLOSURE_BODY (proc);
 742       *out_env = env;
 743     }
 744   else if (BOOT_CLOSURE_IS_REST (proc))
 745     {
 746       if (SCM_UNLIKELY (scm_ilength (args) < nreq))
 747         scm_wrong_num_args (proc);
 748
 749       env = make_env (nreq + 1, SCM_UNDEFINED, env);
 750       for (i = 0; i < nreq; args = CDR (args), i++)
 751         env_set (env, 0, i, CAR (args));
 752       env_set (env, 0, i++, args);
 753
 754       *out_body = BOOT_CLOSURE_BODY (proc);
 755       *out_env = env;
 756     }
 757   else
 758     {
 759       int i, argc, nreq, nopt, nenv;
 760       SCM body, rest, kw, inits, alt;
 761       SCM mx = BOOT_CLOSURE_CODE (proc);
 762
 763     loop:
 764       BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
 765
 766       argc = scm_ilength (args);
 767       if (argc < nreq)
 768         {
 769           if (scm_is_true (alt))
 770             {
 771               mx = alt;
 772               goto loop;
 773             }
 774           else
 775             scm_wrong_num_args (proc);
 776         }
 777       if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
 778         {
 779           if (scm_is_true (alt))
 780             {
 781               mx = alt;
 782               goto loop;
 783             }
 784           else
 785             scm_wrong_num_args (proc);
 786         }
 787       if (scm_is_true (kw) && scm_is_false (rest))
 788         {
 789           int npos = 0;
 790           SCM walk;
 791           for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++)
 792             if (npos >= nreq && scm_is_keyword (CAR (walk)))
 793               break;
 794
 795           if (npos > nreq + nopt)
 796             {
 797               /* Too many positional args and no rest arg.  */
 798               if (scm_is_true (alt))
 799                 {
 800                   mx = alt;
 801                   goto loop;
 802                 }
 803               else
 804                 scm_wrong_num_args (proc);
 805             }
 806         }
 807
 808       /* At this point we are committed to the chosen clause.  */
 809       nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits);
 810       env = make_env (nenv, SCM_UNDEFINED, env);
 811
 812       for (i = 0; i < nreq; i++, args = CDR (args))
 813         env_set (env, 0, i, CAR (args));
 814
 815       if (scm_is_false (kw))
 816         {
 817           /* Optional args (possibly), but no keyword args. */
 818           for (; i < argc && i < nreq + nopt;
 819                i++, args = CDR (args), inits = CDR (inits))
 820             env_set (env, 0, i, CAR (args));
 821
 822           for (; i < nreq + nopt; i++, inits = CDR (inits))
 823             env_set (env, 0, i, EVAL1 (CAR (inits), env));
 824
 825           if (scm_is_true (rest))
 826             env_set (env, 0, i++, args);
 827         }
 828       else
 829         {
 830           SCM aok;
 831
 832           aok = CAR (kw);
 833           kw = CDR (kw);
 834
 835           /* Optional args. As before, but stop at the first keyword. */
 836           for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
 837                i++, args = CDR (args), inits = CDR (inits))
 838             env_set (env, 0, i, CAR (args));
 839
 840           for (; i < nreq + nopt; i++, inits = CDR (inits))
 841             env_set (env, 0, i, EVAL1 (CAR (inits), env));
 842
 843           if (scm_is_true (rest))
 844             env_set (env, 0, i++, args);
 845
 846           /* Parse keyword args. */
 847           {
 848             int kw_start_idx = i;
 849             SCM walk;
 850
 851             if (scm_is_pair (args) && scm_is_pair (CDR (args)))
 852               for (; scm_is_pair (args) && scm_is_pair (CDR (args));
 853                    args = CDR (args))
 854                 {
 855                   SCM k = CAR (args), v = CADR (args);
 856                   if (!scm_is_keyword (k))
 857                     {
 858                       if (scm_is_true (rest))
 859                         continue;
 860                       else
 861                         break;
 862                     }
 863                   for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
 864                     if (scm_is_eq (k, CAAR (walk)))
 865                       {
 866                         env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
 867                         args = CDR (args);
 868                         break;
 869                       }
 870                   if (scm_is_null (walk) && scm_is_false (aok))
 871                     error_unrecognized_keyword (proc, k);
 872                 }
 873             if (scm_is_pair (args) && scm_is_false (rest))
 874               error_invalid_keyword (proc, CAR (args));
 875
 876             /* Now fill in unbound values, evaluating init expressions in their
 877                appropriate environment. */
 878             for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
 879               if (SCM_UNBNDP (env_ref (env, 0, i)))
 880                 env_set (env, 0, i, EVAL1 (CAR (inits), env));
 881           }
 882         }
 883
 884       if (!scm_is_null (inits))
 885         abort ();
 886       if (i != nenv)
 887         abort ();
 888
 889       *out_body = body;
 890       *out_env = env;
 891     }
 892 }
 893
 894 static void
 895 prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
 896                                    SCM exps, SCM *out_body, SCM *inout_env)
 897 {
 898   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 899   SCM new_env = BOOT_CLOSURE_ENV (proc);
 900   if ((BOOT_CLOSURE_IS_FIXED (proc)
 901        || (BOOT_CLOSURE_IS_REST (proc)
 902            && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
 903       && nreq == argc)
 904     {
 905       int i;
 906
 907       new_env = make_env (nreq, SCM_UNDEFINED, new_env);
 908       for (i = 0; i < nreq; exps = CDR (exps), i++)
 909         env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
 910
 911       *out_body = BOOT_CLOSURE_BODY (proc);
 912       *inout_env = new_env;
 913     }
 914   else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
 915     {
 916       SCM rest;
 917       int i;
 918
 919       new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
 920       for (i = 0; i < nreq; exps = CDR (exps), i++)
 921         env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
 922       for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
 923         rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
 924       env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
 925
 926       *out_body = BOOT_CLOSURE_BODY (proc);
 927       *inout_env = new_env;
 928     }
 929   else
 930     {
 931       SCM args = SCM_EOL;
 932       for (; scm_is_pair (exps); exps = CDR (exps))
 933         args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
 934       args = scm_reverse_x (args, SCM_UNDEFINED);
 935       prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
 936     }
 937 }
 938
 939 static SCM
 940 boot_closure_apply (SCM closure, SCM args)
 941 {
 942   SCM body, env;
 943   prepare_boot_closure_env_for_apply (closure, args, &body, &env);
 944   return eval (body, env);
 945 }
 946
 947 static int
 948 boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
 949 {
 950   SCM args;
 951   scm_puts_unlocked ("#<boot-closure ", port);
 952   scm_uintprint (SCM_UNPACK (closure), 16, port);
 953   scm_putc_unlocked (' ', port);
 954   args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
 955                         scm_from_latin1_symbol ("_"));
 956   if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
 957     args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
 958   /* FIXME: optionals and rests */
 959   scm_display (args, port);
 960   scm_putc_unlocked ('>', port);
 961   return 1;
 962 }
 963
 964 void
 965 scm_init_eval ()
 966 {
 967   SCM primitive_eval;
 968
 969   f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
 970
 971   scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
 972   scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
 973   scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
 974
 975   primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
 976                                      scm_c_primitive_eval);
 977   var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
 978                                    primitive_eval);
 979
 980 #include "libguile/eval.x"
 981 }
 982
 983 /*
 984   Local Variables:
 985   c-file-style: "gnu"
 986   End:
 987 */
 988