Exemplo n.º 1
0
/* OBJ must be a values object containing exactly two values.
   scm_i_extract_values_2 puts those two values into *p1 and *p2.  */
void
scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2)
{
  SCM values;

  SCM_ASSERT_TYPE (SCM_VALUESP (obj), obj, SCM_ARG1,
		   "scm_i_extract_values_2", "values");
  values = scm_struct_ref (obj, SCM_INUM0);
  if (scm_ilength (values) != 2)
    scm_wrong_type_arg_msg
      ("scm_i_extract_values_2", SCM_ARG1, obj,
       "a values object containing exactly two values");
  *p1 = SCM_CAR (values);
  *p2 = SCM_CADR (values);
}
Exemplo n.º 2
0
/* Multiple values truncation.  */
static SCM
truncate_values (SCM x)
{
  if (SCM_LIKELY (!SCM_VALUESP (x)))
    return x;
  else
    {
      SCM l = scm_struct_ref (x, SCM_INUM0);
      if (SCM_LIKELY (scm_is_pair (l)))
        return scm_car (l);
      else
        {
          scm_ithrow (scm_from_latin1_symbol ("vm-run"),
                      scm_list_3 (scm_from_latin1_symbol ("vm-run"),
                                  scm_from_locale_string
                                  ("Too few values returned to continuation"),
                                  SCM_EOL),
                      1);
          /* Not reached.  */
          return SCM_BOOL_F;
        }
    }
}
Exemplo n.º 3
0
SCM
scm_c_value_ref (SCM obj, size_t idx)
{
  if (SCM_LIKELY (SCM_VALUESP (obj)))
    {
      SCM values = scm_struct_ref (obj, SCM_INUM0);
      size_t i = idx;
      while (SCM_LIKELY (scm_is_pair (values)))
        {
          if (i == 0)
            return SCM_CAR (values);
          values = SCM_CDR (values);
          i--;
        }
    }
  else if (idx == 0)
    return obj;

  scm_error (scm_out_of_range_key,
	     "scm_c_value_ref",
	     "Too few values in ~S to access index ~S",
             scm_list_2 (obj, scm_from_unsigned_integer (idx)),
             scm_list_1 (scm_from_unsigned_integer (idx)));
}
Exemplo n.º 4
0
static SCM
eval (SCM x, SCM env)
{
  SCM mx;
  SCM proc = SCM_UNDEFINED, args = SCM_EOL;
  unsigned int argc;

 loop:
  SCM_TICK;
  if (!SCM_MEMOIZED_P (x))
    abort ();
  
  mx = SCM_MEMOIZED_ARGS (x);
  switch (SCM_MEMOIZED_TAG (x))
    {
    case SCM_M_SEQ:
      eval (CAR (mx), env);
      x = CDR (mx);
      goto loop;

    case SCM_M_IF:
      if (scm_is_true (EVAL1 (CAR (mx), env)))
        x = CADR (mx);
      else
        x = CDDR (mx);
      goto loop;

    case SCM_M_LET:
      {
        SCM inits = CAR (mx);
        SCM new_env = CAPTURE_ENV (env);
        for (; scm_is_pair (inits); inits = CDR (inits))
          new_env = scm_cons (EVAL1 (CAR (inits), env),
                              new_env);
        env = new_env;
        x = CDR (mx);
        goto loop;
      }
          
    case SCM_M_LAMBDA:
      RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));

    case SCM_M_QUOTE:
      return mx;

    case SCM_M_DEFINE:
      scm_define (CAR (mx), EVAL1 (CDR (mx), env));
      return SCM_UNSPECIFIED;

    case SCM_M_DYNWIND:
      {
        SCM in, out, res;
        scm_i_thread *t = SCM_I_CURRENT_THREAD;
        in = EVAL1 (CAR (mx), env);
        out = EVAL1 (CDDR (mx), env);
        scm_call_0 (in);
        scm_dynstack_push_dynwind (&t->dynstack, in, out);
        res = eval (CADR (mx), env);
        scm_dynstack_pop (&t->dynstack);
        scm_call_0 (out);
        return res;
      }

    case SCM_M_WITH_FLUIDS:
      {
        long i, len;
        SCM *fluidv, *valuesv, walk, res;
        scm_i_thread *thread = SCM_I_CURRENT_THREAD;

        len = scm_ilength (CAR (mx));
        fluidv = alloca (sizeof (SCM)*len);
        for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
          fluidv[i] = EVAL1 (CAR (walk), env);
        valuesv = alloca (sizeof (SCM)*len);
        for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
          valuesv[i] = EVAL1 (CAR (walk), env);
        
        scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
                                  thread->dynamic_state);
        res = eval (CDDR (mx), env);
        scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
        
        return res;
      }

    case SCM_M_APPLY:
      /* Evaluate the procedure to be applied.  */
      proc = EVAL1 (CAR (mx), env);
      /* Evaluate the argument holding the list of arguments */
      args = EVAL1 (CADR (mx), env);
          
    apply_proc:
      /* Go here to tail-apply a procedure.  PROC is the procedure and
       * ARGS is the list of arguments. */
      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_apply (proc, args, &x, &env);
          goto loop;
        }
      else
        return scm_call_with_vm (scm_the_vm (), proc, args);

    case SCM_M_CALL:
      /* Evaluate the procedure to be applied.  */
      proc = EVAL1 (CAR (mx), env);
      argc = SCM_I_INUM (CADR (mx));
      mx = CDDR (mx);

      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
          goto loop;
        }
      else
        {
	  SCM *argv;
	  unsigned int i;

	  argv = alloca (argc * sizeof (SCM));
	  for (i = 0; i < argc; i++, mx = CDR (mx))
	    argv[i] = EVAL1 (CAR (mx), env);

	  return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
        }

    case SCM_M_CONT:
      return scm_i_call_with_current_continuation (EVAL1 (mx, env));

    case SCM_M_CALL_WITH_VALUES:
      {
        SCM producer;
        SCM v;

        producer = EVAL1 (CAR (mx), env);
        /* `proc' is the consumer.  */
        proc = EVAL1 (CDR (mx), env);
        v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
        if (SCM_VALUESP (v))
          args = scm_struct_ref (v, SCM_INUM0);
        else
          args = scm_list_1 (v);
        goto apply_proc;
      }

    case SCM_M_LEXICAL_REF:
      {
        int n;
        SCM ret;
        for (n = SCM_I_INUM (mx); n; n--)
          env = CDR (env);
        ret = CAR (env);
        if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
          /* we don't know what variable, though, because we don't have its
             name */
          error_used_before_defined ();
        return ret;
      }

    case SCM_M_LEXICAL_SET:
      {
        int n;
        SCM val = EVAL1 (CDR (mx), env);
        for (n = SCM_I_INUM (CAR (mx)); n; n--)
          env = CDR (env);
        SCM_SETCAR (env, val);
        return SCM_UNSPECIFIED;
      }

    case SCM_M_TOPLEVEL_REF:
      if (SCM_VARIABLEP (mx))
        return SCM_VARIABLE_REF (mx);
      else
        {
          while (scm_is_pair (env))
            env = CDR (env);
          return SCM_VARIABLE_REF
            (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
        }

    case SCM_M_TOPLEVEL_SET:
      {
        SCM var = CAR (mx);
        SCM val = EVAL1 (CDR (mx), env);
        if (SCM_VARIABLEP (var))
          {
            SCM_VARIABLE_SET (var, val);
            return SCM_UNSPECIFIED;
          }
        else
          {
            while (scm_is_pair (env))
              env = CDR (env);
            SCM_VARIABLE_SET
              (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
               val);
            return SCM_UNSPECIFIED;
          }
      }

    case SCM_M_MODULE_REF:
      if (SCM_VARIABLEP (mx))
        return SCM_VARIABLE_REF (mx);
      else
        return SCM_VARIABLE_REF
          (scm_memoize_variable_access_x (x, SCM_BOOL_F));

    case SCM_M_MODULE_SET:
      if (SCM_VARIABLEP (CDR (mx)))
        {
          SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
          return SCM_UNSPECIFIED;
        }
      else
        {
          SCM_VARIABLE_SET
            (scm_memoize_variable_access_x (x, SCM_BOOL_F),
             EVAL1 (CAR (mx), env));
          return SCM_UNSPECIFIED;
        }

    case SCM_M_PROMPT:
      {
        SCM vm, k, res;
        scm_i_jmp_buf registers;
        /* We need the handler after nonlocal return to the setjmp, so
           make sure it is volatile.  */
        volatile SCM handler;

        k = EVAL1 (CAR (mx), env);
        handler = EVAL1 (CDDR (mx), env);
        vm = scm_the_vm ();

        /* Push the prompt onto the dynamic stack. */
        scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
                                  SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
                                  k,
                                  SCM_VM_DATA (vm)->fp,
                                  SCM_VM_DATA (vm)->sp,
                                  SCM_VM_DATA (vm)->ip,
                                  &registers);

        if (SCM_I_SETJMP (registers))
          {
            /* The prompt exited nonlocally. */
            proc = handler;
            args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
            goto apply_proc;
          }
        
        res = eval (CADR (mx), env);
        scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
        return res;
      }

    default:
      abort ();
    }
}
Exemplo n.º 5
0
static SCM
eval (SCM x, SCM env)
{
  SCM mx;
  SCM proc = SCM_UNDEFINED, args = SCM_EOL;
  unsigned int argc;

 loop:
  SCM_TICK;
  
  mx = SCM_MEMOIZED_ARGS (x);
  switch (SCM_I_INUM (SCM_CAR (x)))
    {
    case SCM_M_SEQ:
      eval (CAR (mx), env);
      x = CDR (mx);
      goto loop;

    case SCM_M_IF:
      if (scm_is_true (EVAL1 (CAR (mx), env)))
        x = CADR (mx);
      else
        x = CDDR (mx);
      goto loop;

    case SCM_M_LET:
      {
        SCM inits = CAR (mx);
        SCM new_env;
        int i;

        new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
        for (i = 0; i < VECTOR_LENGTH (inits); i++)
          env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
        env = new_env;
        x = CDR (mx);
        goto loop;
      }
          
    case SCM_M_LAMBDA:
      RETURN_BOOT_CLOSURE (mx, env);

    case SCM_M_CAPTURE_ENV:
      {
        SCM locs = CAR (mx);
        SCM new_env;
        int i;

        new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
        for (i = 0; i < VECTOR_LENGTH (locs); i++)
          {
            SCM loc = VECTOR_REF (locs, i);
            int depth, width;

            depth = SCM_I_INUM (CAR (loc));
            width = SCM_I_INUM (CDR (loc));
            env_set (new_env, 0, i, env_ref (env, depth, width));
          }

        env = new_env;
        x = CDR (mx);
        goto loop;
      }

    case SCM_M_QUOTE:
      return mx;

    case SCM_M_CAPTURE_MODULE:
      return eval (mx, scm_current_module ());

    case SCM_M_APPLY:
      /* Evaluate the procedure to be applied.  */
      proc = EVAL1 (CAR (mx), env);
      /* Evaluate the argument holding the list of arguments */
      args = EVAL1 (CADR (mx), env);
          
    apply_proc:
      /* Go here to tail-apply a procedure.  PROC is the procedure and
       * ARGS is the list of arguments. */
      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_apply (proc, args, &x, &env);
          goto loop;
        }
      else
        return scm_apply_0 (proc, args);

    case SCM_M_CALL:
      /* Evaluate the procedure to be applied.  */
      proc = EVAL1 (CAR (mx), env);
      argc = scm_ilength (CDR (mx));
      mx = CDR (mx);

      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
          goto loop;
        }
      else
        {
	  SCM *argv;
	  unsigned int i;

	  argv = alloca (argc * sizeof (SCM));
	  for (i = 0; i < argc; i++, mx = CDR (mx))
	    argv[i] = EVAL1 (CAR (mx), env);

	  return scm_call_n (proc, argv, argc);
        }

    case SCM_M_CONT:
      return scm_i_call_with_current_continuation (EVAL1 (mx, env));

    case SCM_M_CALL_WITH_VALUES:
      {
        SCM producer;
        SCM v;

        producer = EVAL1 (CAR (mx), env);
        /* `proc' is the consumer.  */
        proc = EVAL1 (CDR (mx), env);
        v = scm_call_0 (producer);
        if (SCM_VALUESP (v))
          args = scm_struct_ref (v, SCM_INUM0);
        else
          args = scm_list_1 (v);
        goto apply_proc;
      }

    case SCM_M_LEXICAL_REF:
      {
        SCM pos;
        int depth, width;

        pos = mx;
        depth = SCM_I_INUM (CAR (pos));
        width = SCM_I_INUM (CDR (pos));

        return env_ref (env, depth, width);
      }

    case SCM_M_LEXICAL_SET:
      {
        SCM pos;
        int depth, width;
        SCM val = EVAL1 (CDR (mx), env);

        pos = CAR (mx);
        depth = SCM_I_INUM (CAR (pos));
        width = SCM_I_INUM (CDR (pos));

        env_set (env, depth, width, val);

        return SCM_UNSPECIFIED;
      }

    case SCM_M_BOX_REF:
      {
        SCM box = mx;

        return scm_variable_ref (EVAL1 (box, env));
      }

    case SCM_M_BOX_SET:
      {
        SCM box = CAR (mx), val = CDR (mx);

        return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
      }

    case SCM_M_RESOLVE:
      if (SCM_VARIABLEP (mx))
        return mx;
      else
        {
          SCM var;

          var = scm_sys_resolve_variable (mx, env_tail (env));
          scm_set_cdr_x (x, var);

          return var;
        }

    case SCM_M_CALL_WITH_PROMPT:
      {
        struct scm_vm *vp;
        SCM k, handler, res;
        scm_i_jmp_buf registers;
        scm_t_ptrdiff saved_stack_depth;

        k = EVAL1 (CAR (mx), env);
        handler = EVAL1 (CDDR (mx), env);
        vp = scm_the_vm ();

        saved_stack_depth = vp->stack_top - vp->sp;

        /* Push the prompt onto the dynamic stack. */
        scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
                                  SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
                                  k,
                                  vp->stack_top - vp->fp,
                                  saved_stack_depth,
                                  vp->ip,
                                  &registers);

        if (SCM_I_SETJMP (registers))
          {
            /* The prompt exited nonlocally. */
            scm_gc_after_nonlocal_exit ();
            proc = handler;
            args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth);
            goto apply_proc;
          }
        
        res = scm_call_0 (eval (CADR (mx), env));
        scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
        return res;
      }

    default:
      abort ();
    }
}