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