示例#1
0
rs_bool BSOP_write( obj port, const char *src, UINT_32 len )
{
obj buf, fxpos;
char *ptr;
UINT_32 n, max, pos;

    buf = gvec_read( port, BSOP_BUFFER );
    fxpos = gvec_read( port, BSOP_INDEX );
    max = string_length(buf);

    assert( STRING_P(buf) );
    assert( OBJ_ISA_FIXNUM(fxpos) );

    pos = fx2int(fxpos);
    
    ptr = (char *)string_text(buf);

    if (pos + len > max)
    {
	n = max - pos;
	memcpy( ptr + pos, src, n );
	gvec_write_non_ptr( port, BSOP_INDEX, int2fx(max) );
	return NO;
    }

    memcpy( ptr + pos, src, len );
    pos += len;
    gvec_write_non_ptr( port, BSOP_INDEX, int2fx(pos) );
    return YES;
}
示例#2
0
static obj mpz_to_bignum( mpz_t n )
{
    return make3( bignum_class,
                  int2fx( n[0]._mp_alloc ),
                  int2fx( n[0]._mp_size ),
                  DATAPTR_TO_PTR( n[0]._mp_d ) );
}
示例#3
0
static obj bc_bvec_ci_hash( obj bvec, INT_32 offset, INT_32 len,
			     int fpc )
{
  if ((len < 0) || (offset < 0) || ((offset + len) > SIZEOF_PTR(bvec)))
    scheme_error( "bvec_ci_hash: range error: (bvec-ci-hash ~s ~d ~d)",
		  3, bvec, int2fx(offset), int2fx(len) );
  return bvec_ci_hash( bvec, offset, len );
}
示例#4
0
文件: vinsns.c 项目: Fuhuiang/rscheme
_rs_volatile void too_few_args( const char *fn, unsigned min_required )
{
    scheme_error( "Function ~a called with ~d args, required at least ~d",
    		  3,
		  make_string( fn ),
		  int2fx(arg_count_reg),
		  int2fx(min_required) );
}
示例#5
0
文件: vinsns.c 项目: Fuhuiang/rscheme
_rs_volatile void wrong_num_args( const char *fn, unsigned num_required )
{
    scheme_error( "Function ~a called with ~d args, required exactly ~d",
    		  3,
		  make_string( fn ),
		  int2fx(arg_count_reg),
		  int2fx(num_required) );
}
示例#6
0
obj translate_LR( RStore *in_store, struct LocationRef lr )
{
  struct PageRef ref;

  if (lr.indirect)
    {
      if (lr.first)
	{
	  struct VMPageRecord *vmpr;

	  ref.base_page_num = lr.base_page_num;
	  ref.first = 1;
	  ref.indirect = 1;
	  ref.dirty = 0;
	  ref.loaded = 0;
	  ref.nth_page = lr.nth_page;

	  vmpr = get_vmpr( in_store, &ref );

	  if (!vmpr || lr.offset > 63 || lr.nth_page != 1)
	    {
	      scheme_error( "translate_ptr(~d[~d]): illegal",
			    2, 
			    int2fx( lr.base_page_num ),
			    int2fx( lr.offset ) );
	    }
	  return ((obj *)vmpr->mem_address)[ lr.offset ];
	}
      else
	{
	  /* special hack for immobs */
	  return OBJ(lr.base_page_num);
	}
    }
  else
    {
      struct VMPageRecord *vmpr;

      ref.base_page_num = lr.base_page_num;
      ref.first = lr.first;
      ref.indirect = 0;
      ref.dirty = 0;
      ref.loaded = 0;
      ref.nth_page = lr.nth_page;
      vmpr = get_vmpr( in_store, &ref );
      if (!vmpr)
	{
	  scheme_error( "translate_ptr(~x.~04x+~x): illegal",
		        3,
		       int2fx( lr.base_page_num >> 16 ),
		       int2fx( lr.base_page_num & 0xFFFF ),
		       int2fx( lr.offset ) );

	}
      return OBJ( (UINT_32)vmpr->mem_address + lr.offset );
    }
示例#7
0
文件: vinsns.c 项目: Fuhuiang/rscheme
_rs_volatile void wrong_num_args_range( const char *fn, 
				        unsigned mn, unsigned mx )
{
    scheme_error( "Function ~a called with ~d args, expected ~d to ~d",
    		  4,
		  make_string( fn ),
		  int2fx(arg_count_reg),
		  int2fx(mn),
		  int2fx(mx) );
}
示例#8
0
static obj int_lshl(INT_32 a, INT_32 b)
{
    int am;

    if(!a)
        return int2fx(0);
    if(b > 63 || (am = (b + search_one32(a))) > 63)
        return bignum_shl(int_32_to_bignum_u(a), b);
    if(am > 30)
        return int_64_compact(int_64_shl(int_32_to_int_64(a), b));
    return int2fx(a<<b);
}
示例#9
0
文件: synch.c 项目: Fuhuiang/rscheme
static void requeue( obj thr, obj blocked_on )
{
  if (instance_p( blocked_on, mailbox_class ))
    {
      obj mbox = blocked_on;

      /* two cases to consider
       *   1. mailbox has data now
       *   2. mailbox has no data
       */
      if (truish(gvec_ref(mbox,MAILBOX_HAS_DATA_Q)) && !dequeue_empty(mbox))
	{
	  /* mark_thread_ready() will set the state to WAITING */
	  send_item_to_thread( mbox, thr, dequeue_pop_front( mbox ) );
	}
      else
	{
	  /* put it back in the wait queue */
	  gvec_write_non_ptr( mbox, MAILBOX_HAS_DATA_Q, FALSE_OBJ );
	  dequeue_push_back( mbox, thr );
	  /* now, we're blocked again */
	  gvec_set( thr, THREAD_STATE, int2fx( TSTATE_BLOCKED ) );
	}
    }
  else
    {
      /*  it can't be a <queued-output-port>, because we are only
       *  called when the thread has been ejected from the queue,
       *  and that never happens for qout's (they work like timers)
       *  -- see comments in output.c and class.scm
       */
      assert( !instance_p( blocked_on, qout_class ) );
      assert(0); /* not implemented yet... */
    }
}
示例#10
0
文件: guitk.c 项目: Fuhuiang/rscheme
void *tcl_gateway( void )
{
char **argp, *(args[102]);
Tcl_CmdInfo *info;
Tcl_Interp *interp;
char temp[1000], *d;
int i, rc;

    assert( arg_count_reg <= 100 );
    info = (Tcl_CmdInfo *)PTR_TO_DATAPTR(LEXREF0(0));
    interp = (Tcl_Interp *)OBJ_TO_RAW_PTR(LEXREF0(1));

    d = temp;
    argp = args;
    *argp++ = (char *)string_text( LEXREF0(2) );
    for (i=0; i<arg_count_reg; i++)
      {
	obj arg;

	arg = reg_ref(i);
	if (STRING_P(arg))
	  {
	    *argp++ = (char *)string_text(arg);
	  }
	else if (OBJ_ISA_FIXNUM(arg))
	  {
	    *argp++ = d;
	    sprintf( d, "%d", fx2int(arg) );
	    d += strlen(d) + 1;
	  }
	else if (SYMBOL_P(arg))
	  {
	    *argp++ = (char *)symbol_text(arg);
	  }
	else
	  {
	    scheme_error( "tcl_gateway: ~s invalid", 1, arg );
	  }
      }
    *argp++ = NULL;
    Tcl_ResetResult( interp );
    rc = info->proc( info->clientData,
		     interp,
		     arg_count_reg + 1,
		     args );
    if (rc)
      {
	REG0 = make_string( interp->result );
	REG1 = int2fx( rc );
	RETURN(2);
      }
    else
      {
	if (interp->result[0])
	  REG0 = make_string( interp->result );
	else
	  REG0 = TRUE_OBJ;
	RETURN1();
      }
}
示例#11
0
文件: misc.c 项目: Fuhuiang/rscheme
int rscheme_file_mode_to_os( int mode )
{
  int i_mode;
  i_mode = 0;

  if ((mode & 3) == 0)
    {
      i_mode = O_RDONLY;
    }
  else if ((mode & 3) == 1)
    {
      i_mode = O_WRONLY;
    }
  else if ((mode & 3) == 2)
    {
      i_mode = O_RDWR;
    }
  else
    {
      scheme_error( "file-mode->os: mode ~d is invalid", 1, int2fx(mode) );
    }

  if (mode & 4)        i_mode |= O_APPEND;
  if (mode & 8)        i_mode |= O_CREAT;
  if (mode & (1<<4))   i_mode |= O_EXCL;
  if (mode & (1<<5))   i_mode |= O_TRUNC;

  return i_mode;
}
示例#12
0
文件: synch.c 项目: Fuhuiang/rscheme
void mark_thread_suspended( obj th )
{
  obj susp_count = gvec_ref( th, THREAD_SUSPEND_COUNT );
  int still_in_q = 1;

  if (FX_LT( susp_count, ZERO ))
    {
      still_in_q = 0;
      susp_count = FX_SUB( ZERO, susp_count );
    }
  else if (EQ( susp_count, ZERO ))
    {
      /* newly suspended */
      gvec_write_non_ptr( th, THREAD_STATE, int2fx( TSTATE_SUSPEND ) );
    }

  susp_count = ADD1( susp_count );

  if (still_in_q)
    gvec_write_non_ptr( th, 
			THREAD_SUSPEND_COUNT, 
			susp_count );
  else
    gvec_write_non_ptr( th, 
			THREAD_SUSPEND_COUNT, 
			FX_SUB(ZERO,susp_count) );
}
示例#13
0
static void bc_bvec_copy(obj dst, INT_32 dst_offset,
			 obj src, INT_32 src_offset, INT_32 len,
			 int fpc )
{
  char *dst_p;
  const char *src_p;

  if ((dst_offset < 0) 
      || ((dst_offset + len) > SIZEOF_PTR(dst))
      || (src_offset < 0)
      || ((src_offset + len) > SIZEOF_PTR(src))
      || (len < 0))
    scheme_error( "bvec_copy: range error: (bvec-copy ~s ~d ~s ~d ~d)",
		  5, dst, int2fx(dst_offset), src, int2fx(src_offset),
		  int2fx(len) );
  bvec_copy( dst, dst_offset, src, src_offset, len );
}
示例#14
0
obj make_bucket( obj bucket_class, int bucket_bits )
{
  obj x;

  assert( CLASS_P(bucket_class) );
  x = gvec_alloc( (3 * BUCKET_CAPACITY) + 2, bucket_class );
  gvec_write_fresh_non_ptr( x, SLOT(0), int2fx( bucket_bits ) );
  return x;
}
示例#15
0
文件: op_str.c 项目: bitwize/rscheme
void SOP_write( obj port, const char *src, UINT_32 len )
{
  obj buf, fxpos;
  char *ptr;
  UINT_32 n, max, pos;

  buf = gvec_read( port, SOP_BUFFER );
  fxpos = gvec_read( port, SOP_INDEX );

  assert( BYTE_VECTOR_P( buf ) );
  assert( OBJ_ISA_FIXNUM( fxpos ) );

  max = SIZEOF_PTR( buf );
  pos = fx2int( fxpos );

  ptr = (char *)PTR_TO_DATAPTR( buf );

  if (pos + len >= max)
    {
      UINT_32 newbuflen;

      /*  if this write does not fit entirely within the current
       *  buffer, then we need to fill out this buffer and
       *  push it on the overflow list.
       */

      n = max - pos;
      memcpy( ptr + pos, src, n );
      src += n;
      len -= n;
      gvec_write( port,
		  SOP_OVERFLOW,
		  cons( buf, gvec_read( port, SOP_OVERFLOW ) ) );

      /*  Now we need to allocate another buffer, do the
       *  rest of the write in there, and leave it current.
       *
       *  We allocate the new buffer at least big enough to hold
       *  what's needed.
       */
      if (len > SOP_BLOCK_SIZE)
	newbuflen = len + SOP_BLOCK_SIZE;
      else
	newbuflen = SOP_BLOCK_SIZE;

      buf = alloc( newbuflen, byte_vector_class );
      gvec_write( port, SOP_BUFFER, buf );
      pos = 0;
      ptr = (char *)PTR_TO_DATAPTR( buf );
    }

  memcpy( ptr + pos, src, len );
  pos += len;

  gvec_write_non_ptr( port, SOP_INDEX, int2fx( pos ) );
}
示例#16
0
static int chkest( int is, RS_bc_datum *v, int need, UINT_8 *pc )
{
static char *(est_t[]) = { "<none>", "<obj>", "<raw-float>", "<raw-str>", "<raw-bool>", "<raw-int>", "-unknown-" };

  if (is != need && is != est_unknown)
    {
      UINT_8 *base = ((UINT_8 *)PTR_TO_DATAPTR(LITERAL(0)));

      fprintf( stderr, "bcieval stack error: PC=%d\n", pc - base );
      fprintf( stderr, "\ttype is %s (%x.%x), expected %s\n",
	      est_t[is], (v->raw_int_val) >> 2, v->raw_int_val & 3,
	      est_t[need] );
      scheme_error(
	    "bcieval stack error: type = ~d, expected ~d (~x ~x) pc=~d", 
		   5, int2fx(is), int2fx(need), 
		   (v->raw_int_val) & ~3,
		   int2fx((v->raw_int_val) & 3),
		   int2fx(pc - base) );
    }
示例#17
0
static _rs_inline obj int_minus( INT_32 a, INT_32 b )
{
    INT_32 c = a - b;
    if ((~(a ^ b) & (c ^ a)) & HIGHBIT)
    {
        INT_64 a2 = int_32_to_int_64(a);
        INT_64 b2 = int_32_to_int_64(b);
        return int_64_compact( int_64_sub( a2, b2 ) );
    }
    return int2fx( a-b );
}
示例#18
0
static obj get_bytecode_correlation( void )
{
  obj q = make_dequeue();
  int prev, op;

  for (prev=0; prev<512; prev++)
    for (op=0; op<512; op++)
      {
	int n = bci_corr[prev][op];
	if (n != 0)
	  {
	    obj entry = make3( vector_class, 
			       int2fx(n), 
			       int2fx(prev), 
			       int2fx(op) );
	    dequeue_push_back( q, entry );
	  }
      }
  return dequeue_state(q);
}
示例#19
0
static _rs_inline obj int_plus( INT_32 a, INT_32 b )
{
    INT_32 c = a + b;
    if ((~(a ^ b) & (c ^ a)) & HIGHBIT)
    {
        INT_64 a2 = int_32_to_int_64(a);
        INT_64 b2 = int_32_to_int_64(b);
        INT_64 c2 = int_64_add( a2, b2 );
        return int_64_compact( c2 );
    }
    return int2fx( c );
}
示例#20
0
static _rs_inline obj int_mul( INT_32 a, INT_32 b )
{
    INT_32 p_hi, p_lo;
    INT_64 a2, b2;

#ifdef smul_ppmm
    smul_ppmm( p_hi, p_lo, a, b );
#else
    union
    {
        int i32[2];
        long long int i64;
    } u;
    u.i64 = (long long int) a * (long long int) b;
# if __BYTE_ORDER == __LITTLE_ENDIAN
    p_hi = u.i32[0];
    p_lo = u.i32[1];
# else
    p_hi = u.i32[1];
    p_lo = u.i32[0];
# endif
#endif
    if (p_hi == 0)
    {
        if (p_lo < HIGHBIT)
        {
            return int2fx( p_lo );
        }
    }
    else if (p_hi == -1)
    {
        if (p_lo >= -HIGHBIT)
        {
            return int2fx( p_lo );
        }
    }
    a2 = int_32_to_int_64(a);
    b2 = int_32_to_int_64(b);
    return int_64_compact( int_64_mul( a2, b2 ) );
}
示例#21
0
obj string_to_fixnum( char *str_in, UINT_32 len, unsigned radix )
{
int i;
rs_bool neg = NO;
UINT_32 v, preq, prem;
UINT_8 *lim = ((UINT_8*)str_in) + len;
UINT_8 *str = (UINT_8*)str_in;

    if (*str == '-')
    {
	str++;
	neg = YES;
    }
    else if (*str == '+')
    {
	str++;
    }

    /* compute the maximum value & digit that is
       allowed BEFORE a new digit is added.
       For example, if the limit is 1024 (max 1023)
       and we're in base 10, the preq is 102 and prem is 4
       is if the value so far is 102 and we see a 4, we know
       that's too much, but if we see a 3, that's OK */

    preq = (1UL<<(WORD_SIZE_BITS-PRIMARY_TAG_SIZE-1)) / radix;
    prem = (1UL<<(WORD_SIZE_BITS-PRIMARY_TAG_SIZE-1)) % radix;

    /* printf( "preq = %d, prem = %d\n", preq, prem ); */
    
    if (str >= lim)
      return FALSE_OBJ;  /* no digits! */
    
    v = 0;
    while (str < lim)
      {
	i = digit_value( *str++ );
	if (i >= radix)
	  {
	    return FALSE_OBJ;
	  }
	if ((v > preq)
	    || ((v == preq) 
		&& ((i > prem) || ((i == prem) && !neg))))
	  {
	    /* too big -- doesn't fit as a fixnum */
	    return FALSE_OBJ;
	  }
	v = v * radix + i;
      }
    return int2fx( neg ? -v : v );
}
示例#22
0
obj float_truncate( IEEE_64 longfloat )
{
    if ((longfloat >= -536870912.0) && (longfloat <= 536870911.0)) {
        int t = (int)longfloat;
        return int2fx( t );
    } else if ((longfloat >= -9.22337e+18) && (longfloat <= 9.22337e+18)) {
        return int_64_compact( float_to_int_64( longfloat ) );
    } else {
        scheme_error( "float_truncate(~d): out of exact range",
                      1, make_float( longfloat ) );
        return FALSE_OBJ;
    }
}
示例#23
0
文件: mmglue.c 项目: Fuhuiang/rscheme
void mm_set_prot( void *base, size_t bytes, enum mm_mode new_mode )
{
  int rc;
  
  rc = mprotect( (caddr_t)base, bytes, prot[new_mode] );
  if (rc < 0)
    {
      scheme_error( "mm_set_prot: at #x~04x_~04x for ~d bytes, to ~a: ~a",
		    5,
		    int2fx( ((UINT_32)base)>>16 ),
		    int2fx( ((UINT_32)base)&0xFFFF ),
		    int2fx( bytes ),
		    make_string( protname[new_mode] ),
		    make_string( strerror(errno) ) );
    }
示例#24
0
static void fixup_fnd( struct FASL_UnswizzledFnDescr *xd )
{
  struct FASL_PartHdr *xp = xd->container;
  struct FASL_ModuleHdr *xm;
  struct part_descr *p;
  unsigned i;

  if (xd->real_fn_d) {
    return;
  }

  xm = xp->container;

  if (!xm->module)
    {
      struct module_descr *m;

      /* printf( "** mapping in %s module\n", xm->name );*/
      m = find_module( xm->name );
      if (!m) {
        char *p = strchr( xm->name, '|' );
        if (p) {
          scheme_error( "dynamic module ~s not loaded: ~a", 2, 
                        make_string( p+1 ),
                        make_string( dynamic_link_errors() ) );
        } else {
          scheme_error( "static module ~s not loaded", 1, 
                        make_string( xm->name ) );
        }
      }
      xm->module = m;
    }
  /* printf( "** mapping in %s[%d]\n", xm->name, xp->part_tag );*/
  p = find_part( xm->module, xp->part_tag );
  if (!p)
    {
      scheme_error( "module ~s is missing part ~d",
                    2,
                    make_string( xm->name ),
                    int2fx( xp->part_tag ) );
    }
  for (i=0; p->functions[i]; i++)
    {
      xp->fnds[i].real_fn_d = p->functions[i];
      xp->fnds[i].real_code_ptr = p->functions[i]->monotones[0];
    }
}
示例#25
0
文件: guitk.c 项目: Fuhuiang/rscheme
int the_callback( ClientData data, Tcl_Interp *interp,
	 	  int argc, const char **argv )
{
obj item, info = NIL_OBJ;

    while (argc > 1)
      {
	const char *a = argv[--argc];
	if (isdigit(a[0]) || a[0] == '-')
	  item = int2fx( atoi(a) );
	else
	  item = make_string(a);
	info = cons( item, info );
      }
    evts = cons( info, evts );
    return TCL_OK;
}
示例#26
0
void install_bc_extension( struct bcx_descr *extn )
{
  UINT_8 i = extn->extn_code;

  if (extension_fns[i] != NOFN)
    {
      scheme_error( "cannot load bytecode extension ~a.~a in ~d: "
		    "already loaded ~a.~a", 
		    5,
		    make_string( extn->owner->name ),
		    make_string( extn->name ),
		    int2fx(i),
		    make_string( loaded_extensions[i]->owner->name ),
		    make_string( loaded_extensions[i]->name ) );
    }
  loaded_extensions[i] = extn;
  extension_fns[i] = extn->handler;
}
示例#27
0
static obj *setup_reference_objects( obj ref_vec )
{
  UINT_32 i, n = SIZEOF_PTR(ref_vec) / SLOT(1);
  obj *saved_class;

  if (n == 0)
    return NULL;

  saved_class = (obj *)malloc( n * sizeof(obj) );
  for (i=0; i<n; i++)
    {
      obj ref_item = gvec_ref( ref_vec, SLOT(i) );
      /*printf( "REF item %08x\n", VAL(ref_item) ); */
      saved_class[i] = PTR_TO_HDRPTR(ref_item)->pob_class;
      PTR_TO_HDRPTR(ref_item)->pob_class = int2fx(1);
    }
  return saved_class;
}
示例#28
0
obj float_truncate( IEEE_64 longfloat )
{
    /** TODO:
     **   Refine these tests so that exactly the smallest type is used
     **/

    if ((longfloat >= -536870912.0) && (longfloat <= 536870911.0))
    {
        int t = (int)longfloat;
        return int2fx( t );
    }
    else if ((longfloat >= -9.22337e+18) && (longfloat <= 9.22337e+18))
    {
        return int_64_compact( float_to_int_64( longfloat ) );
    }
    else
    {
        return raw_float_to_bignum( longfloat );
    }
}
示例#29
0
obj dequeue_memq( obj deq, obj item )
{
  int j = 0;
  UINT_32 i = FXWORDS_TO_RIBYTES( DEQ_FRONT( deq ) );
  UINT_32 b = FXWORDS_TO_RIBYTES( DEQ_BACK( deq ) );
  obj state = DEQ_STATE( deq );
  UINT_32 lim = SIZEOF_PTR(state);

  while (i != b) {
    if (EQ(gvec_read( state, i ),item)) {
      return int2fx( j );
    }
    i += SLOT(1);
    if (i >= lim) {
      i = 0;
    }
    j++;
  }
  return FALSE_OBJ;
}
示例#30
0
文件: osglue.c 项目: bitwize/rscheme
obj vmake_os_error( const char *fn, int num_args, va_list va )
{
  int i, e = errno;
  obj argv, props;

  argv = alloc( SLOT(num_args), vector_class );

  for (i=0; i<num_args; i++)
    gvec_write_init( argv, SLOT(i), va_arg(va,obj) );

  props = cons( cons( lookup_symbol( "stack" ), 
                      make_exception_stack() ), 
                NIL_OBJ );

  return make4( os_error_class, 
                props,
                int2fx(e), 
                make_string( fn ),
                argv );
}