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); }
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); }
/* 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); }
size_t gc_nbytes(const void *ptr) { GC_ENTER(); if (VERIFY_PTR(ptr)) { size_t block = BLOCK_FROM_PTR(ptr); if (ATB_GET_KIND(block) == AT_HEAD) { // work out number of consecutive blocks in the chain starting with this on size_t n_blocks = 0; do { n_blocks += 1; } while (ATB_GET_KIND(block + n_blocks) == AT_TAIL); GC_EXIT(); return n_blocks * BYTES_PER_BLOCK; } } // invalid pointer GC_EXIT(); return 0; }
void gc_collect_start(void) { GC_ENTER(); MP_STATE_MEM(gc_lock_depth)++; #if MICROPY_GC_ALLOC_THRESHOLD MP_STATE_MEM(gc_alloc_amount) = 0; #endif MP_STATE_MEM(gc_stack_overflow) = 0; // Trace root pointers. This relies on the root pointers being organised // correctly in the mp_state_ctx structure. We scan nlr_top, dict_locals, // dict_globals, then the root pointer section of mp_state_vm. void **ptrs = (void**)(void*)&mp_state_ctx; gc_collect_root(ptrs, offsetof(mp_state_ctx_t, vm.qstr_last_chunk) / sizeof(void*)); #if MICROPY_ENABLE_PYSTACK // Trace root pointers from the Python stack. ptrs = (void**)(void*)MP_STATE_THREAD(pystack_start); gc_collect_root(ptrs, (MP_STATE_THREAD(pystack_cur) - MP_STATE_THREAD(pystack_start)) / sizeof(void*)); #endif }
// force the freeing of a piece of memory // TODO: freeing here does not call finaliser void gc_free(void *ptr) { GC_ENTER(); if (MP_STATE_MEM(gc_lock_depth) > 0) { // TODO how to deal with this error? GC_EXIT(); return; } DEBUG_printf("gc_free(%p)\n", ptr); if (ptr == NULL) { GC_EXIT(); } else { // get the GC block number corresponding to this pointer assert(VERIFY_PTR(ptr)); size_t block = BLOCK_FROM_PTR(ptr); assert(ATB_GET_KIND(block) == AT_HEAD); #if MICROPY_ENABLE_FINALISER FTB_CLEAR(block); #endif // set the last_free pointer to this block if it's earlier in the heap if (block / BLOCKS_PER_ATB < MP_STATE_MEM(gc_last_free_atb_index)) { MP_STATE_MEM(gc_last_free_atb_index) = block / BLOCKS_PER_ATB; } // free head and all of its tail blocks do { ATB_ANY_TO_FREE(block); block += 1; } while (ATB_GET_KIND(block) == AT_TAIL); GC_EXIT(); #if EXTENSIVE_HEAP_PROFILING gc_dump_alloc_table(); #endif } }
void gc_dump_alloc_table(void) { GC_ENTER(); static const size_t DUMP_BYTES_PER_LINE = 64; #if !EXTENSIVE_HEAP_PROFILING // When comparing heap output we don't want to print the starting // pointer of the heap because it changes from run to run. mp_printf(&mp_plat_print, "GC memory layout; from %p:", MP_STATE_MEM(gc_pool_start)); #endif for (size_t bl = 0; bl < MP_STATE_MEM(gc_alloc_table_byte_len) * BLOCKS_PER_ATB; bl++) { if (bl % DUMP_BYTES_PER_LINE == 0) { // a new line of blocks { // check if this line contains only free blocks size_t bl2 = bl; while (bl2 < MP_STATE_MEM(gc_alloc_table_byte_len) * BLOCKS_PER_ATB && ATB_GET_KIND(bl2) == AT_FREE) { bl2++; } if (bl2 - bl >= 2 * DUMP_BYTES_PER_LINE) { // there are at least 2 lines containing only free blocks, so abbreviate their printing mp_printf(&mp_plat_print, "\n (%u lines all free)", (uint)(bl2 - bl) / DUMP_BYTES_PER_LINE); bl = bl2 & (~(DUMP_BYTES_PER_LINE - 1)); if (bl >= MP_STATE_MEM(gc_alloc_table_byte_len) * BLOCKS_PER_ATB) { // got to end of heap break; } } } // print header for new line of blocks // (the cast to uint32_t is for 16-bit ports) //mp_printf(&mp_plat_print, "\n%05x: ", (uint)(PTR_FROM_BLOCK(bl) & (uint32_t)0xfffff)); mp_printf(&mp_plat_print, "\n%05x: ", (uint)((bl * BYTES_PER_BLOCK) & (uint32_t)0xfffff)); } int c = ' '; switch (ATB_GET_KIND(bl)) { case AT_FREE: c = '.'; break; /* this prints out if the object is reachable from BSS or STACK (for unix only) case AT_HEAD: { c = 'h'; void **ptrs = (void**)(void*)&mp_state_ctx; mp_uint_t len = offsetof(mp_state_ctx_t, vm.stack_top) / sizeof(mp_uint_t); for (mp_uint_t i = 0; i < len; i++) { mp_uint_t ptr = (mp_uint_t)ptrs[i]; if (VERIFY_PTR(ptr) && BLOCK_FROM_PTR(ptr) == bl) { c = 'B'; break; } } if (c == 'h') { ptrs = (void**)&c; len = ((mp_uint_t)MP_STATE_THREAD(stack_top) - (mp_uint_t)&c) / sizeof(mp_uint_t); for (mp_uint_t i = 0; i < len; i++) { mp_uint_t ptr = (mp_uint_t)ptrs[i]; if (VERIFY_PTR(ptr) && BLOCK_FROM_PTR(ptr) == bl) { c = 'S'; break; } } } break; } */ /* this prints the uPy object type of the head block */ case AT_HEAD: { void **ptr = (void**)(MP_STATE_MEM(gc_pool_start) + bl * BYTES_PER_BLOCK); if (*ptr == &mp_type_tuple) { c = 'T'; } else if (*ptr == &mp_type_list) { c = 'L'; } else if (*ptr == &mp_type_dict) { c = 'D'; } else if (*ptr == &mp_type_str || *ptr == &mp_type_bytes) { c = 'S'; } #if MICROPY_PY_BUILTINS_BYTEARRAY else if (*ptr == &mp_type_bytearray) { c = 'A'; } #endif #if MICROPY_PY_ARRAY else if (*ptr == &mp_type_array) { c = 'A'; } #endif #if MICROPY_PY_BUILTINS_FLOAT else if (*ptr == &mp_type_float) { c = 'F'; } #endif else if (*ptr == &mp_type_fun_bc) { c = 'B'; } else if (*ptr == &mp_type_module) { c = 'M'; } else { c = 'h'; #if 0 // This code prints "Q" for qstr-pool data, and "q" for qstr-str // data. It can be useful to see how qstrs are being allocated, // but is disabled by default because it is very slow. for (qstr_pool_t *pool = MP_STATE_VM(last_pool); c == 'h' && pool != NULL; pool = pool->prev) { if ((qstr_pool_t*)ptr == pool) { c = 'Q'; break; } for (const byte **q = pool->qstrs, **q_top = pool->qstrs + pool->len; q < q_top; q++) { if ((const byte*)ptr == *q) { c = 'q'; break; } } } #endif } break; } case AT_TAIL: c = '='; break; case AT_MARK: c = 'm'; break; } mp_printf(&mp_plat_print, "%c", c); } mp_print_str(&mp_plat_print, "\n"); GC_EXIT(); }
void *gc_realloc(void *ptr_in, size_t n_bytes, bool allow_move) { // check for pure allocation if (ptr_in == NULL) { return gc_alloc(n_bytes, false); } // check for pure free if (n_bytes == 0) { gc_free(ptr_in); return NULL; } void *ptr = ptr_in; GC_ENTER(); if (MP_STATE_MEM(gc_lock_depth) > 0) { GC_EXIT(); return NULL; } // get the GC block number corresponding to this pointer assert(VERIFY_PTR(ptr)); size_t block = BLOCK_FROM_PTR(ptr); assert(ATB_GET_KIND(block) == AT_HEAD); // compute number of new blocks that are requested size_t new_blocks = (n_bytes + BYTES_PER_BLOCK - 1) / BYTES_PER_BLOCK; // Get the total number of consecutive blocks that are already allocated to // this chunk of memory, and then count the number of free blocks following // it. Stop if we reach the end of the heap, or if we find enough extra // free blocks to satisfy the realloc. Note that we need to compute the // total size of the existing memory chunk so we can correctly and // efficiently shrink it (see below for shrinking code). size_t n_free = 0; size_t n_blocks = 1; // counting HEAD block size_t max_block = MP_STATE_MEM(gc_alloc_table_byte_len) * BLOCKS_PER_ATB; for (size_t bl = block + n_blocks; bl < max_block; bl++) { byte block_type = ATB_GET_KIND(bl); if (block_type == AT_TAIL) { n_blocks++; continue; } if (block_type == AT_FREE) { n_free++; if (n_blocks + n_free >= new_blocks) { // stop as soon as we find enough blocks for n_bytes break; } continue; } break; } // return original ptr if it already has the requested number of blocks if (new_blocks == n_blocks) { GC_EXIT(); return ptr_in; } // check if we can shrink the allocated area if (new_blocks < n_blocks) { // free unneeded tail blocks for (size_t bl = block + new_blocks, count = n_blocks - new_blocks; count > 0; bl++, count--) { ATB_ANY_TO_FREE(bl); } // set the last_free pointer to end of this block if it's earlier in the heap if ((block + new_blocks) / BLOCKS_PER_ATB < MP_STATE_MEM(gc_last_free_atb_index)) { MP_STATE_MEM(gc_last_free_atb_index) = (block + new_blocks) / BLOCKS_PER_ATB; } GC_EXIT(); #if EXTENSIVE_HEAP_PROFILING gc_dump_alloc_table(); #endif return ptr_in; } // check if we can expand in place if (new_blocks <= n_blocks + n_free) { // mark few more blocks as used tail for (size_t bl = block + n_blocks; bl < block + new_blocks; bl++) { assert(ATB_GET_KIND(bl) == AT_FREE); ATB_FREE_TO_TAIL(bl); } GC_EXIT(); #if MICROPY_GC_CONSERVATIVE_CLEAR // be conservative and zero out all the newly allocated blocks memset((byte*)ptr_in + n_blocks * BYTES_PER_BLOCK, 0, (new_blocks - n_blocks) * BYTES_PER_BLOCK); #else // zero out the additional bytes of the newly allocated blocks (see comment above in gc_alloc) memset((byte*)ptr_in + n_bytes, 0, new_blocks * BYTES_PER_BLOCK - n_bytes); #endif #if EXTENSIVE_HEAP_PROFILING gc_dump_alloc_table(); #endif return ptr_in; } #if MICROPY_ENABLE_FINALISER bool ftb_state = FTB_GET(block); #else bool ftb_state = false; #endif GC_EXIT(); if (!allow_move) { // not allowed to move memory block so return failure return NULL; } // can't resize inplace; try to find a new contiguous chain void *ptr_out = gc_alloc(n_bytes, ftb_state); // check that the alloc succeeded if (ptr_out == NULL) { return NULL; } DEBUG_printf("gc_realloc(%p -> %p)\n", ptr_in, ptr_out); memcpy(ptr_out, ptr_in, n_blocks * BYTES_PER_BLOCK); gc_free(ptr_in); return ptr_out; }
void *gc_alloc(size_t n_bytes, bool has_finaliser) { size_t n_blocks = ((n_bytes + BYTES_PER_BLOCK - 1) & (~(BYTES_PER_BLOCK - 1))) / BYTES_PER_BLOCK; DEBUG_printf("gc_alloc(" UINT_FMT " bytes -> " UINT_FMT " blocks)\n", n_bytes, n_blocks); // check for 0 allocation if (n_blocks == 0) { return NULL; } GC_ENTER(); // check if GC is locked if (MP_STATE_MEM(gc_lock_depth) > 0) { GC_EXIT(); return NULL; } size_t i; size_t end_block; size_t start_block; size_t n_free = 0; int collected = !MP_STATE_MEM(gc_auto_collect_enabled); #if MICROPY_GC_ALLOC_THRESHOLD if (!collected && MP_STATE_MEM(gc_alloc_amount) >= MP_STATE_MEM(gc_alloc_threshold)) { GC_EXIT(); gc_collect(); GC_ENTER(); } #endif for (;;) { // look for a run of n_blocks available blocks for (i = MP_STATE_MEM(gc_last_free_atb_index); i < MP_STATE_MEM(gc_alloc_table_byte_len); i++) { byte a = MP_STATE_MEM(gc_alloc_table_start)[i]; if (ATB_0_IS_FREE(a)) { if (++n_free >= n_blocks) { i = i * BLOCKS_PER_ATB + 0; goto found; } } else { n_free = 0; } if (ATB_1_IS_FREE(a)) { if (++n_free >= n_blocks) { i = i * BLOCKS_PER_ATB + 1; goto found; } } else { n_free = 0; } if (ATB_2_IS_FREE(a)) { if (++n_free >= n_blocks) { i = i * BLOCKS_PER_ATB + 2; goto found; } } else { n_free = 0; } if (ATB_3_IS_FREE(a)) { if (++n_free >= n_blocks) { i = i * BLOCKS_PER_ATB + 3; goto found; } } else { n_free = 0; } } GC_EXIT(); // nothing found! if (collected) { return NULL; } DEBUG_printf("gc_alloc(" UINT_FMT "): no free mem, triggering GC\n", n_bytes); gc_collect(); collected = 1; GC_ENTER(); } // found, ending at block i inclusive found: // get starting and end blocks, both inclusive end_block = i; start_block = i - n_free + 1; // Set last free ATB index to block after last block we found, for start of // next scan. To reduce fragmentation, we only do this if we were looking // for a single free block, which guarantees that there are no free blocks // before this one. Also, whenever we free or shink a block we must check // if this index needs adjusting (see gc_realloc and gc_free). if (n_free == 1) { MP_STATE_MEM(gc_last_free_atb_index) = (i + 1) / BLOCKS_PER_ATB; } // mark first block as used head ATB_FREE_TO_HEAD(start_block); // mark rest of blocks as used tail // TODO for a run of many blocks can make this more efficient for (size_t bl = start_block + 1; bl <= end_block; bl++) { ATB_FREE_TO_TAIL(bl); } // get pointer to first block // we must create this pointer before unlocking the GC so a collection can find it void *ret_ptr = (void*)(MP_STATE_MEM(gc_pool_start) + start_block * BYTES_PER_BLOCK); DEBUG_printf("gc_alloc(%p)\n", ret_ptr); #if MICROPY_GC_ALLOC_THRESHOLD MP_STATE_MEM(gc_alloc_amount) += n_blocks; #endif GC_EXIT(); #if MICROPY_GC_CONSERVATIVE_CLEAR // be conservative and zero out all the newly allocated blocks memset((byte*)ret_ptr, 0, (end_block - start_block + 1) * BYTES_PER_BLOCK); #else // zero out the additional bytes of the newly allocated blocks // This is needed because the blocks may have previously held pointers // to the heap and will not be set to something else if the caller // doesn't actually use the entire block. As such they will continue // to point to the heap and may prevent other blocks from being reclaimed. memset((byte*)ret_ptr + n_bytes, 0, (end_block - start_block + 1) * BYTES_PER_BLOCK - n_bytes); #endif #if MICROPY_ENABLE_FINALISER if (has_finaliser) { // clear type pointer in case it is never set ((mp_obj_base_t*)ret_ptr)->type = NULL; // set mp_obj flag only if it has a finaliser GC_ENTER(); FTB_SET(start_block); GC_EXIT(); } #else (void)has_finaliser; #endif #if EXTENSIVE_HEAP_PROFILING gc_dump_alloc_table(); #endif return ret_ptr; }
void gc_info(gc_info_t *info) { GC_ENTER(); info->total = MP_STATE_MEM(gc_pool_end) - MP_STATE_MEM(gc_pool_start); info->used = 0; info->free = 0; info->max_free = 0; info->num_1block = 0; info->num_2block = 0; info->max_block = 0; bool finish = false; for (size_t block = 0, len = 0, len_free = 0; !finish;) { size_t kind = ATB_GET_KIND(block); switch (kind) { case AT_FREE: info->free += 1; len_free += 1; len = 0; break; case AT_HEAD: info->used += 1; len = 1; break; case AT_TAIL: info->used += 1; len += 1; break; case AT_MARK: // shouldn't happen break; } block++; finish = (block == MP_STATE_MEM(gc_alloc_table_byte_len) * BLOCKS_PER_ATB); // Get next block type if possible if (!finish) { kind = ATB_GET_KIND(block); } if (finish || kind == AT_FREE || kind == AT_HEAD) { if (len == 1) { info->num_1block += 1; } else if (len == 2) { info->num_2block += 1; } if (len > info->max_block) { info->max_block = len; } if (finish || kind == AT_HEAD) { if (len_free > info->max_free) { info->max_free = len_free; } len_free = 0; } } } info->used *= BYTES_PER_BLOCK; info->free *= BYTES_PER_BLOCK; GC_EXIT(); }
void gc_unlock(void) { GC_ENTER(); MP_STATE_MEM(gc_lock_depth)--; GC_EXIT(); }
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); }
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); }
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); }