#include "ficl.h" #if FICL_WANT_FILE /* * fileaccess.c * * Implements all of the File Access word set that can be implemented in * portable C. */ static void pushIor(ficlVm *vm, int success) { int ior; if (success) ior = 0; else ior = errno; ficlStackPushInteger(vm->dataStack, ior); } /* ( c-addr u fam -- fileid ior ) */ static void ficlFileOpen(ficlVm *vm, char *writeMode) { int fam = ficlStackPopInteger(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); char mode[4]; FILE *f; char *filename = (char *)malloc(length + 1); memcpy(filename, address, length); filename[length] = 0; *mode = 0; switch (FICL_FAM_OPEN_MODE(fam)) { case 0: ficlStackPushPointer(vm->dataStack, NULL); ficlStackPushInteger(vm->dataStack, EINVAL); goto EXIT; case FICL_FAM_READ: strcat(mode, "r"); break; case FICL_FAM_WRITE: strcat(mode, writeMode); break; case FICL_FAM_READ | FICL_FAM_WRITE: strcat(mode, writeMode); strcat(mode, "+"); break; } strcat(mode, (fam & FICL_FAM_BINARY) ? "b" : "t"); f = fopen(filename, mode); if (f == NULL) ficlStackPushPointer(vm->dataStack, NULL); else { ficlFile *ff = (ficlFile *)malloc(sizeof (ficlFile)); strcpy(ff->filename, filename); ff->f = f; ficlStackPushPointer(vm->dataStack, ff); fseek(f, 0, SEEK_SET); } pushIor(vm, f != NULL); EXIT: free(filename); } /* ( c-addr u fam -- fileid ior ) */ static void ficlPrimitiveOpenFile(ficlVm *vm) { ficlFileOpen(vm, "a"); } /* ( c-addr u fam -- fileid ior ) */ static void ficlPrimitiveCreateFile(ficlVm *vm) { ficlFileOpen(vm, "w"); } /* ( fileid -- ior ) */ static int ficlFileClose(ficlFile *ff) { FILE *f = ff->f; free(ff); return (!fclose(f)); } /* ( fileid -- ior ) */ static void ficlPrimitiveCloseFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); pushIor(vm, ficlFileClose(ff)); } /* ( c-addr u -- ior ) */ static void ficlPrimitiveDeleteFile(ficlVm *vm) { int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); char *filename = (char *)malloc(length + 1); memcpy(filename, address, length); filename[length] = 0; pushIor(vm, !unlink(filename)); free(filename); } /* ( c-addr1 u1 c-addr2 u2 -- ior ) */ static void ficlPrimitiveRenameFile(ficlVm *vm) { int length; void *address; char *from; char *to; length = ficlStackPopInteger(vm->dataStack); address = (void *)ficlStackPopPointer(vm->dataStack); to = (char *)malloc(length + 1); memcpy(to, address, length); to[length] = 0; length = ficlStackPopInteger(vm->dataStack); address = (void *)ficlStackPopPointer(vm->dataStack); from = (char *)malloc(length + 1); memcpy(from, address, length); from[length] = 0; pushIor(vm, !rename(from, to)); free(from); free(to); } /* ( c-addr u -- x ior ) */ static void ficlPrimitiveFileStatus(ficlVm *vm) { int status; int ior; int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); char *filename = (char *)malloc(length + 1); memcpy(filename, address, length); filename[length] = 0; ior = ficlFileStatus(filename, &status); free(filename); ficlStackPushInteger(vm->dataStack, status); ficlStackPushInteger(vm->dataStack, ior); } /* ( fileid -- ud ior ) */ static void ficlPrimitiveFilePosition(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); long ud = ftell(ff->f); ficlStackPushInteger(vm->dataStack, ud); pushIor(vm, ud != -1); } /* ( fileid -- ud ior ) */ static void ficlPrimitiveFileSize(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); long ud = ficlFileSize(ff); ficlStackPushInteger(vm->dataStack, ud); pushIor(vm, ud != -1); } /* ( i*x fileid -- j*x ) */ #define nLINEBUF 256 static void ficlPrimitiveIncludeFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); ficlCell id = vm->sourceId; int except = FICL_VM_STATUS_OUT_OF_TEXT; long currentPosition, totalSize; long size; ficlString s; vm->sourceId.p = (void *)ff; currentPosition = ftell(ff->f); totalSize = ficlFileSize(ff); size = totalSize - currentPosition; if ((totalSize != -1) && (currentPosition != -1) && (size > 0)) { char *buffer = (char *)malloc(size); long got = fread(buffer, 1, size, ff->f); if (got == size) { FICL_STRING_SET_POINTER(s, buffer); FICL_STRING_SET_LENGTH(s, size); except = ficlVmExecuteString(vm, s); } } if ((except < 0) && (except != FICL_VM_STATUS_OUT_OF_TEXT)) ficlVmThrow(vm, except); /* * Pass an empty line with SOURCE-ID == -1 to flush * any pending REFILLs (as required by FILE wordset) */ vm->sourceId.i = -1; FICL_STRING_SET_FROM_CSTRING(s, ""); ficlVmExecuteString(vm, s); vm->sourceId = id; ficlFileClose(ff); } /* ( c-addr u1 fileid -- u2 ior ) */ static void ficlPrimitiveReadFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); int result; clearerr(ff->f); result = fread(address, 1, length, ff->f); ficlStackPushInteger(vm->dataStack, result); pushIor(vm, ferror(ff->f) == 0); } /* ( c-addr u1 fileid -- u2 flag ior ) */ static void ficlPrimitiveReadLine(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); char *address = (char *)ficlStackPopPointer(vm->dataStack); int error; int flag; if (feof(ff->f)) { ficlStackPushInteger(vm->dataStack, -1); ficlStackPushInteger(vm->dataStack, 0); ficlStackPushInteger(vm->dataStack, 0); return; } clearerr(ff->f); *address = 0; fgets(address, length, ff->f); error = ferror(ff->f); if (error != 0) { ficlStackPushInteger(vm->dataStack, -1); ficlStackPushInteger(vm->dataStack, 0); ficlStackPushInteger(vm->dataStack, error); return; } length = strlen(address); flag = (length > 0); if (length && ((address[length - 1] == '\r') || (address[length - 1] == '\n'))) length--; ficlStackPushInteger(vm->dataStack, length); ficlStackPushInteger(vm->dataStack, flag); ficlStackPushInteger(vm->dataStack, 0); /* ior */ } /* ( c-addr u1 fileid -- ior ) */ static void ficlPrimitiveWriteFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); int length = ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); clearerr(ff->f); fwrite(address, 1, length, ff->f); pushIor(vm, ferror(ff->f) == 0); } /* ( c-addr u1 fileid -- ior ) */ static void ficlPrimitiveWriteLine(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); size_t length = (size_t)ficlStackPopInteger(vm->dataStack); void *address = (void *)ficlStackPopPointer(vm->dataStack); clearerr(ff->f); if (fwrite(address, 1, length, ff->f) == length) fwrite("\n", 1, 1, ff->f); pushIor(vm, ferror(ff->f) == 0); } /* ( ud fileid -- ior ) */ static void ficlPrimitiveRepositionFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); size_t ud = (size_t)ficlStackPopInteger(vm->dataStack); pushIor(vm, fseek(ff->f, ud, SEEK_SET) == 0); } /* ( fileid -- ior ) */ static void ficlPrimitiveFlushFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); pushIor(vm, fflush(ff->f) == 0); } #if FICL_PLATFORM_HAS_FTRUNCATE /* ( ud fileid -- ior ) */ static void ficlPrimitiveResizeFile(ficlVm *vm) { ficlFile *ff = (ficlFile *)ficlStackPopPointer(vm->dataStack); size_t ud = (size_t)ficlStackPopInteger(vm->dataStack); pushIor(vm, ficlFileTruncate(ff, ud) == 0); } #endif /* FICL_PLATFORM_HAS_FTRUNCATE */ #endif /* FICL_WANT_FILE */ void ficlSystemCompileFile(ficlSystem *system) { #if !FICL_WANT_FILE FICL_IGNORE(system); #else ficlDictionary *dictionary = ficlSystemGetDictionary(system); ficlDictionary *environment = ficlSystemGetEnvironment(system); FICL_SYSTEM_ASSERT(system, dictionary); FICL_SYSTEM_ASSERT(system, environment); ficlDictionarySetPrimitive(dictionary, "create-file", ficlPrimitiveCreateFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "open-file", ficlPrimitiveOpenFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "close-file", ficlPrimitiveCloseFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "include-file", ficlPrimitiveIncludeFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "read-file", ficlPrimitiveReadFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "read-line", ficlPrimitiveReadLine, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "write-file", ficlPrimitiveWriteFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "write-line", ficlPrimitiveWriteLine, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "file-position", ficlPrimitiveFilePosition, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "file-size", ficlPrimitiveFileSize, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "reposition-file", ficlPrimitiveRepositionFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "file-status", ficlPrimitiveFileStatus, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "flush-file", ficlPrimitiveFlushFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "delete-file", ficlPrimitiveDeleteFile, FICL_WORD_DEFAULT); ficlDictionarySetPrimitive(dictionary, "rename-file", ficlPrimitiveRenameFile, FICL_WORD_DEFAULT); #if FICL_PLATFORM_HAS_FTRUNCATE ficlDictionarySetPrimitive(dictionary, "resize-file", ficlPrimitiveResizeFile, FICL_WORD_DEFAULT); ficlDictionarySetConstant(environment, "file", FICL_TRUE); ficlDictionarySetConstant(environment, "file-ext", FICL_TRUE); #else /* FICL_PLATFORM_HAS_FTRUNCATE */ ficlDictionarySetConstant(environment, "file", FICL_FALSE); ficlDictionarySetConstant(environment, "file-ext", FICL_FALSE); #endif /* FICL_PLATFORM_HAS_FTRUNCATE */ #endif /* !FICL_WANT_FILE */ }