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_c_vm_run (scm_the_vm (), 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         SCM vm, k, res;
 442         scm_i_jmp_buf registers;
 443         /* We need the handler after nonlocal return to the setjmp, so
 444            make sure it is volatile.  */
 445         volatile SCM handler;
 446
 447         k = EVAL1 (CAR (mx), env);
 448         handler = EVAL1 (CDDR (mx), env);
 449         vm = scm_the_vm ();
 450
 451         /* Push the prompt onto the dynamic stack. */
 452         scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
 453                                   SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
 454                                   | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
 455                                   k,
 456                                   SCM_VM_DATA (vm)->fp,
 457                                   SCM_VM_DATA (vm)->sp,
 458                                   SCM_VM_DATA (vm)->ip,
 459                                   &registers);
 460
 461         if (SCM_I_SETJMP (registers))
 462           {
 463             /* The prompt exited nonlocally. */
 464             proc = handler;
 465             args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
 466             goto apply_proc;
 467           }
 468
 469         res = scm_call_0 (eval (CADR (mx), env));
 470         scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
 471         return res;
 472       }
 473
 474     default:
 475       abort ();
 476     }
 477 }
 478
 479 \f
 480
 481 /* Simple procedure calls
 482  */
 483
 484 SCM
 485 scm_call_0 (SCM proc)
 486 {
 487   return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
 488 }
 489
 490 SCM
 491 scm_call_1 (SCM proc, SCM arg1)
 492 {
 493   return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
 494 }
 495
 496 SCM
 497 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
 498 {
 499   SCM args[] = { arg1, arg2 };
 500   return scm_c_vm_run (scm_the_vm (), proc, args, 2);
 501 }
 502
 503 SCM
 504 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
 505 {
 506   SCM args[] = { arg1, arg2, arg3 };
 507   return scm_c_vm_run (scm_the_vm (), proc, args, 3);
 508 }
 509
 510 SCM
 511 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 512 {
 513   SCM args[] = { arg1, arg2, arg3, arg4 };
 514   return scm_c_vm_run (scm_the_vm (), proc, args, 4);
 515 }
 516
 517 SCM
 518 scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
 519 {
 520   SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
 521   return scm_c_vm_run (scm_the_vm (), proc, args, 5);
 522 }
 523
 524 SCM
 525 scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 526             SCM arg6)
 527 {
 528   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
 529   return scm_c_vm_run (scm_the_vm (), proc, args, 6);
 530 }
 531
 532 SCM
 533 scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 534             SCM arg6, SCM arg7)
 535 {
 536   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
 537   return scm_c_vm_run (scm_the_vm (), proc, args, 7);
 538 }
 539
 540 SCM
 541 scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 542             SCM arg6, SCM arg7, SCM arg8)
 543 {
 544   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
 545   return scm_c_vm_run (scm_the_vm (), proc, args, 8);
 546 }
 547
 548 SCM
 549 scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
 550             SCM arg6, SCM arg7, SCM arg8, SCM arg9)
 551 {
 552   SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
 553   return scm_c_vm_run (scm_the_vm (), proc, args, 9);
 554 }
 555
 556 SCM
 557 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 558 {
 559   return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
 560 }
 561
 562 SCM
 563 scm_call (SCM proc, ...)
 564 {
 565   va_list argp;
 566   SCM *argv = NULL;
 567   size_t i, nargs = 0;
 568
 569   va_start (argp, proc);
 570   while (!SCM_UNBNDP (va_arg (argp, SCM)))
 571     nargs++;
 572   va_end (argp);
 573
 574   argv = alloca (nargs * sizeof (SCM));
 575   va_start (argp, proc);
 576   for (i = 0; i < nargs; i++)
 577     argv[i] = va_arg (argp, SCM);
 578   va_end (argp);
 579
 580   return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
 581 }
 582
 583 /* Simple procedure applies
 584  */
 585
 586 SCM
 587 scm_apply_0 (SCM proc, SCM args)
 588 {
 589   SCM *argv;
 590   int i, nargs;
 591
 592   nargs = scm_ilength (args);
 593   if (SCM_UNLIKELY (nargs < 0))
 594     scm_wrong_type_arg_msg ("apply", 2, args, "list");
 595
 596   /* FIXME: Use vm_builtin_apply instead of alloca.  */
 597   argv = alloca (nargs * sizeof(SCM));
 598   for (i = 0; i < nargs; i++)
 599     {
 600       argv[i] = SCM_CAR (args);
 601       args = SCM_CDR (args);
 602     }
 603
 604   return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
 605 }
 606
 607 SCM
 608 scm_apply_1 (SCM proc, SCM arg1, SCM args)
 609 {
 610   return scm_apply_0 (proc, scm_cons (arg1, args));
 611 }
 612
 613 SCM
 614 scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
 615 {
 616   return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
 617 }
 618
 619 SCM
 620 scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
 621 {
 622   return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
 623 }
 624
 625
 626 SCM
 627 scm_map (SCM proc, SCM arg1, SCM args)
 628 {
 629   static SCM var = SCM_BOOL_F;
 630
 631   if (scm_is_false (var))
 632     var = scm_private_variable (scm_the_root_module (),
 633                                 scm_from_latin1_symbol ("map"));
 634
 635   return scm_apply_0 (scm_variable_ref (var),
 636                       scm_cons (proc, scm_cons (arg1, args)));
 637 }
 638
 639 SCM
 640 scm_for_each (SCM proc, SCM arg1, SCM args)
 641 {
 642   static SCM var = SCM_BOOL_F;
 643
 644   if (scm_is_false (var))
 645     var = scm_private_variable (scm_the_root_module (),
 646                                 scm_from_latin1_symbol ("for-each"));
 647
 648   return scm_apply_0 (scm_variable_ref (var),
 649                       scm_cons (proc, scm_cons (arg1, args)));
 650 }
 651
 652
 653 static SCM
 654 scm_c_primitive_eval (SCM exp)
 655 {
 656   if (!SCM_EXPANDED_P (exp))
 657     exp = scm_call_1 (scm_current_module_transformer (), exp);
 658   return eval (scm_memoize_expression (exp), SCM_BOOL_F);
 659 }
 660
 661 static SCM var_primitive_eval;
 662 SCM
 663 scm_primitive_eval (SCM exp)
 664 {
 665   return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
 666                        &exp, 1);
 667 }
 668
 669
 670 /* Eval does not take the second arg optionally.  This is intentional
 671  * in order to be R5RS compatible, and to prepare for the new module
 672  * system, where we would like to make the choice of evaluation
 673  * environment explicit.  */
 674
 675 SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
 676             (SCM exp, SCM module_or_state),
 677             "Evaluate @var{exp}, a list representing a Scheme expression,\n"
 678             "in the top-level environment specified by\n"
 679             "@var{module_or_state}.\n"
 680             "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
 681             "@var{module_or_state} is made the current module when\n"
 682             "it is a module, or the current dynamic state when it is\n"
 683             "a dynamic state."
 684             "Example: (eval '(+ 1 2) (interaction-environment))")
 685 #define FUNC_NAME s_scm_eval
 686 {
 687   SCM res;
 688
 689   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 690   if (scm_is_dynamic_state (module_or_state))
 691     scm_dynwind_current_dynamic_state (module_or_state);
 692   else if (scm_module_system_booted_p)
 693     {
 694       SCM_VALIDATE_MODULE (2, module_or_state);
 695       scm_dynwind_current_module (module_or_state);
 696     }
 697   /* otherwise if the module system isn't booted, ignore the module arg */
 698
 699   res = scm_primitive_eval (exp);
 700
 701   scm_dynwind_end ();
 702   return res;
 703 }
 704 #undef FUNC_NAME
 705
 706
 707 static SCM f_apply;
 708
 709 /* Apply a function to a list of arguments.
 710
 711    This function's interface is a bit wonly.  It takes two required
 712    arguments and a tail argument, as if it were:
 713
 714         (lambda (proc arg1 . args) ...)
 715
 716    Usually you want to use scm_apply_0 or one of its cousins.  */
 717
 718 SCM
 719 scm_apply (SCM proc, SCM arg1, SCM args)
 720 {
 721   return scm_apply_0 (proc,
 722                       scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
 723 }
 724
 725 static void
 726 prepare_boot_closure_env_for_apply (SCM proc, SCM args,
 727                                     SCM *out_body, SCM *out_env)
 728 {
 729   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 730   SCM env = BOOT_CLOSURE_ENV (proc);
 731   int i;
 732
 733   if (BOOT_CLOSURE_IS_FIXED (proc)
 734       || (BOOT_CLOSURE_IS_REST (proc)
 735           && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
 736     {
 737       if (SCM_UNLIKELY (scm_ilength (args) != nreq))
 738         scm_wrong_num_args (proc);
 739
 740       env = make_env (nreq, SCM_UNDEFINED, env);
 741       for (i = 0; i < nreq; args = CDR (args), i++)
 742         env_set (env, 0, i, CAR (args));
 743       *out_body = BOOT_CLOSURE_BODY (proc);
 744       *out_env = env;
 745     }
 746   else if (BOOT_CLOSURE_IS_REST (proc))
 747     {
 748       if (SCM_UNLIKELY (scm_ilength (args) < nreq))
 749         scm_wrong_num_args (proc);
 750
 751       env = make_env (nreq + 1, SCM_UNDEFINED, env);
 752       for (i = 0; i < nreq; args = CDR (args), i++)
 753         env_set (env, 0, i, CAR (args));
 754       env_set (env, 0, i++, args);
 755
 756       *out_body = BOOT_CLOSURE_BODY (proc);
 757       *out_env = env;
 758     }
 759   else
 760     {
 761       int i, argc, nreq, nopt, nenv;
 762       SCM body, rest, kw, inits, alt;
 763       SCM mx = BOOT_CLOSURE_CODE (proc);
 764
 765     loop:
 766       BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
 767
 768       argc = scm_ilength (args);
 769       if (argc < nreq)
 770         {
 771           if (scm_is_true (alt))
 772             {
 773               mx = alt;
 774               goto loop;
 775             }
 776           else
 777             scm_wrong_num_args (proc);
 778         }
 779       if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest))
 780         {
 781           if (scm_is_true (alt))
 782             {
 783               mx = alt;
 784               goto loop;
 785             }
 786           else
 787             scm_wrong_num_args (proc);
 788         }
 789       if (scm_is_true (kw) && scm_is_false (rest))
 790         {
 791           int npos = 0;
 792           SCM walk;
 793           for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++)
 794             if (npos >= nreq && scm_is_keyword (CAR (walk)))
 795               break;
 796
 797           if (npos > nreq + nopt)
 798             {
 799               /* Too many positional args and no rest arg.  */
 800               if (scm_is_true (alt))
 801                 {
 802                   mx = alt;
 803                   goto loop;
 804                 }
 805               else
 806                 scm_wrong_num_args (proc);
 807             }
 808         }
 809
 810       /* At this point we are committed to the chosen clause.  */
 811       nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits);
 812       env = make_env (nenv, SCM_UNDEFINED, env);
 813
 814       for (i = 0; i < nreq; i++, args = CDR (args))
 815         env_set (env, 0, i, CAR (args));
 816
 817       if (scm_is_false (kw))
 818         {
 819           /* Optional args (possibly), but no keyword args. */
 820           for (; i < argc && i < nreq + nopt;
 821                i++, args = CDR (args), inits = CDR (inits))
 822             env_set (env, 0, i, CAR (args));
 823
 824           for (; i < nreq + nopt; i++, inits = CDR (inits))
 825             env_set (env, 0, i, EVAL1 (CAR (inits), env));
 826
 827           if (scm_is_true (rest))
 828             env_set (env, 0, i++, args);
 829         }
 830       else
 831         {
 832           SCM aok;
 833
 834           aok = CAR (kw);
 835           kw = CDR (kw);
 836
 837           /* Optional args. As before, but stop at the first keyword. */
 838           for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
 839                i++, args = CDR (args), inits = CDR (inits))
 840             env_set (env, 0, i, CAR (args));
 841
 842           for (; i < nreq + nopt; i++, inits = CDR (inits))
 843             env_set (env, 0, i, EVAL1 (CAR (inits), env));
 844
 845           if (scm_is_true (rest))
 846             env_set (env, 0, i++, args);
 847
 848           /* Parse keyword args. */
 849           {
 850             int kw_start_idx = i;
 851             SCM walk;
 852
 853             if (scm_is_pair (args) && scm_is_pair (CDR (args)))
 854               for (; scm_is_pair (args) && scm_is_pair (CDR (args));
 855                    args = CDR (args))
 856                 {
 857                   SCM k = CAR (args), v = CADR (args);
 858                   if (!scm_is_keyword (k))
 859                     {
 860                       if (scm_is_true (rest))
 861                         continue;
 862                       else
 863                         break;
 864                     }
 865                   for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
 866                     if (scm_is_eq (k, CAAR (walk)))
 867                       {
 868                         env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
 869                         args = CDR (args);
 870                         break;
 871                       }
 872                   if (scm_is_null (walk) && scm_is_false (aok))
 873                     error_unrecognized_keyword (proc, k);
 874                 }
 875             if (scm_is_pair (args) && scm_is_false (rest))
 876               error_invalid_keyword (proc, CAR (args));
 877
 878             /* Now fill in unbound values, evaluating init expressions in their
 879                appropriate environment. */
 880             for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
 881               if (SCM_UNBNDP (env_ref (env, 0, i)))
 882                 env_set (env, 0, i, EVAL1 (CAR (inits), env));
 883           }
 884         }
 885
 886       if (!scm_is_null (inits))
 887         abort ();
 888       if (i != nenv)
 889         abort ();
 890
 891       *out_body = body;
 892       *out_env = env;
 893     }
 894 }
 895
 896 static void
 897 prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc,
 898                                    SCM exps, SCM *out_body, SCM *inout_env)
 899 {
 900   int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
 901   SCM new_env = BOOT_CLOSURE_ENV (proc);
 902   if ((BOOT_CLOSURE_IS_FIXED (proc)
 903        || (BOOT_CLOSURE_IS_REST (proc)
 904            && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
 905       && nreq == argc)
 906     {
 907       int i;
 908
 909       new_env = make_env (nreq, SCM_UNDEFINED, new_env);
 910       for (i = 0; i < nreq; exps = CDR (exps), i++)
 911         env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
 912
 913       *out_body = BOOT_CLOSURE_BODY (proc);
 914       *inout_env = new_env;
 915     }
 916   else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
 917     {
 918       SCM rest;
 919       int i;
 920
 921       new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
 922       for (i = 0; i < nreq; exps = CDR (exps), i++)
 923         env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
 924       for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
 925         rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
 926       env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
 927
 928       *out_body = BOOT_CLOSURE_BODY (proc);
 929       *inout_env = new_env;
 930     }
 931   else
 932     {
 933       SCM args = SCM_EOL;
 934       for (; scm_is_pair (exps); exps = CDR (exps))
 935         args = scm_cons (EVAL1 (CAR (exps), *inout_env), args);
 936       args = scm_reverse_x (args, SCM_UNDEFINED);
 937       prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env);
 938     }
 939 }
 940
 941 static SCM
 942 boot_closure_apply (SCM closure, SCM args)
 943 {
 944   SCM body, env;
 945   prepare_boot_closure_env_for_apply (closure, args, &body, &env);
 946   return eval (body, env);
 947 }
 948
 949 static int
 950 boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
 951 {
 952   SCM args;
 953   scm_puts_unlocked ("#<boot-closure ", port);
 954   scm_uintprint (SCM_UNPACK (closure), 16, port);
 955   scm_putc_unlocked (' ', port);
 956   args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
 957                         scm_from_latin1_symbol ("_"));
 958   if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
 959     args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
 960   /* FIXME: optionals and rests */
 961   scm_display (args, port);
 962   scm_putc_unlocked ('>', port);
 963   return 1;
 964 }
 965
 966 void
 967 scm_init_eval ()
 968 {
 969   SCM primitive_eval;
 970
 971   f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
 972
 973   scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
 974   scm_set_smob_apply (scm_tc16_boot_closure, boot_closure_apply, 0, 0, 1);
 975   scm_set_smob_print (scm_tc16_boot_closure, boot_closure_print);
 976
 977   primitive_eval = scm_c_make_gsubr ("primitive-eval", 1, 0, 0,
 978                                      scm_c_primitive_eval);
 979   var_primitive_eval = scm_define (SCM_SUBR_NAME (primitive_eval),
 980                                    primitive_eval);
 981
 982 #include "libguile/eval.x"
 983 }
 984
 985 /*
 986   Local Variables:
 987   c-file-style: "gnu"
 988   End:
 989 */
 990