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