예제 #1
0
파일: stream.c 프로젝트: shanelle794/theqvd
LispObj *
Lisp_RenameFile(LispBuiltin *builtin)
/*
 rename-file filename new-name
 */
{
    int code;
    GC_ENTER();
    char *from, *to;
    LispObj *old_truename, *new_truename;

    LispObj *filename, *new_name;

    new_name = ARGUMENT(1);
    filename = ARGUMENT(0);

    if (STRINGP(filename)) {
	filename = APPLY1(Oparse_namestring, filename);
	GC_PROTECT(filename);
    }
    else if (STREAMP(filename)) {
	if (filename->data.stream.type != LispStreamFile)
	    LispDestroy("%s: %s is not a FILE-STREAM",
			STRFUN(builtin), STROBJ(filename));
	filename = filename->data.stream.pathname;
    }
    else {
	CHECK_PATHNAME(filename);
    }
    old_truename = APPLY1(Otruename, filename);
    GC_PROTECT(old_truename);

    if (STRINGP(new_name)) {
	new_name = APPLY3(Oparse_namestring, new_name, NIL, filename);
	GC_PROTECT(new_name);
    }
    else {
	CHECK_PATHNAME(new_name);
    }

    from = THESTR(CAR(filename->data.pathname));
    to = THESTR(CAR(new_name->data.pathname));
    code = LispRename(from, to);
    if (code)
	LispDestroy("%s: rename(%s, %s): %s",
		    STRFUN(builtin), from, to, strerror(errno));
    GC_LEAVE();

    new_truename = APPLY1(Otruename, new_name);
    RETURN_COUNT = 2;
    RETURN(0) = old_truename;
    RETURN(1) = new_truename;

    return (new_name);
}
예제 #2
0
파일: eval3.c 프로젝트: NV/nile
static oop newArray(int tally)
{
  oop elts= _newOops(_Array, sizeof(oop) * tally);	GC_PROTECT(elts);
  oop obj=   newOops( Array);				GC_UNPROTECT(elts);
  set(obj, Array,_array, elts);
  return obj;
}
예제 #3
0
/** \par
 Potion's GC is a generational copying GC. This is why the
 volatile keyword is used so liberally throughout the source
 code. PN types may suddenly move during any collection phase.
 They move from the birth area to the old area.

 Potion actually begins by allocating an old area. This is for
 two reasons. First, the script may be too short to require an
 old area, so we want to avoid allocating two areas to start with.
 And second, since Potion loads its core classes into GC first,
 we save ourselves a severe promotion step by beginning with an
 automatic promotion to second generation. (Oh and this allows
 the core Potion struct pointer to be non-volatile.)

 In short, this first page is never released, since the GC struct
 itself is on that page.

 While this may pay a slight penalty in memory size for long-running
 scripts, perhaps I could add some occassional compaction to solve
 that as well.
 \sa potion_init() which calls GC_PROTECT()
*/
Potion *potion_gc_boot(void *sp) {
  Potion *P;
  int bootsz = POTION_MIN_BIRTH_SIZE;
  void *page1 = pngc_page_new(&bootsz, 0);
  if (page1 == NULL)
    potion_fatal("Not enough memory");
  struct PNMemory *M = (struct PNMemory *)page1;
  PN_MEMZERO(M, struct PNMemory);
#ifdef DEBUG
  M->time = 0.0;
#endif

  SET_GEN(birth, page1, bootsz);
  SET_STOREPTR(4);

  // stack must be 16-byte aligned on amd64 SSE or __APPLE__, and 32-byte with AVX instrs.
  // at least amd64 atof() does SSE register return.
#if (PN_SIZE_T == 8) || defined(__APPLE__)
  M->cstack = (((_PN)sp & ((1<<5)-1)) == 0 )
    ? sp : (void *)(_PN)((_PN)sp | ((1<<5)-1) )+1;
#else
  M->cstack = sp;
#endif
  P = (Potion *)((char *)M + PN_ALIGN(sizeof(struct PNMemory), 8));
  PN_MEMZERO(P, Potion);
  P->mem = M;

  M->birth_cur = (void *)((char *)P + PN_ALIGN(sizeof(Potion), 8));
  GC_PROTECT(P);
  return P;
}
예제 #4
0
파일: stream.c 프로젝트: shanelle794/theqvd
LispObj *
Lisp_DeleteFile(LispBuiltin *builtin)
/*
 delete-file filename
 */
{
    GC_ENTER();
    LispObj *filename;

    filename = ARGUMENT(0);

    if (STRINGP(filename)) {
	filename = APPLY1(Oparse_namestring, filename);
	GC_PROTECT(filename);
    }
    else if (STREAMP(filename)) {
	if (filename->data.stream.type != LispStreamFile)
	    LispDestroy("%s: %s is not a FILE-STREAM",
			STRFUN(builtin), STROBJ(filename));
	filename = filename->data.stream.pathname;
    }
    else {
	CHECK_PATHNAME(filename);
    }
    GC_LEAVE();

    return (LispUnlink(THESTR(CAR(filename->data.pathname))) ? NIL : T);
}
예제 #5
0
파일: eval3.c 프로젝트: NV/nile
static oop newString(char *cstr)
{
  size_t len= strlen(cstr) + 1;
  char *gstr= GC_malloc_atomic(len);
  memcpy(gstr, cstr, len);			GC_PROTECT(gstr);
  oop obj= newOops(String);
  set(obj, String,bits, gstr);			GC_UNPROTECT(gstr);
  return obj;
}
예제 #6
0
파일: gc.c 프로젝트: jbulow/modernity
void *mklist(int n)
{
  struct cell *cell;
  if (!n) return 0;
  cell= GC_malloc(8);  ++objs;  bytes += 8;
  GC_PROTECT(cell);
  cell->tag= n << 1 | 1;
  cell->next= mklist(n - 1);
  GC_UNPROTECT(cell);
  return cell;
}
예제 #7
0
파일: string.c 프로젝트: 8l/xedit
/* XXX preserve-whitespace is being ignored */
LispObj *
Lisp_ReadFromString(LispBuiltin *builtin)
/*
 read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace
 */
{
    GC_ENTER();
    char *string;
    LispObj *stream, *result;
    long length, start, end, bytes_read;

    LispObj *ostring, *eof_error_p, *eof_value, *ostart, *oend;

    oend = ARGUMENT(4);
    ostart = ARGUMENT(3);
    eof_value = ARGUMENT(2);
    eof_error_p = ARGUMENT(1);
    ostring = ARGUMENT(0);

    CHECK_STRING(ostring);
    string = THESTR(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &length);

    if (start > 0 || end < length)
	length = end - start;
    stream = LSTRINGSTREAM(string + start, STREAM_READ, length);

    if (eof_value == UNSPEC)
	eof_value = NIL;

    LispPushInput(stream);
    result = LispRead();
    /* stream->data.stream.source.string->input is
     * the offset of the last byte read in string */
    bytes_read = stream->data.stream.source.string->input;
    LispPopInput(stream);

    if (result == NULL) {
	if (eof_error_p == NIL)
	    result = eof_value;
	else
	    LispDestroy("%s: unexpected end of input", STRFUN(builtin));
    }

    GC_PROTECT(result);
    RETURN(0) = FIXNUM(start + bytes_read);
    RETURN_COUNT = 1;
    GC_LEAVE();

    return (result);
}
예제 #8
0
파일: eval4.c 프로젝트: jbulow/maru-3
static oop readList(FILE *fp, int delim)
{
    oop head= nil, tail= head, obj= nil;
    GC_PROTECT(head);
    GC_PROTECT(obj);
    obj= read(fp);
    if (obj == (oop)EOF) goto eof;
    head= tail= newPair(obj, nil);
    for (;;) {
        obj= read(fp);
        if (obj == (oop)EOF) goto eof;
        if (obj == s_dot) {
            obj= read(fp);
            if (obj == (oop)EOF) {
                printf("missing item after .");
                exit(1);
            }
            tail= set(tail, Pair,tail, obj);
            obj= read(fp);
            if (obj != (oop)EOF) {
                printf("extra item after .");
                exit(1);
            }
            goto eof;
        }
        obj= newPair(obj, nil);
        tail= set(tail, Pair,tail, obj);
    }
eof:
    ;
    int c= getc(fp);
    if (c != delim) {
        fprintf(stderr, "EOF while reading list\n");
        exit(1);
    }
    GC_UNPROTECT(obj);
    GC_UNPROTECT(head);
    return head;
}
예제 #9
0
파일: eval3.c 프로젝트: NV/nile
static oop intern(char *cstr)
{
  oop list= nil;
  for (list= symbols;  is(Pair, list);  list= getTail(list)) {
    oop sym= getHead(list);
    if (!strcmp(cstr, get(sym, Symbol,bits))) return sym;
  }
  oop sym= nil;
  GC_PROTECT(sym);
  sym= newSymbol(cstr);
  symbols= newPair(sym, symbols);
  GC_UNPROTECT(sym);
  return sym;
}
예제 #10
0
파일: gc.c 프로젝트: adamsanderson/potion
//
// Potion's GC is a generational copying GC. This is why the
// volatile keyword is used so liberally throughout the source
// code. PN types may suddenly move during any collection phase.
// They move from the birth area to the old area.
//
// Potion actually begins by allocating an old area. This is for
// two reasons. First, the script may be too short to require an
// old area, so we want to avoid allocating two areas to start with.
// And second, since Potion loads its core classes into GC first,
// we save ourselves a severe promotion step by beginning with an
// automatic promotion to second generation. (Oh and this allows
// the core Potion struct pointer to be non-volatile.)
//
// In short, this first page is never released, since the GC struct
// itself is on that page.
//
// While this may pay a slight penalty in memory size for long-running
// scripts, perhaps I could add some occassional compaction to solve
// that as well.
//
Potion *potion_gc_boot(void *sp) {
  Potion *P;
  int bootsz = POTION_MIN_BIRTH_SIZE;
  void *page1 = pngc_page_new(&bootsz, 0);
  struct PNMemory *M = (struct PNMemory *)page1;
  PN_MEMZERO(M, struct PNMemory);

  SET_GEN(birth, page1, bootsz);
  SET_STOREPTR(4);

  M->cstack = sp;
  P = (Potion *)((char *)M + PN_ALIGN(sizeof(struct PNMemory), 8));
  PN_MEMZERO(P, Potion);
  P->mem = M;

  M->birth_cur = (void *)((char *)P + PN_ALIGN(sizeof(Potion), 8));
  GC_PROTECT(P);
  return P;
}
예제 #11
0
static void potion_init(Potion *P) {
  PN vtable, obj_vt;
  P->lobby = potion_type_new(P, PN_TLOBBY, 0);
  vtable = potion_type_new(P, PN_TVTABLE, P->lobby);
  obj_vt = potion_type_new(P, PN_TOBJECT, P->lobby);
  potion_type_new(P, PN_TNIL, obj_vt);
  potion_type_new(P, PN_TNUMBER, obj_vt);
  potion_type_new(P, PN_TBOOLEAN, obj_vt);
  potion_type_new(P, PN_TSTRING, obj_vt);
  potion_type_new(P, PN_TTABLE, obj_vt);
  potion_type_new(P, PN_TCLOSURE, obj_vt);
  potion_type_new(P, PN_TTUPLE, obj_vt);
  potion_type_new(P, PN_TFILE, obj_vt);
  potion_type_new(P, PN_TSTATE, obj_vt);
  potion_type_new(P, PN_TSOURCE, obj_vt);
  potion_type_new(P, PN_TBYTES, obj_vt);
  potion_type_new(P, PN_TPROTO, obj_vt);
  potion_type_new(P, PN_TWEAK, obj_vt);
  potion_type_new(P, PN_TLICK, obj_vt);
  potion_type_new(P, PN_TERROR, obj_vt);
  potion_type_new(P, PN_TCONT, obj_vt);
  potion_type_new(P, PN_TDECIMAL, obj_vt);

  potion_str_hash_init(P);
  PN_STR0 = PN_STRN("", 0);
  PN_add  = PN_STRN("+", 1);
  PN_sub  = PN_STRN("-", 1);
  PN_mult = PN_STRN("*", 1);
  PN_div  = PN_STRN("/", 1);
  PN_rem  = PN_STRN("%", 1);
  PN_bitn = PN_STRN("~", 1);
  PN_bitl = PN_STRN("<<", 2);
  PN_bitr = PN_STRN(">>", 2);
  PN_if   = PN_STRN("if", 2);
  PN_def = PN_STRN("def", 3);
  PN_cmp = PN_STRN("cmp", 3);
  PN_call = PN_STRN("call", 4);
  PN_else = PN_STRN("else", 4);
  PN_loop = PN_STRN("loop", 4);
  PN_self = PN_STRN("self", 4);
  PN_name = PN_STRN("name", 4);
  PN_size = PN_STRN("size", 4);
  PN_break = PN_STRN("break", 5);
  PN_class = PN_STRN("class", 5);
  PN_elsif = PN_STRN("elsif", 5);
  PN_print = PN_STRN("print", 5);
  PN_while = PN_STRN("while", 5);
  PN_length = PN_STRN("length", 6);
  PN_return = PN_STRN("return", 6);
  PN_string = PN_STRN("string", 6);
  PN_lookup = PN_STRN("lookup", 6);
  PN_number = PN_STRN("number", 6);
  PN_compile = PN_STRN("compile", 7);
  PN_allocate = PN_STRN("allocate", 8);
  PN_continue = PN_STRN("continue", 8);
  PN_delegated = PN_STRN("delegated", 9);

  potion_def_method(P, 0, vtable, PN_lookup, PN_FUNC(potion_lookup, 0));
  potion_def_method(P, 0, vtable, PN_def, PN_FUNC(potion_def_method, "name=S,block=&"));
  potion_send(vtable, PN_def, PN_allocate, PN_FUNC(potion_allocate, 0));
  potion_send(vtable, PN_def, PN_delegated, PN_FUNC(potion_delegated, 0));

  potion_vm_init(P);
  potion_lobby_init(P);
  potion_object_init(P);
  potion_error_init(P);
#ifndef DISABLE_CALLCC
  potion_cont_init(P);
#endif
  potion_primitive_init(P);
  potion_num_init(P);
  potion_str_init(P);
  potion_table_init(P);
  potion_source_init(P);
  potion_lick_init(P);
  potion_compiler_init(P);
#ifndef SANDBOX
  potion_file_init(P);
  potion_loader_init(P);
#endif

  pn_filenames = PN_TUP0();

  GC_PROTECT(P);
}
예제 #12
0
파일: gc.c 프로젝트: jbulow/modernity
int main()
{
  int i, j;
  void *a, *b, *c, *d, *e;
  for (i= 0;  i < 10000;  ++i) {
    a= 0;  GC_PROTECT(a);
    b= 0;  GC_PROTECT(b);
    c= 0;  GC_PROTECT(c);
    d= 0;  GC_PROTECT(d);
    e= 0;  GC_PROTECT(e);
#if !VERBOSE
# define printf(...)
#endif
    //#define GC_malloc malloc
    //#define GC_free free
    a= GC_malloc(RAND(1));	    printf("%p\n", a);	++objs;
    b= GC_malloc(RAND(10));	    printf("%p\n", b);	++objs;
    c= GC_malloc(RAND(100));	    printf("%p\n", c);	++objs;
    d= GC_malloc(RAND(1000));	    printf("%p\n", d);	++objs;
    e= GC_malloc(RAND(10000));	    printf("%p\n", e);	++objs;
    GC_free(a);  a= 0;
    GC_free(b);  b= 0;
    //    GC_free(c);
    GC_free(d);  d= 0;
    GC_free(e);  e= 0;
    a= GC_malloc(RAND(100));	    printf("%p\n", a);	++objs;
    b= GC_malloc(RAND(200));	    printf("%p\n", b);	++objs;
    c= GC_malloc(RAND(300));	    printf("%p\n", c);	++objs;
    d= GC_malloc(RAND(400));	    printf("%p\n", d);	++objs;
    e= GC_malloc(RAND(500));	    printf("%p\n", e);	++objs;
    GC_free(e);  e= 0;
    GC_free(d);  d= 0;
    //    GC_free(c);
    GC_free(b);  b= 0;
    GC_free(a);  a= 0;
    a= GC_malloc(RAND(4));	    printf("%p\n", a);	++objs;
    b= GC_malloc(RAND(16));	    printf("%p\n", b);	++objs;
    c= GC_malloc(RAND(64));	    printf("%p\n", c);	++objs;
    d= GC_malloc(RAND(256));	    printf("%p\n", d);	++objs;
    e= GC_malloc(RAND(1024));	    printf("%p\n", e);	++objs;
    GC_free(e);  e= 0;
    GC_free(b);  b= 0;
    //    GC_free(c);
    GC_free(d);  d= 0;
    GC_free(a);  a= 0;
    a= GC_malloc(RAND(713));	    printf("%p\n", a);	++objs;
    b= GC_malloc(RAND(713));	    printf("%p\n", b);	++objs;
    c= GC_malloc(RAND(713));	    printf("%p\n", c);	++objs;
    d= GC_malloc(RAND(713));	    printf("%p\n", d);	++objs;
    e= GC_malloc(RAND(713));	    printf("%p\n", e);	++objs;
    GC_free(a);  a= 0;
    GC_free(c);  c= 0;
    //    GC_free(e);
    GC_free(d);  d= 0;
    GC_free(b);  b= 0;
#undef printf
    if (i % 1000 == 0) printf("alloc: %ld bytes in %ld objects; alive: %ld bytes in %ld objects\n", bytes, objs, GC_count_bytes(), GC_count_objects());
    GC_gcollect();
    if (i % 1000 == 0) printf("   gc: %ld bytes in %ld objects; alive: %ld bytes in %ld objects\n", bytes, objs, GC_count_bytes(), GC_count_objects());
    GC_UNPROTECT(a);
  }
  {
    a= 0;
    GC_PROTECT(a);
    for (i= 0;  i < 10;  ++i) {
      for (j= 0;  j < 100;  ++j) {
	a= mklist(2000);
	delist(a);
#if VERBOSE
	{
	  struct cell *c= a;
	  printf("----\n");
	  while (c) {
	    printf("%p %d %p\n", c, c->tag >> 1, c->next);
	    c= c->next;
	  }
	}
#endif
      }
    printf("alloc: %ld bytes in %ld objects; alive: %ld bytes in %ld objects\n", bytes, objs, GC_count_bytes(), GC_count_objects());
    GC_gcollect();
    printf("   gc: %ld bytes in %ld objects; alive: %ld bytes in %ld objects\n", bytes, objs, GC_count_bytes(), GC_count_objects());
    }
    GC_UNPROTECT(a);
  }
  printf("alive: %ld bytes in %ld objects\n", GC_count_bytes(), GC_count_objects());
  GC_gcollect();
  printf("   gc: %ld bytes in %ld objects\n", GC_count_bytes(), GC_count_objects());
  printf("   gc: %ld collections\n", GC_collections);
  return 0;
}
예제 #13
0
파일: stream.c 프로젝트: shanelle794/theqvd
LispObj *
Lisp_Open(LispBuiltin *builtin)
/*
 open filename &key direction element-type if-exists if-does-not-exist external-format
 */
{
    GC_ENTER();
    char *string;
    LispObj *stream = NIL;
    int mode, flags, direction, exist, noexist, file_exist;
    LispFile *file;

    LispObj *filename, *odirection, *element_type, *if_exists,
	    *if_does_not_exist, *external_format;

    external_format = ARGUMENT(5);
    if_does_not_exist = ARGUMENT(4);
    if_exists = ARGUMENT(3);
    element_type = ARGUMENT(2);
    odirection = ARGUMENT(1);
    filename = ARGUMENT(0);

    if (STRINGP(filename)) {
	filename = APPLY1(Oparse_namestring, filename);
	GC_PROTECT(filename);
    }
    else if (STREAMP(filename)) {
	if (filename->data.stream.type != LispStreamFile)
	    LispDestroy("%s: %s is not a FILE-STREAM",
			STRFUN(builtin), STROBJ(filename));
	filename = filename->data.stream.pathname;
    }
    else {
	CHECK_PATHNAME(filename);
    }

    if (odirection != UNSPEC) {
	direction = -1;
	if (KEYWORDP(odirection)) {
	    if (odirection == Kprobe)
		direction = DIR_PROBE;
	    else if (odirection == Kinput)
		direction = DIR_INPUT;
	    else if (odirection == Koutput)
		direction = DIR_OUTPUT;
	    else if (odirection == Kio)
		direction = DIR_IO;
	}
	if (direction == -1)
	    LispDestroy("%s: bad :DIRECTION %s",
			STRFUN(builtin), STROBJ(odirection));
    }
    else
	direction = DIR_INPUT;

    if (element_type != UNSPEC) {
	/* just check argument... */
	if (SYMBOLP(element_type) &&
	    ATOMID(element_type) == Scharacter)
	    ;	/* do nothing */
	else if (KEYWORDP(element_type) &&
	    ATOMID(element_type) == Sdefault)
	    ;	/* do nothing */
	else
	    LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s",
			STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type));
    }

    if (if_exists != UNSPEC) {
	exist = -1;
	if (if_exists == NIL)
	    exist = EXT_NIL;
	else if (KEYWORDP(if_exists)) {
	    if (if_exists == Kerror)
		exist = EXT_ERROR;
	    else if (if_exists == Knew_version)
		exist = EXT_NEW_VERSION;
	    else if (if_exists == Krename)
		exist = EXT_RENAME;
	    else if (if_exists == Krename_and_delete)
		exist = EXT_RENAME_DELETE;
	    else if (if_exists == Koverwrite)
		exist = EXT_OVERWRITE;
	    else if (if_exists == Kappend)
		exist = EXT_APPEND;
	    else if (if_exists == Ksupersede)
		exist = EXT_SUPERSEDE;
	}
	if (exist == -1)
	    LispDestroy("%s: bad :IF-EXISTS %s",
			STRFUN(builtin), STROBJ(if_exists));
    }
    else
	exist = EXT_ERROR;

    if (if_does_not_exist != UNSPEC) {
	noexist = -1;
	if (if_does_not_exist == NIL)
	    noexist = NOEXT_NIL;
	if (KEYWORDP(if_does_not_exist)) {
	    if (if_does_not_exist == Kerror)
		noexist = NOEXT_ERROR;
	    else if (if_does_not_exist == Kcreate)
		noexist = NOEXT_CREATE;
	}
	if (noexist == -1)
	    LispDestroy("%s: bad :IF-DOES-NO-EXISTS %s",
			STRFUN(builtin), STROBJ(if_does_not_exist));
    }
    else
	noexist = direction != DIR_INPUT ? NOEXT_NOTHING : NOEXT_ERROR;

    if (external_format != UNSPEC) {
	/* just check argument... */
	if (SYMBOLP(external_format) &&
	    ATOMID(external_format) == Scharacter)
	    ;	/* do nothing */
	else if (KEYWORDP(external_format) &&
	    ATOMID(external_format) == Sdefault)
	    ;	/* do nothing */
	else
	    LispDestroy("%s: only :%s and %s supported for :EXTERNAL-FORMAT, not %s",
			STRFUN(builtin), Sdefault, Scharacter, STROBJ(external_format));
    }

    /* string representation of pathname */
    string = THESTR(CAR(filename->data.pathname));
    mode = 0;

    file_exist = access(string, F_OK) == 0;
    if (file_exist) {
	if (exist == EXT_NIL) {
	    GC_LEAVE();
	    return (NIL);
	}
    }
    else {
	if (noexist == NOEXT_NIL) {
	    GC_LEAVE();
	    return (NIL);
	}
	if (noexist == NOEXT_ERROR)
	    LispDestroy("%s: file %s does not exist",
			STRFUN(builtin), STROBJ(CAR(filename->data.quote)));
	else if (noexist == NOEXT_CREATE) {
	    LispFile *tmp = LispFopen(string, FILE_WRITE);

	    if (tmp)
		LispFclose(tmp);
	    else
		LispDestroy("%s: cannot create file %s",
			    STRFUN(builtin),
			    STROBJ(CAR(filename->data.quote)));
	}
    }

    if (direction == DIR_OUTPUT || direction == DIR_IO) {
	if (file_exist) {
	    if (exist == EXT_ERROR)
		LispDestroy("%s: file %s already exists",
			    STRFUN(builtin), STROBJ(CAR(filename->data.quote)));
	    if (exist == EXT_RENAME) {
		/* Add an ending '~' at the end of the backup file */
		char tmp[PATH_MAX + 1];

		strcpy(tmp, string);
		if (strlen(tmp) + 1 > PATH_MAX)
		    LispDestroy("%s: backup name for %s too long",
				STRFUN(builtin),
				STROBJ(CAR(filename->data.quote)));
		strcat(tmp, "~");
		if (rename(string, tmp))
		    LispDestroy("%s: rename: %s",
				STRFUN(builtin), strerror(errno));
		mode |= FILE_WRITE;
	    }
	    else if (exist == EXT_OVERWRITE)
		mode |= FILE_WRITE;
	    else if (exist == EXT_APPEND)
		mode |= FILE_APPEND;
	}
	else
	    mode |= FILE_WRITE;
	if (direction == DIR_IO)
	    mode |= FILE_IO;
    }
    else
	mode |= FILE_READ;

    file = LispFopen(string, mode);
    if (file == NULL)
	LispDestroy("%s: open: %s", STRFUN(builtin), strerror(errno));

    flags = 0;
    if (direction == DIR_PROBE) {
	LispFclose(file);
	file = NULL;
    }
    else {
	if (direction == DIR_INPUT || direction == DIR_IO)
	    flags |= STREAM_READ;
	if (direction == DIR_OUTPUT || direction == DIR_IO)
	    flags |= STREAM_WRITE;
    }
    stream = FILESTREAM(file, filename, flags);
    GC_LEAVE();

    return (stream);
}
예제 #14
0
파일: regex.c 프로젝트: 8l/xedit
LispObj *
Lisp_Reexec(LispBuiltin *builtin)
/*
 re-exec regex string &key count start end notbol noteol
 */
{
    size_t nmatch;
    re_mat match[10];
    long start, end, length;
    int code, cflags, eflags;
    char *string;
    LispObj *result;
    re_cod *regexp;

    LispObj *regex, *ostring, *count, *ostart, *oend, *notbol, *noteol;

    noteol = ARGUMENT(6);
    notbol = ARGUMENT(5);
    oend = ARGUMENT(4);
    ostart = ARGUMENT(3);
    count = ARGUMENT(2);
    ostring = ARGUMENT(1);
    regex = ARGUMENT(0);

    if (STRINGP(regex))
	regexp = LispRecomp(builtin, THESTR(regex), cflags = 0);
    else {
	CHECK_REGEX(regex);
	regexp = regex->data.regex.regex;
	cflags = regex->data.regex.options;
    }

    CHECK_STRING(ostring);

    if (count == UNSPEC)
	nmatch = 1;
    else {
	CHECK_INDEX(count);
	nmatch = FIXNUM_VALUE(count);
	if (nmatch > 10)
	    LispDestroy("%s: COUNT cannot be larger than 10", STRFUN(builtin));
    }
    if (nmatch && (cflags & RE_NOSUB))
	nmatch = 1;

    eflags = RE_STARTEND;
    if (notbol != UNSPEC && notbol != NIL)
	eflags |= RE_NOTBOL;
    if (noteol != UNSPEC && noteol != NIL)
	eflags |= RE_NOTEOL;

    string = THESTR(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &length);

    match[0].rm_so = start;
    match[0].rm_eo = end;
    code = reexec(regexp, string, nmatch, &match[0], eflags);

    if (code == 0) {
	if (nmatch && match[0].rm_eo >= match[0].rm_so) {
	    result = CONS(CONS(FIXNUM(match[0].rm_so),
			       FIXNUM(match[0].rm_eo)), NIL);
	    if (nmatch > 1 && match[1].rm_eo >= match[1].rm_so) {
		int i;
		GC_ENTER();
		LispObj *cons = result;

		GC_PROTECT(result);
		for (i = 1;
		     i < nmatch && match[i].rm_eo >= match[i].rm_so;
		     i++) {
		    RPLACD(cons, CONS(CONS(FIXNUM(match[i].rm_so),
					   FIXNUM(match[i].rm_eo)), NIL));
		    cons = CDR(cons);
		}
		GC_LEAVE();
	    }
	}
	else
	    result = NIL;
    }
    else
	result = Knomatch;

    /* Maybe shoud cache compiled regex, but better the caller do it */
    if (!XREGEXP(regex)) {
	refree(regexp);
	LispFree(regexp);
    }

    return (result);
}
예제 #15
0
파일: string.c 프로젝트: 8l/xedit
LispObj *
Lisp_ParseInteger(LispBuiltin *builtin)
/*
 parse-integer string &key start end radix junk-allowed
 */
{
    GC_ENTER();
    char *ptr, *string;
    int character, junk, sign, overflow;
    long i, start, end, radix, length, integer, check;
    LispObj *result;

    LispObj *ostring, *ostart, *oend, *oradix, *junk_allowed;

    junk_allowed = ARGUMENT(4);
    oradix = ARGUMENT(3);
    oend = ARGUMENT(2);
    ostart = ARGUMENT(1);
    ostring = ARGUMENT(0);

    start = end = radix = 0;
    result = NIL;

    CHECK_STRING(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &length);
    string = THESTR(ostring);
    if (oradix == UNSPEC)
	radix = 10;
    else {
	CHECK_INDEX(oradix);
	radix = FIXNUM_VALUE(oradix);
    }
    if (radix < 2 || radix > 36)
	LispDestroy("%s: :RADIX %ld must be in the range 2 to 36",
		    STRFUN(builtin), radix);

    integer = check = 0;
    ptr = string + start;
    sign = overflow = 0;

    /* Skip leading white spaces */
    for (i = start; i < end && *ptr && isspace(*ptr); ptr++, i++)
	;

    /* Check for sign specification */
    if (i < end && (*ptr == '-' || *ptr == '+')) {
	sign = *ptr == '-';
	++ptr;
	++i;
    }

    for (junk = 0; i < end; i++, ptr++) {
	character = *ptr;
	if (islower(character))
	    character = toupper(character);
	if (character >= '0' && character <= '9') {
	    if (character - '0' >= radix)
		junk = 1;
	    else {
		check = integer;
		integer = integer * radix + character - '0';
	    }
	}
	else if (character >= 'A' && character <= 'Z') {
	    if (character - 'A' + 10 >= radix)
		junk = 1;
	    else {
		check = integer;
		integer = integer * radix + character - 'A' + 10;
	    }
	}
	else {
	    if (isspace(character))
		break;
	    junk = 1;
	}

	if (junk)
	    break;

	if (!overflow && check > integer)
	    overflow = 1;
	/* keep looping just to count read bytes */
    }

    if (!junk)
	/* Skip white spaces */
	for (; i < end && *ptr && isspace(*ptr); ptr++, i++)
	    ;

    if ((junk || ptr == string) &&
	(junk_allowed == UNSPEC || junk_allowed == NIL))
	LispDestroy("%s: %s has a bad integer representation",
		    STRFUN(builtin), STROBJ(ostring));
    else if (ptr == string)
	result = NIL;
    else if (overflow) {
	mpi *bigi = LispMalloc(sizeof(mpi));
	char *str;

	length = end - start + sign;
	str = LispMalloc(length + 1);

	strncpy(str, string - sign, length + sign);
	str[length + sign] = '\0';
	mpi_init(bigi);
	mpi_setstr(bigi, str, radix);
	LispFree(str);
	result = BIGNUM(bigi);
    }
    else
	result = INTEGER(sign ? -integer : integer);

    GC_PROTECT(result);
    RETURN(0) = FIXNUM(i);
    RETURN_COUNT = 1;
    GC_LEAVE();

    return (result);
}