Ejemplo n.º 1
0
cell pp_curs_mvcur(cell x) {
	char	name[] = "curs:mvcur";

	if (!Running) return UNSPECIFIC;
	if (!integer_p(cadddr(x)))
		return error("curs:mvcur: expected integer, got",
				caddr(cdr(x)));
	mvcur(integer_value(name, car(x)),
		integer_value(name, cadr(x)),
		integer_value(name, caddr(x)),
		integer_value(name, cadddr(x)));
	return UNSPECIFIC;
}
Ejemplo n.º 2
0
void
eval_coeff(void)
{
	push(cadr(p1));			// 1st arg, p
	eval();

	push(caddr(p1));		// 2nd arg, x
	eval();

	push(cadddr(p1));		// 3rd arg, n
	eval();

	N = pop();
	X = pop();
	P = pop();

	if (N == symbol(NIL)) {		// only 2 args?
		N = X;
		X = symbol(SYMBOL_X);
	}

	push(P);			// divide p by x^n
	push(X);
	push(N);
	power();
	divide();

	push(X);			// keep the constant part
	filter();
}
Ejemplo n.º 3
0
cons_t* proc_ffi_prep_cif_var(cons_t* p, environment_t*)
{
  assert_length(p, 3, 4);

  ffi_abi abi = FFI_DEFAULT_ABI;

  /*
   * ARGUMENT 1: ABI for foreign function
   */
  abi = parse_ffi_abi(car(p));

  /*
   * ARGUMENT 2:
   * Return type for foreign function
   */
  ffi_type* rtype = parse_ffi_type(cadr(p));

  /*
   * ARGUMENT 3:
   * Number of fixed vars
   */
  assert_type(INTEGER, caddr(p));
  unsigned int fixedargs = caddr(p)->number.integer;

  /*
   * ARGUMENT 4:
   * Types for foreign function's input parameters.
   */
  ffi_type** argtypes = NULL;
  unsigned int nargs = 0;

  if ( length(p) >= 4 ) {
    cons_t *args = cadddr(p);
    assert_type(PAIR, args);
    nargs = length(args);

    if ( nargs > 0 ) {
      argtypes = static_cast<ffi_type**>(malloc(nargs*sizeof(ffi_type*)));

      for ( unsigned int n=0; n<nargs; ++n ) {
        argtypes[n] = parse_ffi_type(car(args));
        args = cdr(args);
      }
    }
  }

  /*
   * Initialize returned struct
   */
  ffi_cif *cif = new ffi_cif();
  memset(cif, 0, sizeof(ffi_cif));

  check(ffi_prep_cif_var(cif, abi, fixedargs, nargs, rtype, argtypes));
  return pointer(tag_ffi_cif, cif);

  /*
   * In the future, the malloced argtypes should be added to the
   * pointer-return value here, so that it too can be freed.
   */
}
Ejemplo n.º 4
0
object *if_alternative(object *exp) {
	if (is_the_empty_list(cdddr(exp))) {
		return false;
	} else {
		return cadddr(exp);
	}
}
Ejemplo n.º 5
0
/*
 * (set-video-mode <width> <height> <bits per pixel>?) or
 * (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
 *
 * where <symbols> are:
 *  swsurface
 *  hwsurface
 *  asyncblit
 *  anyformat
 *  hwpalette
 *  doublebuf
 *  fullscreen
 *  opengl
 *  openglblit
 *  resizable
 *  noframe
 *
 */
cons_t* set_video_mode(cons_t* p, environment_t*)
{
  assert_length_min(p, 2);
  assert_type(INTEGER, car(p));
  assert_type(INTEGER, cadr(p));

  // dimension
  int x = car(p)->integer;
  int y = cadr(p)->integer;

  // default values
  int bits = 32;
  uint32_t mode = 0;

///////////////////
  raise(runtime_exception("Testing"));
///////////////////

  // bits per pixel
  if ( integerp(caddr(p)) )
    bits = caddr(p)->integer;

  // options
  cons_t *opts = symbolp(caddr(p))? cddr(p) :
                 symbolp(cadddr(p))? cdddr(p) : nil();;

  for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
    assert_type(SYMBOL, car(s));

    std::string sym = symbol_name(s);
    int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>);

    for ( int n=0; n < size; ++n )
      if ( sym == sdl_flags[n].key ) {
///////////////////
printf("flag %s\n", sym.c_str());
printf("value %d and %d\n", sdl_flags[n].value, SDL_HWSURFACE);
///////////////////
        mode |= sdl_flags[n].value;
        goto NEXT_FLAG;
      }

    raise(runtime_exception("Unknown SDL video mode flag: " + sym));

NEXT_FLAG:
    continue;
  }

  mode = SDL_HWSURFACE;
///////////////////
  printf("video mode\n"); fflush(stdout);
///////////////////

  SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);

  if ( screen == NULL )
    raise(runtime_exception(SDL_GetError()));

  return pointer(new pointer_t("sdl-surface", (void*)screen));
}
Ejemplo n.º 6
0
static pSlipObject if_alternative(pSlip gd, pSlipObject exp)
{
	if (sIsObject_EmptyList(gd, cdddr(exp)) == S_TRUE)
	{
		return gd->singleton_False;
	}
	else
	{
		return cadddr(exp);
	}
}
Ejemplo n.º 7
0
/*
 * (set-video-mode <width> <height> <bits per pixel>?) or
 * (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
 *
 * where <symbols> are:
 *  swsurface
 *  hwsurface
 *  asyncblit
 *  anyformat
 *  hwpalette
 *  doublebuf
 *  fullscreen
 *  opengl
 *  openglblit
 *  resizable
 *  noframe
 *
 */
cons_t* set_video_mode(cons_t* p, environment_t*)
{
  assert_length_min(p, 2);
  assert_type(INTEGER, car(p));
  assert_type(INTEGER, cadr(p));

  // dimension
  int x = intval(car(p));
  int y = intval(cadr(p));

  // default values
  int bits = 32;
  uint32_t mode = 0;

  // bits per pixel
  if ( length(p) > 2 && integerp(caddr(p)) )
    bits = intval(caddr(p));

  // mode options
  if ( length(p) > 3 ) {
    cons_t *opts = symbolp(caddr(p))? cddr(p) :
                   symbolp(cadddr(p))? cdddr(p) : nil();;

    DPRINT(opts);

    for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
      assert_type(SYMBOL, car(s));

      std::string sym = symbol_name(car(s));

      for ( size_t n=0; n < num_sdl_flags; ++n )
        if ( sym == sdl_flags[n].key ) {
          mode |= sdl_flags[n].value;
          goto NEXT_FLAG;
        }

      raise(runtime_exception("Unknown SDL video mode flag: " + sym));

  NEXT_FLAG:
      continue;
    }
  }

  SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);

  if ( screen == NULL )
    raise(runtime_exception(SDL_GetError()));

  return pointer(
    new pointer_t("sdl-surface",
                  reinterpret_cast<void*>(screen)));
}
Ejemplo n.º 8
0
void
eval_product(void)
{
	int i, j, k;

	// 1st arg (quoted)

	X = cadr(p1);
	if (!issymbol(X))
		stop("product: 1st arg?");

	// 2nd arg

	push(caddr(p1));
	eval();
	j = pop_integer();
	if (j == (int) 0x80000000)
		stop("product: 2nd arg?");

	// 3rd arg

	push(cadddr(p1));
	eval();
	k = pop_integer();
	if (k == (int) 0x80000000)
		stop("product: 3rd arg?");

	// 4th arg
	// fix

	p1 = cddddr(p1);
	p1 = car(p1);

	B = get_binding(X);
	A = get_arglist(X);

	push_integer(1);

	for (i = j; i <= k; i++) {
		push_integer(i);
		I = pop();
		set_binding(X, I);
		push(p1);
		eval();
		multiply();
	}

	set_binding_and_arglist(X, B, A);
}
Ejemplo n.º 9
0
int typeSize(refObject type)
{ switch (toHook(car(type)))
  { case arrayHook:
    { type = cdr(type);
      return toInteger(car(type)) * typeSize(cadr(type)); }
    case char0Hook:
    { return sizeof(char0Type); }
    case char1Hook:
    { return sizeof(char1Type); }
    case int0Hook:
    { return sizeof(int0Type); }
    case int1Hook:
    { return sizeof(int1Type); }
    case int2Hook:
    { return sizeof(int2Type); }
    case nullHook:
    case referHook:
    case rowHook:
    { return sizeof(pointerType); }
    case procHook:
    { return sizeof(procType); }
    case real0Hook:
    { return sizeof(real0Type); }
    case real1Hook:
    { return sizeof(real1Type); }
    case skoHook:
    case varHook:
    { return typeSize(cadr(type)); }
    case strTypeHook:
    { return toInteger(cadddr(type)); }
    case tupleHook:
    { int slotAlign;
      refObject slotType;
      int tupleAlign = 1;
      int tupleSize = 0;
      type = cdr(type);
      while (type != nil)
      { slotType = car(type);
        slotAlign = typeAlign(slotType);
        tupleAlign = (slotAlign > tupleAlign ? slotAlign : tupleAlign);
        tupleSize += typeSize(slotType);
        tupleSize += rounder(tupleSize, slotAlign);
        type = cddr(type); }
      return tupleSize + rounder(tupleSize, tupleAlign); }
    case voidHook:
    { return sizeof(voidType); }
    default:
    { fail("Type has undefined size in typeSize!"); }}}
Ejemplo n.º 10
0
void
eval_transpose(void)
{
	push(cadr(p1));
	eval();
	if (cddr(p1) == symbol(NIL)) {
		push_integer(1);
		push_integer(2);
	} else {
		push(caddr(p1));
		eval();
		push(cadddr(p1));
		eval();
	}
	transpose();
}
Ejemplo n.º 11
0
void
eval_quotient(void)
{
	push(cadr(p1));			// 1st arg, p(x)
	eval();

	push(caddr(p1));		// 2nd arg, q(x)
	eval();

	push(cadddr(p1));		// 3rd arg, x
	eval();

	p1 = pop();			// default x
	if (p1 == symbol(NIL))
		p1 = symbol(SYMBOL_X);
	push(p1);

	divpoly_void();
}
Ejemplo n.º 12
0
void
eval_cofactor(void)
{
	int i, j, n;
	push(cadr(p1));
	eval();
	p2 = pop();
	if (istensor(p2) && p2->u.tensor->ndim == 2 && p2->u.tensor->dim[0] == p2->u.tensor->dim[1])
		;
	else
		stop("cofactor: 1st arg: square matrix expected");
	n = p2->u.tensor->dim[0];
	push(caddr(p1));
	eval();
	i = pop_integer();
	if (i < 1 || i > n)
		stop("cofactor: 2nd arg: row index expected");
	push(cadddr(p1));
	eval();
	j = pop_integer();
	if (j < 1 || j > n)
		stop("cofactor: 3rd arg: column index expected");
	cofactor(p2, n, i - 1, j - 1);
}
Ejemplo n.º 13
0
object *if_alternative(object *exp) {
    return is_empty(cdddr(exp)) ? make_boolean(false) : cadddr(exp);
}
Ejemplo n.º 14
0
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {

    char comeback = 1;

    while(comeback) {
        comeback = 0;

        if(is_self_evaluating(exp)) {
            return exp;
        }

        if(list_begins_with(exp, quote_symbol)) {
            return cadr(exp);
        }

        // (define... )
        if(list_begins_with(exp, define_symbol)) {

            object_t *var = cadr(exp);

            // (define a b)
            if(issymbol(var)) {
                object_t *val = caddr(exp);
                return define_var(env, var, val);
            }

            // (define (a ...) ...) TODO use scheme macro
            if(ispair(var)) {
                object_t *name = car(cadr(exp)),
                    *formals = cdr(cadr(exp)),
                    *body = cddr(exp),
                    *lambda = cons(lambda_symbol,
                                      cons(formals, body));

                exp = cons(define_symbol,
                              cons(name, cons(lambda, empty_list)));
                comeback = 1;
                continue;
            }

            fprintf(stderr, "Syntax error.\n");
            exit(-1);
        }

        // (set! a b)
        if(list_begins_with(exp, set_symbol)) {
            object_t *var = cadr(exp);
            object_t *val = caddr(exp);
            return set_var(env, var, val);
        }

        // (if c a b)
        if(list_begins_with(exp, if_symbol)) {
            exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
            comeback = 1;
            continue;
        }

        // (cond ...)
        if(list_begins_with(exp, cond_symbol)) {
            object_t *tail = cons(void_symbol, empty_list);
            object_t *ifs = tail; //empty_list;
            object_t *rules = reverse_list(cdr(exp));

            while(!isemptylist(rules)) {
                object_t *rule = car(rules),
                    *condition = car(rule),
                    *consequence = cadr(rule);

                if(isemptylist(consequence)) {
                    consequence = cons(void_obj, empty_list);
                }

                ifs = cons(if_symbol,
                              cons(condition,
                                      cons(consequence,
                                              cons(ifs, empty_list))));

                rules = cdr(rules);
            }

            exp = ifs;

            comeback = 1;
            continue;
        }

        // (begin ...)
        if(list_begins_with(exp, begin_symbol)) {

            object_t *result = empty_list, *exps;

            for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
                result = eval(car(exps), env);
            }

            return result;
        }

        if(list_begins_with(exp, lambda_symbol)) {
            object_t *fn = cons(begin_symbol,
                                    cdr(cdr(exp)));
            return make_compound_proc(empty_list, cadr(exp),
                                         fn,
                                         env);
        }

        // (let ...)
        if(list_begins_with(exp, let_symbol)) {
            //if(! issymbol(cadr(exp)))
            object_t *bindings = cadr(exp);
            object_t *body = cddr(exp);

            object_t *formals = empty_list;
            object_t *values = empty_list;

            while(!isemptylist(bindings)) {
                formals = cons(caar(bindings), formals);
                values = cons(cadr(car(bindings)), values);

                bindings = cdr(bindings);
            }

            exp = cons(cons(lambda_symbol, cons(formals, body)),
                          values);

            comeback = 1;
            continue;
        }

        if(issymbol(exp)) {
            return var_get_value(env, exp);
        }

        if(ispair(exp)) {
            object_t *exp_car = car(exp);
            object_t *fn = eval(exp_car, env); //var_get_value(env, car);
            if(!iscallable(fn)) {
                fprintf(stderr, "object_t is not callable\n");
                exit(-1);
            }

            object_t *args = cdr(exp);
            object_t *evaluated_args = evaluate_list(env, args, empty_list);

            if(isprimitiveproc(fn)) {
                return fn->value.prim_proc.fn(evaluated_args);
            } else if(iscompoundproc(fn)) {
                object_t *fn_formals = fn->value.compound_proc.formals;
                object_t *fn_body = fn->value.compound_proc.body;
                object_t *fn_env = fn->value.compound_proc.env;

                ARGS_EQ(evaluated_args, list_size(fn_formals));

                exp = fn_body;
                env = extend_environment(fn_formals, evaluated_args, fn_env);
                comeback = 1;
                continue;

            }
            assert(0);
        }

    }

    fprintf(stderr, "Unable to evaluate expression: \n");
    write(exp);
    exit(-1);
}
Ejemplo n.º 15
0
/*
 * (call <tag_ffi_cif>
 *       <closure w/C function pointer>
 *       <rvalue size in bytes>
 * )
 */
cons_t* proc_ffi_call(cons_t* p, environment_t*)
{
  assert_length(p, 2, 4);
  assert_pointer(tag_ffi_cif, car(p));
  assert_type(CLOSURE, cadr(p));
  assert_type(INTEGER, caddr(p));

  /*
   * libffi description of function.
   */

  ffi_cif *cif = static_cast<ffi_cif*>(car(p)->pointer->value);

  /*
   * Pointer to function to call.
   */

  if ( cadr(p)->closure->function == NULL )
    raise(runtime_exception(
      "Can only call foreign C functions; not Scheme procedures"));

  void (*funptr)() =
    reinterpret_cast<void(*)()>(cadr(p)->closure->function);

  /*
   * Size of return value.
   */
  integer_t size = 0;

  if ( length(p)>2 )
    size = caddr(p)->number.integer;

  if ( size < 0 )
    raise(runtime_exception(format(
      "Cannot allocate a negative number of bytes: %d", size)));

  /*
   * Allocate enough memory necessary to hold return data.
   */
  value_t *retval = new value_t(size);

  /*
   * Function arguments (currently unsupported).
   */
  void **funargs = NULL;

  if ( !nullp(cadddr(p)) ) {
    cons_t *args = cadddr(p);

    if ( length(args) != cif->nargs )
      raise(runtime_exception(format(
        "Foreign function expects %d arguments",
        cif->nargs)));

    funargs = static_cast<void**>(malloc(sizeof(void*)*(cif->nargs+1)));

    size_t n=0;
    for ( cons_t *a = args; !nullp(a); a = cdr(a), ++n ) {
      funargs[n] = make_arg(cif->arg_types[n], car(a));
    }

    funargs[cif->nargs] = NULL; // TODO: is this necessary?
  }

  /*
   * TODO: Destroy allocated funargs data after ffi_call, unless those are
   * pointer values used to store returned data.
   */

  ffi_call(cif, funptr, &retval->data, funargs);
  return pointer(tag_ffi_retval, retval);
}