Esempio n. 1
0
static PyObject *load_wrapper(PyObject *name_arg)
{
	return scm2py(
		scm_eval(
			scm_list_2(scm_from_utf8_symbol("load"),
				   py2scm(name_arg)),
			scm_current_module()));
}
Esempio n. 2
0
PyObject *VM_init(VM *self, PyObject *args, PyObject *kwds){
  // For the enviroment setup
  scm_init_guile();
  self->root = scm_current_module();
  self->SMOB_Tag = scm_make_smob_type("PythonSMOB", 0);
  self->callbacks = PyDict_New();
  
  return 0;
}
Esempio n. 3
0
static SCM
expand_env_ref_macro (SCM env, SCM x)
{
  SCM var;
  if (!expand_env_var_is_free (env, x))
    return SCM_BOOL_F; /* lexical */

  var = scm_module_variable (scm_current_module (), x);
  if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
      && scm_is_true (scm_macro_p (scm_variable_ref (var))))
    return scm_variable_ref (var);
  else
    return SCM_BOOL_F; /* anything else */
}
Esempio n. 4
0
static void
shell_main (void *data, int argc, char **argv)
{
  SCM setup_lst = SCM_EOL; /* We reverse! this before using it. */
  SCM run_lst = SCM_EOL;   /* We reverse! this before using it. */
  int c;
  int interactive = 1;
  int inhibit_rc = 0;
  int status;
  TOPLEVEL *toplevel;

  #include "shell.x"

  /* Parse command-line arguments */
  opterr = 0;
  while ((c = getopt (argc, argv, GETOPT_OPTIONS)) != -1) {
    switch (c) {
    case 's':
      /* Construct an application of LOAD to the script name */
      run_lst = scm_cons (scm_list_2 (sym_load,
                                      scm_from_locale_string (optarg)),
                          run_lst);
      interactive = 0;
      goto endoptloop;
    case 'c':
      /* We need to evaluate an expression */
      run_lst = scm_cons (scm_list_2 (sym_eval_string,
                                  scm_from_locale_string (optarg)),
                          run_lst);
      interactive = 0;
      goto endoptloop;
    case 'L':
      /* Add argument to %load-path */
      setup_lst = scm_cons (scm_list_3 (sym_set_x,
                                        sym_load_path,
                                        scm_list_3 (sym_cons,
                                                    scm_from_locale_string (optarg),
                                                    sym_load_path)),
                            setup_lst);
      break;
    case 'l':
      /* Same as -s, pretty much */
      run_lst = scm_cons (scm_list_2 (sym_load,
                                      scm_from_locale_string (optarg)),
                          run_lst);
      break;
    case 'q':
      inhibit_rc = 1;
      break;
    case 'h':
      usage (0);
    case 'V':
      version();
    case '?':
      if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) {
        fprintf (stderr,
                 "ERROR: -%c option requires an argument.\n\n",
                 optopt);
        usage (1);
      } else if (isprint (optopt)) {
        fprintf (stderr, "ERROR: Unknown option -%c\n\n", optopt);
        usage (1);
      } else {
        fprintf (stderr,
                 "ERROR: Unknown option character `\\x%x'.\n\n",
                 optopt);
        usage (1);
      }
    default:
      g_assert_not_reached ();
    }
  }

 endoptloop:
  /* Set program arguments visible from Guile */
  scm_set_program_arguments (argc - optind, argv + optind, "geda-shell");

  /* If interactive mode, load readline and run top REPL. */
  if (interactive) {
    run_lst = scm_cons (scm_list_2 (sym_use_modules,
                                    scm_list_2 (sym_ice_9, sym_readline)),
                        run_lst);
    run_lst = scm_cons (scm_list_1 (sym_activate_readline), run_lst);
    run_lst = scm_cons (scm_list_1 (sym_top_repl), run_lst);

    /* Print GPL bumf if necessary */
    if (isatty (1) && isatty (0)) {

      printf (
"gEDA " PACKAGE_GIT_VERSION "\n"
"Copyright (C) 1998-2010 gEDA developers\n"
"This is free software, and you are welcome to redistribute it under\n"
"certain conditions. For details, see the file `COPYING', which is\n"
"included in the gEDA distribution.\n"
"There is NO WARRANTY, to the extent permitted by law.\n"
              );
    }

  } else {
    run_lst = scm_cons (scm_list_1 (sym_quit), run_lst);
  }

  /* Reverse lists */
  setup_lst = scm_reverse_x (setup_lst, SCM_UNDEFINED);
  run_lst = scm_reverse_x (run_lst, SCM_UNDEFINED);

  /* Initialise libgeda */
  libgeda_init ();
  scm_dynwind_begin (0);
  toplevel = s_toplevel_new ();
  edascm_dynwind_toplevel (toplevel);

  /* First run the setup list */
  if (setup_lst != SCM_EOL) {
    setup_lst = scm_cons (sym_begin, setup_lst);
    scm_eval_x (setup_lst, scm_current_module ());
  }

  /* Now load rc files, if necessary */
  if (!inhibit_rc)
    g_rc_parse (toplevel, argv[0], NULL, NULL);

  i_vars_libgeda_set (toplevel); /* Ugh */

  /* Finally evaluate run list */
  run_lst = scm_cons (sym_begin, run_lst);
  status = scm_exit_status (scm_eval_x (run_lst, scm_current_module ()));
  exit (status);

  scm_dynwind_end ();

  scm_remember_upto_here_2 (setup_lst, run_lst);
}
Esempio n. 5
0
/* in the form: (1 2 3 4). Repeated slots are NOT returned */
SCM g_get_unique_slots(SCM scm_uref)
{
    NETLIST *nl_current;
    char *uref;
    gchar *slot = NULL;
    char *slot_tmp = NULL;
    SCM slots_list = SCM_EOL;
    SCM slot_number;


    SCM_ASSERT(scm_is_string (scm_uref),
	       scm_uref, SCM_ARG1, "gnetlist:get-unique-slots-used-of-package");

    uref = SCM_STRING_CHARS (scm_uref);
    
    /* here is where you make it multi page aware */
    nl_current = netlist_head;

    /* search for the first instance */
    /* through the entire list */
    while (nl_current != NULL) {

	if (nl_current->component_uref) {
	    if (strcmp(nl_current->component_uref, uref) == 0) {

		/* first search outside the symbol */
		slot_tmp =
		    o_attrib_search_name_single(nl_current->object_ptr,
						"slot", NULL);

		if (!slot_tmp) {
		/* if not found, search inside the symbol */
		slot_tmp =
		    o_attrib_search_name(nl_current->object_ptr->
					 complex->prim_objs, "slot",
					 0);
		}
		/* When a package has no slot attribute, then assume it's slot number 1 */
		if (!slot_tmp) {
		  slot_tmp=g_strdup("1");
		}
		slot = g_strconcat ("#d", slot_tmp, NULL);
		slot_number = scm_string_to_number(scm_makfrom0str (slot),
                                           scm_from_int(10));
		g_free (slot);
		if (slot_number != SCM_BOOL_F) {
		  if (scm_member(slot_number, slots_list) ==  SCM_BOOL_F) {
		    slots_list = scm_cons (slot_number, slots_list);
		  }
		}
		else 
		  fprintf(stderr, "Uref %s: Bad slot number: %s.\n", uref, slot_tmp);
		g_free (slot_tmp);
	    }
	}
	nl_current = nl_current->next;
    }

    slots_list = scm_sort_list_x(slots_list,
                                 SCM_VARIABLE_REF (scm_c_module_lookup (
                                   scm_current_module (), "<")));
    return (slots_list);
}
Esempio n. 6
0
void *
weechat_guile_exec (struct t_plugin_script *script,
                    int ret_type, const char *function,
                    char *format, void **argv)
{
    struct t_plugin_script *old_guile_current_script;
    SCM rc, old_current_module;
    void *argv2[17], *ret_value;
    int i, argc, *ret_int;

    old_guile_current_script = guile_current_script;
    old_current_module = NULL;
    if (script->interpreter)
    {
        old_current_module = scm_current_module ();
        scm_set_current_module ((SCM)(script->interpreter));
    }
    guile_current_script = script;

    if (argv && argv[0])
    {
        argc = strlen (format);
        for (i = 0; i < argc; i++)
        {
            switch (format[i])
            {
                case 's': /* string */
                    argv2[i] = scm_from_locale_string ((char *)argv[i]);
                    break;
                case 'i': /* integer */
                    argv2[i] = scm_from_int (*((int *)argv[i]));
                    break;
                case 'h': /* hash */
                    argv2[i] = weechat_guile_hashtable_to_alist (argv[i]);
                    break;
            }
        }
        for (i = argc; i < 17; i++)
        {
            argv2[i] = SCM_UNDEFINED;
        }
        rc = weechat_guile_exec_function (function, (SCM *)argv2, argc);
    }
    else
    {
        rc = weechat_guile_exec_function (function, NULL, 0);
    }

    ret_value = NULL;

    if ((ret_type == WEECHAT_SCRIPT_EXEC_STRING) && (scm_is_string (rc)))
    {
        ret_value = scm_to_locale_string (rc);
    }
    else if ((ret_type == WEECHAT_SCRIPT_EXEC_INT) && (scm_is_integer (rc)))
    {
        ret_int = malloc (sizeof (*ret_int));
        if (ret_int)
            *ret_int = scm_to_int (rc);
        ret_value = ret_int;
    }
    else if (ret_type == WEECHAT_SCRIPT_EXEC_HASHTABLE)
    {
        ret_value = weechat_guile_alist_to_hashtable (rc,
                                                      WEECHAT_SCRIPT_HASHTABLE_DEFAULT_SIZE,
                                                      WEECHAT_HASHTABLE_STRING,
                                                      WEECHAT_HASHTABLE_STRING);
    }
    else
    {
        weechat_printf (NULL,
                        weechat_gettext ("%s%s: function \"%s\" must return "
                                         "a valid value"),
                        weechat_prefix ("error"), GUILE_PLUGIN_NAME, function);
    }

    if (ret_value == NULL)
    {
        weechat_printf (NULL,
                        weechat_gettext ("%s%s: error in function \"%s\""),
                        weechat_prefix ("error"), GUILE_PLUGIN_NAME, function);
    }

    if (old_current_module)
        scm_set_current_module (old_current_module);

    guile_current_script = old_guile_current_script;

    return ret_value;
}
Esempio n. 7
0
static SCM
memoize (SCM exp, SCM env)
{
  if (!SCM_EXPANDED_P (exp))
    abort ();

  switch (SCM_EXPANDED_TYPE (exp))
    {
    case SCM_EXPANDED_VOID:
      return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
      
    case SCM_EXPANDED_CONST:
      return MAKMEMO_QUOTE (REF (exp, CONST, EXP));

    case SCM_EXPANDED_PRIMITIVE_REF:
      if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
        return maybe_makmemo_capture_module
          (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
                                             REF (exp, PRIMITIVE_REF, NAME))),
           env);
      else
        return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
                                                 list_of_guile,
                                                 REF (exp, PRIMITIVE_REF, NAME),
                                                 SCM_BOOL_F));
                                
    case SCM_EXPANDED_LEXICAL_REF:
      return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));

    case SCM_EXPANDED_LEXICAL_SET:
      return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
                              memoize (REF (exp, LEXICAL_SET, EXP), env));

    case SCM_EXPANDED_MODULE_REF:
      return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
                              (SCM_EXPANDED_MODULE_REF,
                               REF (exp, MODULE_REF, MOD),
                               REF (exp, MODULE_REF, NAME),
                               REF (exp, MODULE_REF, PUBLIC)));

    case SCM_EXPANDED_MODULE_SET:
      return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
                              (SCM_EXPANDED_MODULE_SET,
                               REF (exp, MODULE_SET, MOD),
                               REF (exp, MODULE_SET, NAME),
                               REF (exp, MODULE_SET, PUBLIC)),
                              memoize (REF (exp, MODULE_SET, EXP), env));

    case SCM_EXPANDED_TOPLEVEL_REF:
      return maybe_makmemo_capture_module
        (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
                                           REF (exp, TOPLEVEL_REF, NAME))),
         env);

    case SCM_EXPANDED_TOPLEVEL_SET:
      return maybe_makmemo_capture_module
        (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
                                           REF (exp, TOPLEVEL_SET, NAME)),
                          memoize (REF (exp, TOPLEVEL_SET, EXP),
                                   capture_env (env))),
         env);

    case SCM_EXPANDED_TOPLEVEL_DEFINE:
      return maybe_makmemo_capture_module
        (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
                                           REF (exp, TOPLEVEL_DEFINE, NAME)),
                          memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
                                   capture_env (env))),
         env);

    case SCM_EXPANDED_CONDITIONAL:
      return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
                         memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
                         memoize (REF (exp, CONDITIONAL, ALTERNATE), env));

    case SCM_EXPANDED_CALL:
      {
        SCM proc, args;

        proc = REF (exp, CALL, PROC);
        args = memoize_exps (REF (exp, CALL, ARGS), env);

        return MAKMEMO_CALL (memoize (proc, env), args);
      }

    case SCM_EXPANDED_PRIMCALL:
      {
        SCM name, args;
        int nargs;

        name = REF (exp, PRIMCALL, NAME);
        args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
        nargs = scm_ilength (args);

        if (nargs == 3
            && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
          return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
                                           CADR (args),
                                           CADDR (args));
        else if (nargs == 2
                 && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
          return MAKMEMO_APPLY (CAR (args), CADR (args));
        else if (nargs == 1
                 && scm_is_eq (name,
                               scm_from_latin1_symbol
                               ("call-with-current-continuation")))
          return MAKMEMO_CONT (CAR (args));
        else if (nargs == 2
                 && scm_is_eq (name,
                               scm_from_latin1_symbol ("call-with-values")))
          return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
        else if (nargs == 1
                 && scm_is_eq (name,
                               scm_from_latin1_symbol ("variable-ref")))
          return MAKMEMO_BOX_REF (CAR (args));
        else if (nargs == 2
                 && scm_is_eq (name,
                               scm_from_latin1_symbol ("variable-set!")))
          return MAKMEMO_BOX_SET (CAR (args), CADR (args));
        else if (nargs == 2
                 && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
        else if (nargs == 0
                 && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL);
        else if (nargs == 2
                 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args);
        else if (nargs == 0
                 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
        else if (nargs == 1
                 && scm_is_eq (name,
                               scm_from_latin1_symbol ("push-dynamic-state")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
        else if (nargs == 0
                 && scm_is_eq (name,
                               scm_from_latin1_symbol ("pop-dynamic-state")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
        else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
          return MAKMEMO_CALL (maybe_makmemo_capture_module
                               (MAKMEMO_BOX_REF
                                (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
                                                  name)),
                                env),
                               args);
        else
          return MAKMEMO_CALL (MAKMEMO_BOX_REF
                               (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
                                                 list_of_guile,
                                                 name,
                                                 SCM_BOOL_F)),
                               args);
      }

    case SCM_EXPANDED_SEQ:
      return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
                          memoize (REF (exp, SEQ, TAIL), env));

    case SCM_EXPANDED_LAMBDA:
      /* The body will be a lambda-case. */
      {
	SCM meta, body, proc, new_env;

	meta = REF (exp, LAMBDA, META);
        body = REF (exp, LAMBDA, BODY);
        new_env = push_flat_link (capture_env (env));
        proc = memoize (body, new_env);
        SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);

	return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
                                             env);
      }

    case SCM_EXPANDED_LAMBDA_CASE:
      {
        SCM req, rest, opt, kw, inits, vars, body, alt;
        SCM unbound, arity, rib, new_env;
        int nreq, nopt, ninits;

        req = REF (exp, LAMBDA_CASE, REQ);
        rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
        opt = REF (exp, LAMBDA_CASE, OPT);
        kw = REF (exp, LAMBDA_CASE, KW);
        inits = REF (exp, LAMBDA_CASE, INITS);
        vars = REF (exp, LAMBDA_CASE, GENSYMS);
        body = REF (exp, LAMBDA_CASE, BODY);
        alt = REF (exp, LAMBDA_CASE, ALTERNATE);

        nreq = scm_ilength (req);
        nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
        ninits = scm_ilength (inits);
        /* This relies on assignment conversion turning inits into a
           sequence of CONST expressions whose values are a unique
           "unbound" token.  */
        unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
        rib = scm_vector (vars);
        new_env = push_nested_link (rib, env);

        if (scm_is_true (kw))
          {
            /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
            SCM aok = CAR (kw), indices = SCM_EOL;
            for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
              {
                SCM k;
                int idx;

                k = CAR (CAR (kw));
                idx = lookup_rib (CADDR (CAR (kw)), rib);
                indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
              }
            kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
          }

        if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
          {
            if (scm_is_false (rest))
              arity = FIXED_ARITY (nreq);
            else
              arity = REST_ARITY (nreq, SCM_BOOL_T);
          }
        else if (scm_is_true (alt))
          arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
                              SCM_MEMOIZED_ARGS (memoize (alt, env)));
        else
          arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
                              SCM_BOOL_F);

        return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
                               SCM_EOL /* meta, filled in later */);
      }

    case SCM_EXPANDED_LET:
      {
        SCM vars, exps, body, varsv, inits, new_env;
        int i;
        
        vars = REF (exp, LET, GENSYMS);
        exps = REF (exp, LET, VALS);
        body = REF (exp, LET, BODY);
        
        varsv = scm_vector (vars);
        inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
                                   SCM_BOOL_F);
        new_env = push_nested_link (varsv, capture_env (env));
        for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
          VECTOR_SET (inits, i, memoize (CAR (exps), env));

        return maybe_makmemo_capture_module
          (MAKMEMO_LET (inits, memoize (body, new_env)), env);
      }

    default:
      abort ();
    }
}
Esempio n. 8
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 ();
    }
}
Esempio n. 9
0
/*! \brief Main Scheme(GUILE) program function.
 *  \par Function Description
 *  This function is the main program called from scm_boot_guile.
 *  It handles initializing all libraries and gSchem variables
 *  and passes control to the gtk main loop.
 */
void main_prog(void *closure, int argc, char *argv[])
{
  int i;
  char *cwd = NULL;
  GSCHEM_TOPLEVEL *w_current = NULL;
  char *input_str = NULL;
  int argv_index;
  int first_page = 1;
  char *filename;
  SCM scm_tmp;

#ifdef HAVE_GTHREAD
  /* Gschem isn't threaded, but some of GTK's file chooser
   * backends uses threading so we need to call g_thread_init().
   * GLib requires threading be initialised before any other GLib
   * functions are called. Do it now if its not already setup.  */
  if (!g_thread_supported ()) g_thread_init (NULL);
#endif

#if ENABLE_NLS
  /* this should be equivalent to setlocale (LC_ALL, "") */
  gtk_set_locale();

  /* This must be the same for all locales */
  setlocale(LC_NUMERIC, "C");

  /* Disable gtk's ability to set the locale. */ 
  /* If gtk is allowed to set the locale, then it will override the     */
  /* setlocale for LC_NUMERIC (which is important for proper PS output. */
  /* This may look funny here, given we make a call to gtk_set_locale() */
  /* above.  I don't know yet, if this is really the right thing to do. */
  gtk_disable_setlocale(); 

#endif

  gtk_init(&argc, &argv);

  argv_index = parse_commandline(argc, argv);
  cwd = g_get_current_dir();
  
  libgeda_init();

  /* create log file right away even if logging is enabled */
  s_log_init ("gschem");

  s_log_message(
                _("gEDA/gschem version %s%s.%s\n"), PREPEND_VERSION_STRING,
                PACKAGE_DOTTED_VERSION, PACKAGE_DATE_VERSION);
  s_log_message(
                _("gEDA/gschem comes with ABSOLUTELY NO WARRANTY; see COPYING for more details.\n"));
  s_log_message(
                _("This is free software, and you are welcome to redistribute it under certain\n"));
  s_log_message(
                _("conditions; please see the COPYING file for more details.\n\n")); 

#if defined(__MINGW32__) && defined(DEBUG)
  fprintf(stderr, _("This is the MINGW32 port.\n"));
#endif  

#if DEBUG
  fprintf(stderr, _("Current locale settings: %s\n"), setlocale(LC_ALL, NULL));
#endif

  /* init global buffers */
  o_buffer_init();

  /* register guile (scheme) functions */
  g_register_funcs();
  g_init_window ();
  g_init_select ();
  g_init_hook ();
  g_init_attrib ();
  g_init_keys ();
  g_init_util ();

  /* initialise color map (need to do this before reading rc files */
  x_color_init ();

  o_undo_init(); 

  if (s_path_sys_data () == NULL) {
    const gchar *message = 
      _("You must set the GEDADATA environment variable!\n\n"
        "gschem cannot locate its data files. You must set the GEDADATA\n"
        "environment variable to point to the correct location.\n");
    GtkWidget* error_diag =
      gtk_message_dialog_new (NULL, 0, GTK_MESSAGE_ERROR,
                              GTK_BUTTONS_OK,
                              "%s", message);
    gtk_dialog_run (GTK_DIALOG (error_diag));
    g_error ("%s", message);
  }

  /* Allocate w_current */
  w_current = gschem_toplevel_new ();

  /* Connect hooks that run for each s_toplevel_new() first */
  s_toplevel_append_new_hook ((NewToplevelFunc) add_libgeda_toplevel_hooks,
                              w_current);

  w_current->toplevel = s_toplevel_new ();

  w_current->toplevel->load_newer_backup_func = x_fileselect_load_backup;
  w_current->toplevel->load_newer_backup_data = w_current;

  o_text_set_rendered_bounds_func (w_current->toplevel,
                                   o_text_get_rendered_bounds, w_current);

  /* Damage notifications should invalidate the object on screen */
  o_add_change_notify (w_current->toplevel,
                       (ChangeNotifyFunc) o_invalidate,
                       (ChangeNotifyFunc) o_invalidate, w_current);

  scm_dynwind_begin (0);
  g_dynwind_window (w_current);

  /* Run pre-load Scheme expressions */
  g_scm_eval_protected (s_pre_load_expr, scm_current_module ());

  /* By this point, libgeda should have setup the Guile load path, so
   * we can take advantage of that.  */
  scm_tmp = scm_sys_search_load_path (scm_from_utf8_string ("gschem.scm"));
  if (scm_is_false (scm_tmp)) {
    s_log_message (_("Couldn't find init scm file [%s]\n"), "gschem.scm");
  }
  input_str = scm_to_utf8_string (scm_tmp);
  if (g_read_file(w_current->toplevel, input_str, NULL)) {
    s_log_message(_("Read init scm file [%s]\n"), input_str);
  } else {
    /*! \todo These two messages are the same. Should be
     * integrated. */
    s_log_message(_("Failed to read init scm file [%s]\n"),
                  input_str);
  }
  free (input_str); /* M'allocated by scm_to_utf8_string() */
  scm_remember_upto_here_1 (scm_tmp);

  /* Now read in RC files. */
  g_rc_parse_gtkrc();
  x_rc_parse_gschem (w_current, rc_filename);

  /* Set default icon */
  x_window_set_default_icon();

  /* At end, complete set up of window. */
  x_color_allocate();
  x_window_setup (w_current);

#ifdef HAVE_LIBSTROKE
  x_stroke_init ();
#endif /* HAVE_LIBSTROKE */

  for (i = argv_index; i < argc; i++) {

    if (g_path_is_absolute(argv[i]))
    {
      /* Path is already absolute so no need to do any concat of cwd */
      filename = g_strdup (argv[i]);
    } else {
      filename = g_build_filename (cwd, argv[i], NULL);
    }

    if ( first_page )
      first_page = 0;

    /*
     * SDB notes:  at this point the filename might be unnormalized, like
     * /path/to/foo/../bar/baz.sch.  Bad filenames will be normalized in
     * f_open (called by x_window_open_page). This works for Linux and MINGW32.
     */
    x_window_open_page(w_current, filename);
    g_free (filename);
  }

  g_free(cwd);

  /* If no page has been loaded (wasn't specified in the command line.) */
  /* Then create an untitled page */
  if ( first_page ) {
    x_window_open_page( w_current, NULL );
  }

  /* Update the window to show the current page */
  x_window_set_current_page( w_current, w_current->toplevel->page_current );


#if DEBUG
  scm_c_eval_string ("(display \"hello guile\n\")");
#endif

  /* Run post-load expressions */
  g_scm_eval_protected (s_post_load_expr, scm_current_module ());

  /* open up log window on startup */
  if (w_current->log_window == MAP_ON_STARTUP) {
    x_log_open ();
  }

  /* if there were any symbols which had major changes, put up an error */
  /* dialog box */
  major_changed_dialog(w_current);

  scm_dynwind_end ();

  /* enter main loop */
  gtk_main();
}
Esempio n. 10
0
void main_prog(void *closure, int argc, char *argv[])
{
    int i;
    int argv_index;
    char *cwd;
    gchar *str;
    gchar *filename;

    TOPLEVEL *pr_current;

    /* set default output filename */
    output_filename = g_strdup("output.net");

    argv_index = parse_commandline(argc, argv);
    cwd = g_get_current_dir();

    scm_set_program_arguments (argc, argv, NULL);

    /* this is a kludge to make sure that spice mode gets set */
    /*  Hacked by SDB to allow spice netlisters of arbitrary name
     *        as long as they begin with "spice".  For example, this spice
     *  netlister is valid: "spice-sdb".
     */
    if (guile_proc) {
        if (strncmp(guile_proc, "spice", 5) == 0) {
            netlist_mode = SPICE;
        }
    }

    libgeda_init();

    /* create log file right away */
    /* even if logging is enabled */
    s_log_init ("gnetlist");

    s_log_message("gEDA/gnetlist version %s%s.%s\n", PREPEND_VERSION_STRING,
                  PACKAGE_DOTTED_VERSION, PACKAGE_DATE_VERSION);
    s_log_message
        ("gEDA/gnetlist comes with ABSOLUTELY NO WARRANTY; see COPYING for more details.\n");
    s_log_message
        ("This is free software, and you are welcome to redistribute it under certain\n");
    s_log_message
        ("conditions; please see the COPYING file for more details.\n\n");

#if defined(__MINGW32__) && defined(DEBUG)
    fprintf(stderr, "This is the MINGW32 port.\n\n");
#endif

    /* register guile (scheme) functions */
    g_register_funcs();

    pr_current = s_toplevel_new ();

    /* Evaluate Scheme expressions that need to be run before rc files
     * are loaded. */
    scm_eval (pre_rc_list, scm_current_module ());

    g_rc_parse (pr_current, argv[0], "gnetlistrc", rc_filename);
    /* immediately setup user params */
    i_vars_set (pr_current);

    s_rename_init();

    if(list_backends) {
      gnetlist_backends(pr_current);
      exit (0);
    }

    /* Evaluate the first set of Scheme expressions before we load any
     * schematic files */
    scm_eval (pre_backend_list, scm_current_module ());

    i = argv_index;
    while (argv[i] != NULL) {
      GError *err = NULL;

      if (g_path_is_absolute(argv[i])) {
        /* Path is already absolute so no need to do any concat of cwd */
        filename = g_strdup (argv[i]);
      } else {
        filename = g_build_filename (cwd, argv[i], NULL);
      }

      if (!quiet_mode) {
        s_log_message ("Loading schematic [%s]\n", filename);
        printf ("Loading schematic [%s]\n", filename);
      }

      s_page_goto (pr_current, s_page_new (pr_current, filename));

      if (!f_open (pr_current, pr_current->page_current, filename, &err)) {
        g_warning ("%s\n", err->message);
        fprintf (stderr, "%s\n", err->message);
        g_error_free (err);
      }

      /* collect input filenames for backend use */
      input_files = g_slist_append(input_files, argv[i]);

      i++;
      g_free (filename);
    }

    /* Change back to the directory where we started.  This is done */
    /* since gnetlist is a command line utility and will deposit its output */
    /* in the current directory.  Having the output go to a different */
    /* directory will confuse the user (confused me, at first). */
    if (chdir (cwd)) {
      /* Error occured with chdir */
#warning FIME: What do we do?
    }
    /* free(cwd); - Defered; see below */

    if (argv[argv_index] == NULL) {
        fprintf (stderr, "ERROR: No schematics files specified for processing.\n");
        fprintf (stderr, "\nRun `%s --help' for more information.\n", argv[0]);
        exit (1);
    }

    g_set_project_current(pr_current);
#if DEBUG
    s_page_print_all(pr_current);
#endif

    /* Load basic gnetlist functions */
    scm_primitive_load_path (scm_from_utf8_string ("gnetlist.scm"));

    if (guile_proc) {
      SCM s_backend_path;

      /* Search for backend scm file in load path */
      str = g_strdup_printf("gnet-%s.scm", guile_proc);
      s_backend_path = scm_sys_search_load_path (scm_from_locale_string (str));
      g_free (str);

      /* If it couldn't be found, fail. */
      if (scm_is_false (s_backend_path)) {
        fprintf (stderr, "ERROR: Could not find backend `%s' in load path.\n",
                 guile_proc);
        fprintf (stderr,
                 "\nRun `%s --list-backends' for a full list of available backends.\n",
                 argv[0]);
        exit (1);
      }

      /* Load backend code. */
      scm_primitive_load (s_backend_path);

      /* Evaluate second set of Scheme expressions. */
      scm_eval (post_backend_list, scm_current_module ());
    }

    s_traverse_init();
    s_traverse_start(pr_current);

    /* Change back to the directory where we started AGAIN.  This is done */
    /* because the s_traverse functions can change the Current Working Directory. */
    if (chdir (cwd)) {
      /* Error occured with chdir */
#warning FIXME: What do we do?
    }
    g_free(cwd);

    /* Run post-traverse code. */
    scm_primitive_load_path (scm_from_utf8_string ("gnetlist-post.scm"));

    if (guile_proc) {
        /* check size here hack */
        str = g_strdup_printf ("(%s \"%s\")", guile_proc, output_filename);
        scm_c_eval_string (str);
        g_free (str);
        /* gh_eval_str_with_stack_saving_handler (input_str); */
    } else if (interactive_mode) {
        scm_c_eval_string ("(set-repl-prompt! \"gnetlist> \")");
        scm_shell (0, NULL);
    } else {
        fprintf(stderr,
                "You gave neither backend to execute nor interactive mode!\n");
    }

    gnetlist_quit();
}
Esempio n. 11
0
static SCM
memoize (SCM exp, SCM env)
{
  if (!SCM_EXPANDED_P (exp))
    abort ();

  switch (SCM_EXPANDED_TYPE (exp))
    {
    case SCM_EXPANDED_VOID:
      return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
      
    case SCM_EXPANDED_CONST:
      return MAKMEMO_QUOTE (REF (exp, CONST, EXP));

    case SCM_EXPANDED_PRIMITIVE_REF:
      if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
        return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
      else
        return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
                                SCM_BOOL_F);
                                
    case SCM_EXPANDED_LEXICAL_REF:
      return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));

    case SCM_EXPANDED_LEXICAL_SET:
      return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
                              memoize (REF (exp, LEXICAL_SET, EXP), env));

    case SCM_EXPANDED_MODULE_REF:
      return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
                              REF (exp, MODULE_REF, NAME),
                              REF (exp, MODULE_REF, PUBLIC));

    case SCM_EXPANDED_MODULE_SET:
      return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
                              REF (exp, MODULE_SET, MOD),
                              REF (exp, MODULE_SET, NAME),
                              REF (exp, MODULE_SET, PUBLIC));

    case SCM_EXPANDED_TOPLEVEL_REF:
      return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));

    case SCM_EXPANDED_TOPLEVEL_SET:
      return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
                              memoize (REF (exp, TOPLEVEL_SET, EXP), env));

    case SCM_EXPANDED_TOPLEVEL_DEFINE:
      return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
                             memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));

    case SCM_EXPANDED_CONDITIONAL:
      return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
                         memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
                         memoize (REF (exp, CONDITIONAL, ALTERNATE), env));

    case SCM_EXPANDED_CALL:
      {
        SCM proc, args;

        proc = REF (exp, CALL, PROC);
        args = memoize_exps (REF (exp, CALL, ARGS), env);

        return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
      }

    case SCM_EXPANDED_PRIMCALL:
      {
        SCM name, args;
        int nargs;

        name = REF (exp, PRIMCALL, NAME);
        args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
        nargs = scm_ilength (args);

        if (nargs == 3
            && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
          return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
                                           CADR (args),
                                           CADDR (args));
        else if (nargs == 2
                 && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
          return MAKMEMO_APPLY (CAR (args), CADR (args));
        else if (nargs == 1
                 && scm_is_eq (name,
                               scm_from_latin1_symbol
                               ("call-with-current-continuation")))
          return MAKMEMO_CONT (CAR (args));
        else if (nargs == 2
                 && scm_is_eq (name,
                               scm_from_latin1_symbol ("call-with-values")))
          return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
        else if (nargs == 2
                 && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
        else if (nargs == 0
                 && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
        else if (nargs == 2
                 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
        else if (nargs == 0
                 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
          return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
        else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
          return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
        else
          return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
                                                SCM_BOOL_F),
                               nargs,
                               args);
      }

    case SCM_EXPANDED_SEQ:
      return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
                          memoize (REF (exp, SEQ, TAIL), env));

    case SCM_EXPANDED_LAMBDA:
      /* The body will be a lambda-case or #f. */
      {
	SCM meta, docstring, body, proc;

	meta = REF (exp, LAMBDA, META);
	docstring = scm_assoc_ref (meta, scm_sym_documentation);

        body = REF (exp, LAMBDA, BODY);
        if (scm_is_false (body))
          /* Give a body to case-lambda with no clauses.  */
          proc = MAKMEMO_LAMBDA
            (MAKMEMO_CALL
             (MAKMEMO_MOD_REF (list_of_guile,
                               scm_from_latin1_symbol ("throw"),
                               SCM_BOOL_F),
              5,
              scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
                          MAKMEMO_QUOTE (SCM_BOOL_F),
                          MAKMEMO_QUOTE (scm_from_latin1_string
                                         ("Wrong number of arguments")),
                          MAKMEMO_QUOTE (SCM_EOL),
                          MAKMEMO_QUOTE (SCM_BOOL_F))),
             FIXED_ARITY (0),
             SCM_BOOL_F /* docstring */);
        else
          proc = memoize (body, env);

	if (scm_is_string (docstring))
	  {
	    SCM args = SCM_MEMOIZED_ARGS (proc);
	    SCM_SETCAR (SCM_CDR (args), docstring);
	  }

	return proc;
      }

    case SCM_EXPANDED_LAMBDA_CASE:
      {
        SCM req, rest, opt, kw, inits, vars, body, alt;
        SCM walk, minits, arity, new_env;
        int nreq, nopt, ntotal;

        req = REF (exp, LAMBDA_CASE, REQ);
        rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
        opt = REF (exp, LAMBDA_CASE, OPT);
        kw = REF (exp, LAMBDA_CASE, KW);
        inits = REF (exp, LAMBDA_CASE, INITS);
        vars = REF (exp, LAMBDA_CASE, GENSYMS);
        body = REF (exp, LAMBDA_CASE, BODY);
        alt = REF (exp, LAMBDA_CASE, ALTERNATE);

        nreq = scm_ilength (req);
        nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
        ntotal = scm_ilength (vars);

        /* The vars are the gensyms, according to the divine plan. But we need
           to memoize the inits within their appropriate environment,
           complicating things. */
        new_env = env;
        for (walk = req; scm_is_pair (walk);
             walk = CDR (walk), vars = CDR (vars))
          new_env = scm_cons (CAR (vars), new_env);

        minits = SCM_EOL;
        for (walk = opt; scm_is_pair (walk);
             walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
          {
            minits = scm_cons (memoize (CAR (inits), new_env), minits);
            new_env = scm_cons (CAR (vars), new_env);
          }

        if (scm_is_true (rest))
          {
            new_env = scm_cons (CAR (vars), new_env);
            vars = CDR (vars);
          }

        for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
          {
            minits = scm_cons (memoize (CAR (inits), new_env), minits);
            new_env = scm_cons (CAR (vars), new_env);
          }
        if (!scm_is_null (vars))
          abort ();

        minits = scm_reverse_x (minits, SCM_UNDEFINED);

        if (scm_is_true (kw))
          {
            /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
            SCM aok = CAR (kw), indices = SCM_EOL;
            for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
              {
                SCM k;
                int idx;

                k = CAR (CAR (kw));
                idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
                indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
              }
            kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
          }

        if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
          {
            if (scm_is_false (rest))
              arity = FIXED_ARITY (nreq);
            else
              arity = REST_ARITY (nreq, SCM_BOOL_T);
          }
        else if (scm_is_true (alt))
          arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
                              SCM_MEMOIZED_ARGS (memoize (alt, env)));
        else
          arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);

        return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
			       SCM_BOOL_F /* docstring */);
      }

    case SCM_EXPANDED_LET:
      {
        SCM vars, exps, body, inits, new_env;
        
        vars = REF (exp, LET, GENSYMS);
        exps = REF (exp, LET, VALS);
        body = REF (exp, LET, BODY);
        
        inits = SCM_EOL;
        new_env = env;
        for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
          {
            new_env = scm_cons (CAR (vars), new_env);
            inits = scm_cons (memoize (CAR (exps), env), inits);
          }

        return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
                            memoize (body, new_env));
      }

    case SCM_EXPANDED_LETREC:
      {
        SCM vars, exps, body, undefs, new_env;
        int i, nvars, in_order_p;
        
        vars = REF (exp, LETREC, GENSYMS);
        exps = REF (exp, LETREC, VALS);
        body = REF (exp, LETREC, BODY);
        in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
        nvars = i = scm_ilength (vars);
        undefs = SCM_EOL;
        new_env = env;

        for (; scm_is_pair (vars); vars = CDR (vars))
          {
            new_env = scm_cons (CAR (vars), new_env);
            undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
          }

        if (in_order_p)
          {
            SCM body_exps = SCM_EOL, seq;
            for (; scm_is_pair (exps); exps = CDR (exps), i--)
              body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
                                                     memoize (CAR (exps), new_env)),
                                    body_exps);

            seq = memoize (body, new_env);
            for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
              seq = MAKMEMO_SEQ (CAR (body_exps), seq);

            return MAKMEMO_LET (undefs, seq);
          }
        else
          {
            SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
            for (; scm_is_pair (exps); exps = CDR (exps), i--)
              {
                sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
                                                  MAKMEMO_LEX_REF (i-1)),
                                 sets);
                inits = scm_cons (memoize (CAR (exps), new_env), inits);
              }
            inits = scm_reverse_x (inits, SCM_UNDEFINED);

            sets = scm_reverse_x (sets, SCM_UNDEFINED);
            if (scm_is_null (sets))
              return memoize (body, env);

            for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
                 sets = CDR (sets))
              set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
            
            return MAKMEMO_LET (undefs,
                                MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
                                             memoize (body, new_env)));
          }
      }

    default:
      abort ();
    }
}