コード例 #1
0
cons_t* proc_read_from_port(cons_t* p, environment_t* e)
{
  assert_length(p, 1);
  assert_type(PORT, car(p));

  port_t* port = car(p)->port;

  FILE *f = port->file();
  std::string s;
  int ch = ' ';

  while ( ch != '\n' && !feof(f) ) {
    s += ch;
    ch = fgetc(f);
  }

  program_t *prog = parse(s, e);
  return car(prog->root);

  /*
   * TODO: If you do this:
   *
   * > (read (current-input-port))
   * (+ 1 2 3) (* 4 5 6)
   *
   * it should RETURN '(+ 1 2 3) and
   * EVALUATE (* 4 5 6) the reader should
   * stop parsing as soon as it is finished,
   * so the loop above should check balanced
   * parens. When balanced, it should bail out.
   */
}
コード例 #2
0
cons_t* proc_display(cons_t *p, environment_t*)
{
  assert_length(p, 1, 2);

  /*
   * Get port to write to.
   *
   * TODO: Should we check if the file descriptor
   *       is open?
   */
  port_t* port = &global_opts.current_output_device;

  if ( length(p) == 2 ) {
    assert_type(PORT, cadr(p));
    port = cadr(p)->port;
  }

  /*
   * TODO: Implement display in terms of (write) and
   *       use tail call elimination to be able to
   *       endlessly print circular lists.
   */
  std::string s = print(car(p));
  fwrite(s.c_str(), s.length(), 1, port->file());

  return unspecified();
}
コード例 #3
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
cons_t* proc_retval_to_u8vector(cons_t* p, environment_t*)
{
  assert_length(p, 2);
  assert_pointer(tag_ffi_retval, car(p));
  value_t* value = static_cast<value_t*>(car(p)->pointer->value);
  return bytevector(value->size, static_cast<uint8_t*>(value->data));
}
コード例 #4
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
cons_t* proc_retval_to_pointer(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_pointer(tag_ffi_retval, car(p));
  value_t* value = static_cast<value_t*>(car(p)->pointer->value);
  return pointer(tag_void_pointer, value->data);
}
コード例 #5
0
/*
 * Query sizes of basic C data types.
 *
 */
extern "C" cons_t* proc_sizeof(cons_t* p, environment_t*)
{
  static struct {
    const char* name;
    size_t size;
  } sizes[] = {
    {"char", sizeof(char)},
    {"int", sizeof(int)},
    {"long", sizeof(long)},
    {"longlong", sizeof(long long)},
    {"pointer", sizeof(void*)}, // shorthand
    {"short", sizeof(short)},
    {"void*", sizeof(void*)},
    {NULL, 0}
  };

  assert_length(p, 1);
  assert_type(SYMBOL, car(p));

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

  for ( size_t n=0; sizes[n].name != NULL; ++n )
    if ( s == sizes[n].name )
      return integer(sizes[n].size);

  // not found
  return boolean(false);
}
コード例 #6
0
ファイル: c-stdio.cpp プロジェクト: Fangang/mickey-scheme
/*
 * (fclose <file-obj>)
 */
cons_t* proc_fclose(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_pointer("FILE*", car(p));
  FILE *f = reinterpret_cast<FILE*>(car(p)->pointer->value);
  return !fclose(f)? nil() : boolean(false);
}
コード例 #7
0
cons_t* proc_env_assign(cons_t* p, environment_t*)
{
  assert_length(p, 3);
  assert_type(ENVIRONMENT, car(p));
  assert_type(SYMBOL, cadr(p));

  const std::string name = symbol_name(cadr(p));
  environment_t *e = car(p)->environment;
  cons_t *value = caddr(p);

  if ( value == NULL )
    raise(runtime_exception(
      "Symbol is not bound in any environment: " + name));

  environment_t *i = e;

  // search for definition and set if found
  for ( ; i != NULL; i = i->outer ) {
    if ( i->symbols.find(name) != i->symbols.end() ) {
      i->symbols[name] = value;
      return nil();
    }
  }

  // only set if NOT found
  if ( i == NULL )
    e->define(name, value);

  return nil();
}
コード例 #8
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
cons_t* proc_retval_to_uchar(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_pointer(tag_ffi_retval, car(p));
  value_t* value = static_cast<value_t*>(car(p)->pointer->value);
  return character(value->character());
}
コード例 #9
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
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.
   */
}
コード例 #10
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
/*
 * (make-type (<type1> <type2>) size alignment)
 */
cons_t* proc_make_type(cons_t* p, environment_t*)
{
  cons_t *types = car(p),
          *size = cadr(p),
         *align = caddr(p);

  assert_length(p, 3);
  assert_type(PAIR, types);
  assert_type(INTEGER, size);
  assert_type(INTEGER, align);

  const size_t ntypes = length(types);

  if ( ntypes == 0 )
    raise(runtime_exception("No types given"));

  ffi_type *t = new ffi_type();
  t->size      = size->number.integer;
  t->alignment = align->number.integer;
  t->elements  = new ffi_type*[1+ntypes];
  t->elements[ntypes] = NULL;

  p = types;
  for ( size_t n=0; n<ntypes; ++n ) {
    t->elements[n] = parse_ffi_type(car(p));
    p = cdr(p);
  }

  return pointer(tag_ffi_type, t);
}
コード例 #11
0
cons_t* proc_positivep(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));
  return boolean(integerp(car(p)) ? car(p)->number.integer > 0 :
                                    car(p)->number.real > 0);
}
コード例 #12
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
cons_t* proc_retval_to_double(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_pointer(tag_ffi_retval, car(p));
  value_t* value = static_cast<value_t*>(car(p)->pointer->value);
  return real(value->real_double());
}
コード例 #13
0
ファイル: c-stdio.cpp プロジェクト: Fangang/mickey-scheme
cons_t* proc_feof(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_pointer("FILE*", car(p));
  FILE *f = reinterpret_cast<FILE*>(car(p)->pointer->value);
  return boolean(feof(f) != 0);
}
コード例 #14
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
cons_t* proc_version(cons_t* p, environment_t*)
{
  assert_length(p, 0);
#ifdef PACKAGE_VERSION
  return string(PACKAGE_VERSION);
#else
  return string("<unknown version>");
#endif
}
コード例 #15
0
cons_t* proc_env_parent(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_type(ENVIRONMENT, car(p));

  if ( car(p)->environment->outer == NULL )
    raise(runtime_exception("Environment has no parent"));

  return environment(car(p)->environment->outer);
}
コード例 #16
0
cons_t* proc_truncate(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));

  if ( integerp(car(p)) )
    return integer(car(p)->number.integer);
  else
    return real(truncf(car(p)->number.real));
}
コード例 #17
0
cons_t* proc_env_eval(cons_t* p, environment_t* e)
{
  assert_length(p, 2);

  // evaluate environment argument
  cons_t *env = eval(cadr(p), e);
  assert_type(ENVIRONMENT, env);

  return eval(car(p), env->environment);
}
コード例 #18
0
cons_t* proc_nanp(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));

  if ( realp(car(p)) )
    return boolean(std::isnan(car(p)->number.real));

  return boolean(false);
}
コード例 #19
0
cons_t* proc_infinitep(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));

  if ( type_of(car(p)) == INTEGER )
    return boolean(false);

  return boolean(std::fpclassify(car(p)->number.real) == FP_INFINITE);
}
コード例 #20
0
cons_t* proc_finitep(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));

  if ( type_of(car(p)) == INTEGER )
    return boolean(true);

  return boolean(std::isfinite(car(p)->number.real));
}
コード例 #21
0
cons_t* proc_expt(cons_t* p, environment_t*)
{
  assert_length(p, 2);

  cons_t *base = car(p),
         *expn = cadr(p);

  assert_number(base);
  assert_number(expn);

  bool exact = integerp(base) && integerp(expn);

  if ( exact ) {
    int a = base->number.integer,
        n = expn->number.integer,
        r = a;

    // Per definition
    if ( n == 0 )
      return integer(1);

    if ( n < 0 )
      raise(runtime_exception("Negative exponents not implemented"));

    // This is a slow version
    // TODO: Implement O(log n) version
    while ( n-- > 1 )
      r *= a;

    return integer(r);
  }

  // Floating point exponentiation
  real_t a = number_to_real(base),
            n = number_to_real(expn),
            r = a;

  if ( n == 0.0 )
    return real(1.0);

  if ( n < 0.0 )
    raise(runtime_exception("Negative exponents not implemented"));

  while ( floor(n) > 1.0 ) {
    r *= a;
    n -= 1.0;
  }

  if ( n > 1.0 )
    raise(runtime_exception("Fractional exponents not supported"));

  // TODO: Compute r^n, where n is in [0..1)
  return real(r);
}
コード例 #22
0
ファイル: ffi.cpp プロジェクト: cslarsen/mickey-scheme
/*
 * (return-value->string <retval>)
 *
 * USE AT YOUR OWN RISK! :-)
 */
cons_t* proc_retval_to_string(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_pointer(tag_ffi_retval, car(p));

  /*
   * Note that string() duplicates the string, so this is a bit potential
   * risk. We'll assume the authors know they're doing :-)
   */
  value_t* value = static_cast<value_t*>(car(p)->pointer->value);
  return string(value->string());
}
コード例 #23
0
extern "C" cons_t* proc_gethostname(cons_t* p, environment_t*)
{
  assert_length(p, 0);

  size_t len = 1+sysconf(_SC_HOST_NAME_MAX);
  char *s = static_cast<char*>(malloc(sizeof(char)*len));
  gethostname(s, len);
  cons_t *r = string(s);
  free(s);

  return r;
}
コード例 #24
0
cons_t* proc_env_boundp(cons_t* p, environment_t*)
{
  assert_length(p, 2);
  assert_type(ENVIRONMENT, car(p));
  assert_type(SYMBOL, cadr(p));

  const std::string name = symbol_name(cadr(p));
  environment_t *e = car(p)->environment;

  // follow parent environments
  return boolean(e->lookup(name) != NULL);
}
コード例 #25
0
cons_t* proc_round(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));

  if ( integerp(car(p)) )
    return integer(car(p)->number.integer);
  else if ( rationalp(car(p)) )
    return real(roundf(make_inexact(car(p))->number.real));

  assert_type(REAL, car(p));
  return real(roundf(car(p)->number.real));
}
コード例 #26
0
ファイル: c-stdio.cpp プロジェクト: Fangang/mickey-scheme
/*
 * (freopen <filename>) <mode> <file-obj>)
 */
cons_t* proc_freopen(cons_t* p, environment_t*)
{
  assert_length(p, 3);
  assert_type(STRING, car(p));
  assert_type(STRING, cadr(p));
  assert_pointer("FILE*", caddr(p));

  const char* filename = car(p)->string;
  const char* mode = cadr(p)->string;
  FILE* f = reinterpret_cast<FILE*>(caddr(p)->pointer->value);

  return !freopen(filename, mode, f)? nil() : boolean(false);
}
コード例 #27
0
cons_t* proc_exact_to_inexact(cons_t* p, environment_t*)
{
  assert_length(p, 1);

  cons_t *q = car(p);
  assert_number(q);
  assert_exact(q);

  cons_t *r = new cons_t();
  *r = *q;
  r->number.exact = false;
  return r;
}
コード例 #28
0
cons_t* proc_abs(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_number(car(p));

  if ( realp(car(p)) ) {
    real_t n = car(p)->number.real;
    return real(n<0.0? -n : n);
  }

  int n = car(p)->number.integer;
  return integer(n<0? -n : n);
}
コード例 #29
0
cons_t* proc_env_lookup(cons_t* p, environment_t*)
{
  assert_length(p, 2);
  assert_type(ENVIRONMENT, car(p));
  assert_type(SYMBOL, cadr(p));

  const std::string name = symbol_name(cadr(p));
  environment_t *e = car(p)->environment;

  // follow parent environments, don't signal error
  // if not found (TODO: Correct?)
  return nil_coalesce(e->lookup(name));
}
コード例 #30
0
extern "C" cons_t* proc_usleep(cons_t* p, environment_t*)
{
  assert_length(p, 1);
  assert_type(INTEGER, car(p));

  int usecs = car(p)->number.integer;

  if ( usecs < 0 )
    raise(runtime_exception("usleep doesn't like negative time"));

  // TODO: If it returns -1, lookup error and return it
  return integer(usleep(usecs));
}