Esempio n. 1
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. 2
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 ();
    }
}