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,2014
   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,ninits,unbound,alt) \
 120   do { SCM fu = fu_;                                            \
 121     body = CAR (fu); fu = CDDR (fu);                            \
 122                                                                 \
 123     rest = kw = alt = SCM_BOOL_F;                               \
 124     unbound = SCM_BOOL_F;                                       \
 125     nopt = ninits = 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             ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu);      \
 136             unbound = CAR (fu); fu = CDR (fu);                  \
 137             alt = CAR (fu);                                     \
 138           }                                                     \
 139       }                                                         \
 140   } while (0)
 141 static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
 142                                                 SCM *out_body, SCM *out_env);
 143 static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
 144                                                SCM exps, SCM *out_body,
 145                                                SCM *inout_env);
 146
 147
 148 #define CAR(x)   SCM_CAR(x)
 149 #define CDR(x)   SCM_CDR(x)
 150 #define CAAR(x)  SCM_CAAR(x)
 151 #define CADR(x)  SCM_CADR(x)
 152 #define CDAR(x)  SCM_CDAR(x)
 153 #define CDDR(x)  SCM_CDDR(x)
 154 #define CADDR(x) SCM_CADDR(x)
 155 #define CDDDR(x) SCM_CDDDR(x)
 156
 157 #define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
 158 #define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
 159 #define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
 160
 161 static SCM
 162 make_env (int n, SCM init, SCM next)
 163 {
 164   SCM env = scm_c_make_vector (n + 1, init);
 165   VECTOR_SET (env, 0, next);
 166   return env;
 167 }
 168
 169 static SCM
 170 next_rib (SCM env)
 171 {
 172   return VECTOR_REF (env, 0);
 173 }
 174
 175 static SCM
 176 env_tail (SCM env)
 177 {
 178   while (SCM_I_IS_VECTOR (env))
 179     env = next_rib (env);
 180   return env;
 181 }
 182
 183 static SCM
 184 env_ref (SCM env, int depth, int width)
 185 {
 186   while (depth--)
 187     env = next_rib (env);
 188   return VECTOR_REF (env, width + 1);
 189 }
 190
 191 static void
 192 env_set (SCM env, int depth, int width, SCM val)
 193 {
 194   while (depth--)
 195     env = next_rib (env);
 196   VECTOR_SET (env, width + 1, val);
 197 }
 198
 199
 200 static void error_invalid_keyword (SCM proc, SCM obj)
 201 {
 202   scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
 203                  scm_from_locale_string ("Invalid keyword"), SCM_EOL,
 204                  scm_list_1 (obj));
 205 }
 206
 207 static void error_unrecognized_keyword (SCM proc, SCM kw)
 208 {
 209   scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
 210                  scm_from_locale_string ("Unrecognized keyword"), SCM_EOL,
 211                  scm_list_1 (kw));
 212 }
 213
 214
 215 /* Multiple values truncation.  */
 216 static SCM
 217 truncate_values (SCM x)
 218 {
 219   if (SCM_LIKELY (!SCM_VALUESP (x)))
 220     return x;
 221   else
 222     {
 223       SCM l = scm_struct_ref (x, SCM_INUM0);
 224       if (SCM_LIKELY (scm_is_pair (l)))
 225         return scm_car (l);
 226       else
 227         {
 228           scm_ithrow (scm_from_latin1_symbol ("vm-run"),
 229                       scm_list_3 (scm_from_latin1_symbol ("vm-run"),
 230                                   scm_from_locale_string
 231                                   ("Too few values returned to continuation"),
 232                                   SCM_EOL),
 233                       1);
 234           /* Not reached.  */
 235           return SCM_BOOL_F;
 236         }
 237     }
 238 }
 239 #define EVAL1(x, env) (truncate_values (eval ((x), (env))))
 240
 241 static SCM
 242 eval (SCM x, SCM env)
 243 {
 244   SCM mx;
 245   SCM proc = SCM_UNDEFINED, args = SCM_EOL;
 246   unsigned int argc;
 247
 248  loop:
 249   SCM_TICK;
 250
 251   mx = SCM_MEMOIZED_ARGS (x);
 252   switch (SCM_I_INUM (SCM_CAR (x)))
 253     {
 254     case SCM_M_SEQ:
 255       eval (CAR (mx), env);
 256       x = CDR (mx);
 257       goto loop;
 258
 259     case SCM_M_IF:
 260       if (scm_is_true (EVAL1 (CAR (mx), env)))
 261         x = CADR (mx);
 262       else
 263         x = CDDR (mx);
 264       goto loop;
 265
 266     case SCM_M_LET:
 267       {
 268         SCM inits = CAR (mx);
 269         SCM new_env;
 270         int i;
 271
 272         new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
 273         for (i = 0; i < VECTOR_LENGTH (inits); i++)
 274           env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
 275         env = new_env;
 276         x = CDR (mx);
 277         goto loop;
 278       }
 279
 280     case SCM_M_LAMBDA:
 281       RETURN_BOOT_CLOSURE (mx, env);
 282
 283     case SCM_M_CAPTURE_ENV:
 284       {
 285         SCM locs = CAR (mx);
 286         SCM new_env;
 287         int i;
 288
 289         new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
 290         for (i = 0; i < VECTOR_LENGTH (locs); i++)
 291           {
 292             SCM loc = VECTOR_REF (locs, i);
 293             int depth, width;
 294
 295             depth = SCM_I_INUM (CAR (loc));
 296             width = SCM_I_INUM (CDR (loc));
 297             env_set (new_env, 0, i, env_ref (env, depth, width));
 298           }
 299
 300         env = new_env;
 301         x = CDR (mx);
 302         goto loop;
 303       }
 304
 305     case SCM_M_QUOTE:
 306       return mx;
 307
 308     case SCM_M_CAPTURE_MODULE:
 309       return eval (mx, scm_current_module ());
 310
 311     case SCM_M_APPLY:
 312       /* Evaluate the procedure to be applied.  */
 313       proc = EVAL1 (CAR (mx), env);
 314       /* Evaluate the argument holding the list of arguments */
 315       args = EVAL1 (CADR (mx), env);
 316
 317     apply_proc:
 318       /* Go here to tail-apply a procedure.  PROC is the procedure and
 319        * ARGS is the list of arguments. */
 320       if (BOOT_CLOSURE_P (proc))
 321         {
 322           prepare_boot_closure_env_for_apply (proc, args, &x, &env);
 323           goto loop;
 324         }
 325       else
 326         return scm_apply_0 (proc, args);
 327
 328     case SCM_M_CALL:
 329       /* Evaluate the procedure to be applied.  */
 330       proc = EVAL1 (CAR (mx), env);
 331       argc = SCM_I_INUM (CADR (mx));
 332       mx = CDDR (mx);
 333
 334       if (BOOT_CLOSURE_P (proc))
 335         {
 336           prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
 337           goto loop;
 338         }
 339       else
 340         {
 341           SCM *argv;
 342           unsigned int i;
 343
 344           argv = alloca (argc * sizeof (SCM));
 345           for (i = 0; i < argc; i++, mx = CDR (mx))
 346             argv[i] = EVAL1 (CAR (mx), env);
 347
 348           return scm_call_n (proc, argv, argc);
 349         }
 350
 351     case SCM_M_CONT:
 352       return scm_i_call_with_current_continuation (EVAL1 (mx, env));
 353
 354     case SCM_M_CALL_WITH_VALUES:
 355       {
 356         SCM producer;
 357         SCM v;
 358
 359         producer = EVAL1 (CAR (mx), env);
 360         /* `proc' is the consumer.  */
 361         proc = EVAL1 (CDR (mx), env);
 362         v = scm_call_0 (producer);
 363         if (SCM_VALUESP (v))
 364           args = scm_struct_ref (v, SCM_INUM0);
 365         else
 366           args = scm_list_1 (v);
 367         goto apply_proc;
 368       }
 369
 370     case SCM_M_LEXICAL_REF:
 371       {
 372         SCM pos;
 373         int depth, width;
 374
 375         pos = mx;
 376         depth = SCM_I_INUM (CAR (pos));
 377         width = SCM_I_INUM (CDR (pos));
 378
 379         return env_ref (env, depth, width);
 380       }
 381
 382     case SCM_M_LEXICAL_SET:
 383       {
 384         SCM pos;
 385         int depth, width;
 386         SCM val = EVAL1 (CDR (mx), env);
 387
 388         pos = CAR (mx);
 389         depth = SCM_I_INUM (CAR (pos));
 390         width = SCM_I_INUM (CDR (pos));
 391
 392         env_set (env, depth, width, val);
 393
 394         return SCM_UNSPECIFIED;
 395       }
 396
 397     case SCM_M_BOX_REF:
 398       {
 399         SCM box = mx;
 400
 401         return scm_variable_ref (EVAL1 (box, env));
 402       }
 403
 404     case SCM_M_BOX_SET:
 405       {
 406         SCM box = CAR (mx), val = CDR (mx);
 407
 408         return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
 409       }
 410
 411     case SCM_M_RESOLVE:
 412       if (SCM_VARIABLEP (mx))
 413         return mx;
 414       else
 415         {
 416           SCM var;
 417
 418           var = scm_sys_resolve_variable (mx, env_tail (env));
 419           scm_set_cdr_x (x, var);
 420
 421           return var;
 422         }
 423
 424     case SCM_M_CALL_WITH_PROMPT:
 425       {
 426         struct scm_vm *vp;
 427         SCM k, res;
 428         scm_i_jmp_buf registers;
 429         /* We need the handler after nonlocal return to the setjmp, so
 430            make sure it is volatile.  */
 431         volatile SCM handler;
 432
 433         k = EVAL1 (CAR (mx), env);
 434         handler = EVAL1 (CDDR (mx), env);
 435         vp = scm_the_vm ();
 436
 437         /* Push the prompt onto the dynamic stack. */
 438         scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
 439                                   SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
 440                                   | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
 441                                   k,
 442                                   vp->fp - vp->stack_base,
 443                                   vp->sp - vp->stack_base,
 444                                   vp->ip,
 445                                   &registers);
 446
 447         if (SCM_I_SETJMP (registers))
 448           {
 449             /* The prompt exited nonlocally. */
 450             scm_gc_after_nonlocal_exit ();
 451             proc = handler;
 452             vp = scm_the_vm ();
 453             args = scm_i_prompt_pop_abort_args_x (vp);
 454             goto apply_proc;
 455           }
 456
 457         res = scm_call_0 (eval (CADR (mx), env));
 458         scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
 459         return res;
 460       }
 461
 462     default:
 463       abort ();
 464     }
 465 }
 466
 467 \f
 468
 469 /* Simple procedure calls
 470  */
 471
 472 SCM
 473 scm_call_0 (SCM proc)
 474 {
 475   return scm_call_n (proc, NULL, 0);
 476 }
 477
 478 SCM
 479 scm_call_1 (SCM proc, SCM arg1)
 480 {
 481   return scm_call_n (proc, &arg1, 1);
 482 }
 483
 484 SCM
 485 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
 486 {
 487   SCM args[] = { arg1, arg2 };
 488   return scm_call_n (proc, args, 2);
 489 }
 490
 491 SCM
 492 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
 493 {
 494   SCM args[] = { arg1, arg2, arg3 };
 495   return scm_call_n (proc, args, 3);
 496 }
 497
 498 SCM
 499 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 500 {
 501   SCM args[] = { arg1, arg2, arg3, arg4 };
 502   return scm_call_n (proc, args, 4);
 503 }
 504
 505 SCM
 506 scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
 507 {
 508   SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
 509   return scm_call_n (proc, args, 5);
 510 }
 511
 512 SCM
 513 scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 514             SCM arg6)
 515 {
 516   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
 517   return scm_call_n (proc, args, 6);
 518 }
 519
 520 SCM
 521 scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 522             SCM arg6, SCM arg7)
 523 {
 524   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
 525   return scm_call_n (proc, args, 7);
 526 }
 527
 528 SCM
 529 scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 530             SCM arg6, SCM arg7, SCM arg8)
 531 {
 532   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
 533   return scm_call_n (proc, args, 8);
 534 }
 535
 536 SCM
 537 scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 538             SCM arg6, SCM arg7, SCM arg8, SCM arg9)
 539 {
 540   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
 541   return scm_call_n (proc, args, 9);
 542 }
 543
 544 /* scm_call_n defined in vm.c */
 545
 546 SCM
 547 scm_call (SCM proc, ...)
 548 {
 549   va_list argp;
 550   SCM *argv = NULL;
 551   size_t i, nargs = 0;
 552
 553   va_start (argp, proc);
 554   while (!SCM_UNBNDP (va_arg (argp, SCM)))
 555     nargs++;
 556   va_end (argp);
 557
 558   argv = alloca (nargs * sizeof (SCM));
 559   va_start (argp, proc);
 560   for (i = 0; i < nargs; i++)
 561     argv[i] = va_arg (argp, SCM);
 562   va_end (argp);
 563
 564   return scm_call_n (proc, argv, nargs);
 565 }
 566
 567 /* Simple procedure applies
 568  */
 569
 570 SCM
 571 scm_apply_0 (SCM proc, SCM args)
 572 {
 573   SCM *argv;
 574   int i, nargs;
 575
 576   nargs = scm_ilength (args);
 577   if (SCM_UNLIKELY (nargs < 0))
 578     scm_wrong_type_arg_msg ("apply", 2, args, "list");
 579
 580   /* FIXME: Use vm_builtin_apply instead of alloca.  */
 581   argv = alloca (nargs * sizeof(SCM));
 582   for (i = 0; i < nargs; i++)
 583     {
 584       argv[i] = SCM_CAR (args);
 585       args = SCM_CDR (args);
 586     }
 587
 588   return scm_call_n (proc, argv, nargs);
 589 }
 590
 591 SCM
 592 scm_apply_1 (SCM proc, SCM arg1, SCM args)
 593 {
 594   return scm_apply_0 (proc, scm_cons (arg1, args));
 595 }
 596
 597 SCM
 598 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
 599 {
 600   return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
 601 }
 602
 603 SCM
 604 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
 605 {
 606   return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
 607 }
 608
 609 static SCM map_var, for_each_var;
 610
 611 static void init_map_var (void)
 612 {
 613   map_var = scm_private_variable (scm_the_root_module (),
 614                                   scm_from_latin1_symbol ("map"));
 615 }
 616
 617 static void init_for_each_var (void)
 618 {
 619   for_each_var = scm_private_variable (scm_the_root_module (),
 620                                        scm_from_latin1_symbol ("for-each"));
 621 }
 622
 623 SCM
 624 scm_map (SCM proc, SCM arg1, SCM args)
 625 {
 626   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 627   scm_i_pthread_once (&once, init_map_var);
 628
 629   return scm_apply_0 (scm_variable_ref (map_var),
 630                       scm_cons (proc, scm_cons (arg1, args)));
 631 }
 632
 633 SCM
 634 scm_for_each (SCM proc, SCM arg1, SCM args)
 635 {
 636   static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
 637   scm_i_pthread_once (&once, init_for_each_var);
 638
 639   return scm_apply_0 (scm_variable_ref (for_each_var),
 640                       scm_cons (proc, scm_cons (arg1, args)));
 641 }
 642
 643
 644 static SCM
 645 scm_c_primitive_eval (SCM exp)
 646 {
 647   if (!SCM_EXPANDED_P (exp))
 648     exp = scm_call_1 (scm_current_module_transformer (), exp);
 649   return eval (scm_memoize_expression (exp), SCM_BOOL_F);
 650 }
 651
 652 static SCM var_primitive_eval;
 653 SCM
 654 scm_primitive_eval (SCM exp)
 655 {
 656   return scm_call_n (scm_variable_ref (var_primitive_eval),
 657                      &exp, 1);
 658 }
 659
 660
 661 /* Eval does not take the second arg optionally.  This is intentional
 662  * in order to be R5RS compatible, and to prepare for the new module
 663  * system, where we would like to make the choice of evaluation
 664  * environment explicit.  */
 665
 666 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
 667             (SCM exp, SCM module_or_state),
 668             "Evaluate @var{exp}, a list representing a Scheme expression,\n"
 669             "in the top-level environment specified by\n"
 670             "@var{module_or_state}.\n"
 671             "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
 672             "@var{module_or_state} is made the current module when\n"
 673             "it is a module, or the current dynamic state when it is\n"
 674             "a dynamic state."
 675             "Example: (eval '(+ 1 2) (interaction-environment))")
 676 #define FUNC_NAME s_scm_eval
 677 {
 678   SCM res;
 679
 680   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 681   if (scm_is_dynamic_state (module_or_state))
 682     scm_dynwind_current_dynamic_state (module_or_state);
 683   else if (scm_module_system_booted_p)
 684     {
 685       SCM_VALIDATE_MODULE (2, module_or_state);
 686       scm_dynwind_current_module (module_or_state);
 687     }
 688   /* otherwise if the module system isn't booted, ignore the module arg */
 689
 690   res = scm_primitive_eval (exp);
 691
 692   scm_dynwind_end ();
 693   return res;
 694 }
 695 #undef FUNC_NAME
 696
 697
 698 static SCM f_apply;
 699
 700 /* Apply a function to a list of arguments.
 701
 702    This function's interface is a bit wonly.  It takes two required
 703    arguments and a tail argument, as if it were:
 704
 705         (lambda (proc arg1 . args) ...)
 706
 707    Usually you want to use scm_apply_0 or one of its cousins.  */
 708
 709 SCM
 710 scm_apply (SCM proc, SCM arg1, SCM args)
 711 {
 712   return scm_apply_0 (proc,
 713                       scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
 714 }
 715
 716 static void
 717 prepare_boot_closure_env_for_apply (SCM proc, SCM args,
 718                                     SCM *out_body, SCM *out_env)
 719 {
 720   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 721   SCM env = BOOT_CLOSURE_ENV (proc);
 722   int i;
 723
 724   if (BOOT_CLOSURE_IS_FIXED (proc)
 725       || (BOOT_CLOSURE_IS_REST (proc)
 726           && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
 727     {
 728       if (SCM_UNLIKELY (scm_ilength (args) != nreq))
 729         scm_wrong_num_args (proc);
 730
 731       env = make_env (nreq, SCM_UNDEFINED, env);
 732       for (i = 0; i < nreq; args = CDR (args), i++)
 733         env_set (env, 0, i, CAR (args));
 734       *out_body = BOOT_CLOSURE_BODY (proc);
 735       *out_env = env;
 736     }
 737   else if (BOOT_CLOSURE_IS_REST (proc))
 738     {
 739       if (SCM_UNLIKELY (scm_ilength (args) < nreq))
 740         scm_wrong_num_args (proc);
 741
 742       env = make_env (nreq + 1, SCM_UNDEFINED, env);
 743       for (i = 0; i < nreq; args = CDR (args), i++)
 744         env_set (env, 0, i, CAR (args));
 745       env_set (env, 0, i++, args);
 746
 747       *out_body = BOOT_CLOSURE_BODY (proc);
 748       *out_env = env;
 749     }
 750   else
 751     {
 752       int i, argc, nreq, nopt, ninits, nenv;
 753       SCM body, rest, kw, unbound, alt;
 754       SCM mx = BOOT_CLOSURE_CODE (proc);
 755
 756     loop:
 757       BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
 758                                ninits, unbound, alt);
 759
 760       argc = scm_ilength (args);
 761       if (argc < nreq)
 762         {
 763           if (scm_is_true (alt))
 764             {
 765               mx = alt;
 766               goto loop;
 767             }
 768           else
 769             scm_wrong_num_args (proc);
 770         }
 771       if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
 772         {
 773           if (scm_is_true (alt))
 774             {
 775               mx = alt;
 776               goto loop;
 777             }
 778           else
 779             scm_wrong_num_args (proc);
 780         }
 781       if (scm_is_true (kw) && scm_is_false (rest))
 782         {
 783           int npos = 0;
 784           SCM walk;
 785           for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++)
 786             if (npos >= nreq && scm_is_keyword (CAR (walk)))
 787               break;
 788
 789           if (npos > nreq + nopt)
 790             {
 791               /* Too many positional args and no rest arg.  */
 792               if (scm_is_true (alt))
 793                 {
 794                   mx = alt;
 795                   goto loop;
 796                 }
 797               else
 798                 scm_wrong_num_args (proc);
 799             }
 800         }
 801
 802       /* At this point we are committed to the chosen clause.  */
 803       nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits;
 804       env = make_env (nenv, unbound, env);
 805
 806       for (i = 0; i < nreq; i++, args = CDR (args))
 807         env_set (env, 0, i, CAR (args));
 808
 809       if (scm_is_false (kw))
 810         {
 811           /* Optional args (possibly), but no keyword args. */
 812           for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
 813             env_set (env, 0, i, CAR (args));
 814           if (scm_is_true (rest))
 815             env_set (env, 0, nreq + nopt, args);
 816         }
 817       else
 818         {
 819           SCM aok;
 820
 821           aok = CAR (kw);
 822           kw = CDR (kw);
 823
 824           /* Optional args. As before, but stop at the first keyword. */
 825           for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
 826                i++, args = CDR (args))
 827             env_set (env, 0, i, CAR (args));
 828           if (scm_is_true (rest))
 829             env_set (env, 0, nreq + nopt, args);
 830
 831           /* Parse keyword args. */
 832           {
 833             SCM walk;
 834
 835             if (scm_is_pair (args) && scm_is_pair (CDR (args)))
 836               for (; scm_is_pair (args) && scm_is_pair (CDR (args));
 837                    args = CDR (args))
 838                 {
 839                   SCM k = CAR (args), v = CADR (args);
 840                   if (!scm_is_keyword (k))
 841                     {
 842                       if (scm_is_true (rest))
 843                         continue;
 844                       else
 845                         break;
 846                     }
 847                   for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
 848                     if (scm_is_eq (k, CAAR (walk)))
 849                       {
 850                         env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
 851                         args = CDR (args);
 852                         break;
 853                       }
 854                   if (scm_is_null (walk) && scm_is_false (aok))
 855                     error_unrecognized_keyword (proc, k);
 856                 }
 857             if (scm_is_pair (args) && scm_is_false (rest))
 858               error_invalid_keyword (proc, CAR (args));
 859           }
 860         }
 861
 862       *out_body = body;
 863       *out_env = env;
 864     }
 865 }
 866
 867 static void
 868 prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
 869                                    SCM exps, SCM *out_body, SCM *inout_env)
 870 {
 871   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 872   SCM new_env = BOOT_CLOSURE_ENV (proc);
 873   if ((BOOT_CLOSURE_IS_FIXED (proc)
 874        || (BOOT_CLOSURE_IS_REST (proc)
 875            && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
 876       && nreq == argc)
 877     {
 878       int i;
 879
 880       new_env = make_env (nreq, SCM_UNDEFINED, new_env);
 881       for (i = 0; i < nreq; exps = CDR (exps), i++)
 882         env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
 883
 884       *out_body = BOOT_CLOSURE_BODY (proc);
 885       *inout_env = new_env;
 886     }
 887   else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
 888     {
 889       SCM rest;
 890       int i;
 891
 892       new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
 893       for (i = 0; i < nreq; exps = CDR (exps), i++)
 894         env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
 895       for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
 896         rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
 897       env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
 898
 899       *out_body = BOOT_CLOSURE_BODY (proc);
 900       *inout_env = new_env;
 901     }
 902   else
 903     {
 904       SCM args = SCM_EOL;
 905       for (; scm_is_pair (exps); exps = CDR (exps))
 906         args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
 907       args = scm_reverse_x (args, SCM_UNDEFINED);
 908       prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
 909     }
 910 }
 911
 912 static SCM
 913 boot_closure_apply (SCM closure, SCM args)
 914 {
 915   SCM body, env;
 916   prepare_boot_closure_env_for_apply (closure, args, &body, &env);
 917   return eval (body, env);
 918 }
 919
 920 static int
 921 boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
 922 {
 923   SCM args;
 924   scm_puts_unlocked ("#<boot-closure ", port);
 925   scm_uintprint (SCM_UNPACK (closure), 16, port);
 926   scm_putc_unlocked (' ', port);
 927   args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
 928                         scm_from_latin1_symbol ("_"));
 929   if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
 930     args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
 931   /* FIXME: optionals and rests */
 932   scm_display (args, port);
 933   scm_putc_unlocked ('>', port);
 934   return 1;
 935 }
 936
 937 void
 938 scm_init_eval ()
 939 {
 940   SCM primitive_eval;
 941
 942   f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
 943
 944   scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
 945   scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
 946   scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
 947
 948   primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
 949                                      scm_c_primitive_eval);
 950   var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
 951                                    primitive_eval);
 952
 953 #include "libguile/eval.x"
 954 }
 955
 956 /*
 957   Local Variables:
 958   c-file-style: "gnu"
 959   End:
 960 */
 961