Beispiel #1
0
int sexp_rest_unused_p (sexp lambda) {
  sexp var;
  for (var=sexp_lambda_params(lambda); sexp_pairp(var); var=sexp_cdr(var))
    ;
  if (sexp_nullp(var)) return 0;
  return !usedp(lambda, var, sexp_lambda_body(lambda));
}
Beispiel #2
0
static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
  sexp_gc_var2(res, tmp);
  res = type;
  if (! res) {
    res = sexp_type_by_index(ctx, SEXP_OBJECT);
  } if (sexp_fixnump(res)) {
    res = sexp_type_by_index(ctx, sexp_unbox_fixnum(res));
  } else if (sexp_nullp(res)) {        /* opcode list types */
    sexp_gc_preserve2(ctx, res, tmp);
    tmp = sexp_intern(ctx, "or", -1);
    res = sexp_cons(ctx, SEXP_NULL, SEXP_NULL);
    res = sexp_cons(ctx, sexp_type_by_index(ctx, SEXP_PAIR), res);
    res = sexp_cons(ctx, tmp, res);
    sexp_gc_release2(ctx);
  }
  return res;
}
Beispiel #3
0
static void repl (sexp ctx, sexp env) {
  sexp_gc_var6(obj, tmp, res, in, out, err);
  sexp_gc_preserve6(ctx, obj, tmp, res, in, out, err);
  sexp_context_tracep(ctx) = 1;
  in  = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL));
  out = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL));
  err = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
  if (in == NULL || out == NULL) {
    fprintf(stderr, "Standard I/O ports not found, aborting.  Maybe a bad -x language?\n");
    exit_failure();
  }
  if (err == NULL) err = out;
  sexp_port_sourcep(in) = 1;
  while (1) {
    sexp_write_string(ctx, "> ", out);
    sexp_flush(ctx, out);
    sexp_maybe_block_port(ctx, in, 1);
    obj = sexp_read(ctx, in);
    sexp_maybe_unblock_port(ctx, in);
    if (obj == SEXP_EOF)
      break;
    if (sexp_exceptionp(obj)) {
      sexp_print_exception(ctx, obj, err);
    } else {
      sexp_context_top(ctx) = 0;
      if (!(sexp_idp(obj)||sexp_pairp(obj)||sexp_nullp(obj)))
        obj = sexp_make_lit(ctx, obj);
      tmp = sexp_env_bindings(env);
      res = sexp_eval(ctx, obj, env);
#if SEXP_USE_WARN_UNDEFS
      sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, res);
#endif
      if (res && sexp_exceptionp(res)) {
        sexp_print_exception(ctx, res, err);
        if (res != sexp_global(ctx, SEXP_G_OOS_ERROR))
          sexp_stack_trace(ctx, err);
      } else if (res != SEXP_VOID) {
        sexp_write(ctx, res, out);
        sexp_write_char(ctx, '\n', out);
      }
    }
  }
  sexp_gc_release6(ctx);
}
Beispiel #4
0
/* Returns 0 or an atom */
int
spki_get_type(struct sexp *e, struct sexp_iterator **res)
{
  struct sexp_iterator *i;
  int type;
  
  if (sexp_atomp(e) || sexp_nullp(e))
    return 0;

  i = SEXP_ITER(e);

  type = sexp2atom(SEXP_GET(i));
  if (type && res)
    {
      SEXP_NEXT(i);
      *res = i;
    }
  else
    KILL(i);

  return type;
}
Beispiel #5
0
static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq,
                         sexp less, sexp key) {
  sexp_sint_t len;
  sexp res, *data;
  sexp_gc_var1(vec);

  if (sexp_nullp(seq)) return seq;

  sexp_gc_preserve1(ctx, vec);

  vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);

  if (! sexp_vectorp(vec)) {
    res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
  } else {
    data = sexp_vector_data(vec);
    len = sexp_vector_length(vec);
    if (sexp_not(key) && sexp_basic_comparator(less)) {
      sexp_qsort(ctx, data, 0, len-1);
      if (sexp_opcodep(less) && sexp_opcode_inverse(less))
        sexp_vector_nreverse(ctx, vec);
      res = vec;
    } else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
      res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less);
    } else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
      res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
    } else {
      res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
    }
  }

  if (sexp_pairp(seq) && ! sexp_exceptionp(res))
    res = sexp_vector_copy_to_list(ctx, vec, seq);

  sexp_gc_release1(ctx);
  return res;
}
Beispiel #6
0
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
  int check;
  sexp ls1, ls2, p1, p2, sv;
  sexp_gc_var5(res, substs, tmp, app, ctx2);
  sexp_gc_preserve5(ctx, res, substs, tmp, app, ctx2);
  res = ast;                    /* return the ast as-is by default */
  substs = init_substs;

 loop:
  switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) {

  case SEXP_PAIR:
    /* don't simplify the operator if it's a lambda because we
       simplify that as a special case below, with the appropriate
       substs list */
    app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
                     : (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
    sexp_pair_source(app) = sexp_pair_source(res);
    for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
      sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
      if (sexp_pairp(app)) sexp_pair_source(app) = sexp_pair_source(ls1);
    }
    app = sexp_nreverse(ctx, app);
    /* app now holds a copy of the list, and is the default result
       (res = app below) if we don't replace it with a simplification */
    if (sexp_opcodep(sexp_car(app))) {
      /* opcode app - right now we just constant fold arithmetic */
      if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) {
        for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
          if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
            check = 0;
            break;
          }
        }
        if (check) {
          ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0, 0);
          sexp_generate(ctx2, 0, 0, 0, app);
          res = sexp_complete_bytecode(ctx2);
          if (! sexp_exceptionp(res)) {
            tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
            tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp);
            if (! sexp_exceptionp(tmp)) {
              tmp = sexp_apply(ctx2, tmp, SEXP_NULL);
              if (! sexp_exceptionp(tmp))
                app = sexp_make_lit(ctx2, tmp);
            }
          }
        }
      }
    } else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
      p1 = NULL;
      p2 = sexp_lambda_params(sexp_car(app));
      ls1 = app;
      ls2 = sexp_cdr(app);
      sv = sexp_lambda_sv(sexp_car(app));
      if (sexp_length(ctx, p2) == sexp_length(ctx, ls2)) {
        for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
          if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
              && (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
                  || (sexp_refp(sexp_car(ls2))
                      && sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))
                      && sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)),
                                            sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) {
            tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
            tmp = sexp_cons(ctx, sexp_car(p2), tmp);
            sexp_push(ctx, substs, tmp);
            sexp_cdr(ls1) = sexp_cdr(ls2);
            if (p1)
              sexp_cdr(p1) = sexp_cdr(p2);
            else
              sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
          } else {
            p1 = p2;
            ls1 = ls2;
          }
        }
        sexp_lambda_body(sexp_car(app))
          = simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
        if (sexp_nullp(sexp_cdr(app))
            && sexp_nullp(sexp_lambda_params(sexp_car(app)))
            && sexp_nullp(sexp_lambda_defs(sexp_car(app))))
          app = sexp_lambda_body(sexp_car(app));
      }
    }
    res = app;
    break;

  case SEXP_LAMBDA:
    sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
    break;

  case SEXP_CND:
    tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
    if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
      res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
        ? sexp_cnd_fail(res) : sexp_cnd_pass(res);
      goto loop;
    } else {
      sexp_cnd_test(res) = tmp;
      simplify_it(sexp_cnd_pass(res));
      simplify_it(sexp_cnd_fail(res));
    }
    break;

  case SEXP_REF:
    tmp = sexp_ref_name(res);
    for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
      if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
        res = sexp_cddar(ls1);
        break;
      }
    break;

  case SEXP_SET:
    simplify_it(sexp_set_value(res));
    break;

  case SEXP_SEQ:
    app = SEXP_NULL;
    for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
      tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
      if (! (sexp_pairp(sexp_cdr(ls2))
             && (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
                 || sexp_lambdap(tmp))))
        sexp_push(ctx, app, tmp);
    }
    if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
      res = sexp_car(app);
    else
      sexp_seq_ls(res) = sexp_nreverse(ctx, app);
    break;

  }

  sexp_gc_release5(ctx);
  return res;
}