Check-ins Using Download Hex

Artifact 2dd851de771cf34375d505e7b29e21705515fc94da718e1a0c76c4815b4ca321:

/* sysipaq.c                      Copyright (C) 1989-2007 Codemist Ltd */

/*
 * System specific code. My objective is that this will subsume and replace
 * all the other files that I have or had called sysxxx.c, sysyyy.c etc.
 *
 * System-specific code for use with the "fwin" window interface code.
 * This is expected to be buildable on Windows via mingw32, on
 * both 32 and 64-bit variants of Linux, and (I hope) on Macintosh
 * system X (at least if an X server is made available to it). I thus
 * at least hope that I can use it as a generic uniform body of code.
 * The system will also build as a terminal-mode program as well as
 * a windowed one.
 *
 * I will use "autoconf" and all that stuff with a view to making
 * this code build on a wide range of systems via the usual
 *    ./configure ; make
 * sequence. This (obviously) involves a Unix-like build environment
 * but mingw/msys provides that for Windows.
 */

/*
 * This code may be used and modified, and redistributed in binary
 * or source form, subject to the "CCL Public License", which should
 * accompany it. This license is a variant on the BSD license, and thus
 * permits use of code derived from this in either open and commercial
 * projects: but it does require that updates to this code be made
 * available back to the originators of the package.
 * Before merging other code in with this or linking this code
 * with other packages or libraries please check that the license terms
 * of the other material are compatible with those of this.
 */

/* Signature: 018c0c8a 18-Jan-2007 */

#include "headers.h"

/*
 * WIN32               all Windows platforms that I support
 * <else>              Unix-like
 *
 *    popen(cmd, dir)  vs   _popen(cms, dir)
 *    pclose(stream)   vs   _pclose(stream)
 *    fileno(file)     vs   _fileno(file)
 *    struct stat      vs   struct _stat
 *    stat             vs   _stat
 *    ftruncate(file)  vs   chsize(file)
 *    S_IFMT __S_IFMT       to go with stat
 *    S_IFDIR __S_IFDIR
 *    DO_NOT_USE_GETUID     is getuid available
 *    UNIX_TIMES            how can I read the clock
 *    UTIME_TIME_T          struct utimbuf
 */



#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef HAVE_DIRENT_H
#include <dirent.h>
#endif

#ifdef WIN32
#include <windows.h>
#endif

/*
 * Jollies re GC statistics...
 */
 
static char time_string[32], space_string[32];

void report_time(int32_t t, int32_t gct)
{
    sprintf(time_string, "%ld.%.2ld+%ld.%.2ld secs  ",
        t/100L, t%100L, gct/100L, gct%100L);
    if ((window_heading & 1) == 0) fwin_report_left(time_string);
}

void report_space(int n, double percent)
{
    sprintf(space_string, "[GC %d]:%.2f%%", n, percent);
    if ((window_heading & 4) == 0) fwin_report_right(space_string);
}

void flush_screen()
{
    fwin_ensure_screen();
}

void pause_for_user()
{
}

int wimpget(char *buf)
{
    int c, n=0;
    ensure_screen();
    while (n < 255)
    {   c = ce_readch();
        if (c == (0x1f & 'C') ||           /* ^C - quiet : quit      */
            c == (0x1f & 'G')) return 0;   /* ^G - noisy : interrupt */
        if (c == EOF) c = 0x1f & 'D';
        buf[n++] = (char)c;
        if (c == '\n' || c == (0x1f & 'D')) break;
    };
    return n;
}

FILE *my_popen(char *command, char *direction)
{
    return NULL;
}

int my_pipe_putc(int c, FILE *f)
{
    return putc(c, f);
}

int my_pipe_flush(FILE *f)
{
    return fflush(f);
}

void my_pclose(FILE *stream)
{
}


/*
 * Map file-names to expand references to shell variables etc.
 * and to provide portability of names across operating systems.
 */


char *look_in_lisp_variable(char *o, int prefix)
{
    Lisp_Object nil, var;
/*
 * I will start by tagging a '$' (or whatever) on in front of the
 * parameter name.
 */
    o[0] = (char)prefix;
    var = make_undefined_symbol(o);
    nil = C_nil;
/*
 * make_undefined_symbol() could fail either if we had utterly run out
 * of memory or if somebody generated an interrupt (eg ^C) around now. Ugh.
 */
    if (exception_pending())
    {   flip_exception();
        return NULL;
    }
/*
 * If the variable $name was undefined then I use an empty replacement
 * text for it. Otherwise I need to look harder at its value.
 */
    if (qvalue(var) == unset_var) return o;
    else
    {   Header h;
        intptr_t len;
        var = qvalue(var);
/*
 * Mostly I expect that the value will be a string or symbol.
 */
#ifdef COMMON
        if (complex_stringp(var))
        {   var = simplify_string(var);
            nil = C_nil;
            if (exception_pending())
            {   flip_exception();
                return NULL;
            }
        }
#endif /* COMMON */
        if (symbolp(var))
        {   var = get_pname(var);
            nil = C_nil;
            if (exception_pending())
            {   flip_exception();
                return NULL;
            }
            h = vechdr(var);
        }
        else if (!is_vector(var) ||
                 type_of_header(h = vechdr(var)) != TYPE_STRING)
            return NULL;
        len = length_of_header(h) - CELL;
/*
 * Copy the characters from the string or from the name of the variable
 * into the file-name buffer. There could at present be a crash here
 * if the expansion was very very long and overflowed my buffer. Tough
 * luck for now - people doing that (maybe) get what they (maybe) deserve.
 */
        memcpy(o, (char *)var + (CELL - TAG_VECTOR), (size_t)len);
        o = o + len;
        return o;
    }
}


#ifdef UNIX_TIMES
/*
 * This is a BSD-style clock facility, possibly giving a resolution of
 * only 1/100 second.  I believe that Portable Standard Lisp typically
 * reports user time, which is why I do this.  A further nasty here
 * is that I am probably compiling this file in ANSI mode, and on
 * at least some computers this makes #include <sys/times.h> fairly
 * ineffective (ugh), so I declare all the structures and functions I
 * want directly (ugh ugh) and hope they are as needed.  Consider this
 * when you port to a new machine.
 */

clock_t read_clock(void)
{
    struct my_tms {
        clock_t tms_utime;
        clock_t tms_stime;
        clock_t tms_cutime;
        clock_t tms_cstime;
        } tmsbuf;
    clock_t w1, w2, w3;
    extern void times(/*struct my_tms * */);
    times(&tmsbuf);
    w1 = tmsbuf.tms_utime;   /* User time in UNIX_TIMES ticks */
    w2 = CLOCKS_PER_SEC;
    w3 = UNIX_TIMES;
    return (clock_t)((double)w1 * ((double)w2/(double)w3));
}

#else

clock_t read_clock()
{
    return clock();
}

#endif

int batchp()
{
    return !isatty(fileno(stdin));
}

/*
 * The next procedure is responsible for establishing information about
 * where the main checkpoint image should be recovered from, and where
 * and fasl files should come from.
 */
char *find_image_directory(int argc, char *argv[])
{
    int n = strlen(programName) + strlen(programDir) + 6;
    char *w = (char *)(*malloc_hook)(n);
    strcpy(w, programDir);
    n = strlen(programDir);
    w[n] = '/';                 /* Should be '\\' for Windows? */
    strcpy(&w[n+1], programName);
    n += strlen(programName) + 1;
    strcpy(&w[n], ".img");
    return w;
}

/*
 * The following function controls memory allocation policy
 */

int32_t ok_to_grab_memory(int32_t current)
{
#ifdef COMMON
    return current;
#else
    return 3*current + 2;
#endif
}

time_t MS_CDECL time(time_t *x)
{
    time_t r = 0;
    if (x != NULL) *x = r;
    return r;
}

clock_t MS_CDECL clock()
{
    return 0;
}

const char *fwin_full_program_name = (const char *)"./csl.exe";
const char *programName            = (const char *)"csl.exe";
const char *programDir             = (const char *)".";

void fwin_restore()
{
}

void fwin_putchar(int c)
{
/*
 * Despite using termed during keyboard input I will just use the
 * ordinary C stream functions for normal output. Provided I do an
 * fflush(stdout) before requesting input I should be OK.
 */
    char s[2];
    s[0] = c;
    s[1] = 0;
    ce_print(s);
}

void fwin_puts(const char *s)
{
    ce_print(s);
}


void MS_CDECL fwin_printf(const char *fmt, ...)
{
    va_list a;
    char s[200];
    va_start(a, fmt);
    vsprintf(s, fmt, a);
    va_end(a);
    ce_print(s);
}

void fwin_vfprintf(const char *fmt, va_list a)
{
    char s[200];
    vsprintf(s, fmt, a);
    ce_print(s);
}

void fwin_ensure_screen()
{
}

void fwin_report_left(const char *s)
{
}

void fwin_report_mid(const char *s)
{
}

void fwin_report_right(const char *s)
{
}

void fwin_set_prompt(const char *s)
{
}

void fwin_menus(char **modules, char **switches)
{
}

void fwin_refresh_switches(char **switches, char **packages)
{
}

void fwin_set_help_file(const char *key, const char *path)
{
}

void fwin_acknowledge_tick()
{
}

int fwin_windowmode()
{
    return 0;
}

/*
 * The following four strings may be updated (but PLEASE keep within the
 * length limit) to make the display in the "ABOUT" box reflect your
 * particular application.
 */
char about_box_title[32] = "ABout Reduce";
char about_box_description[32] = "Version 3.8";
char about_box_rights_1[32] = "Copyright A C Hearn";
char about_box_rights_2[32] = "and Codemist Ltd";
char about_box_rights_3[32] = "Ipaq version March 2005";

int get_current_directory(char *s, int n)
{
    strcpy(s, ".");
    return 1;
}

int get_home_directory(char *s, int n)
{
    strcpy(s, ".");
    return 1;
}

int get_users_home_directory(char *s, int n)
{
    strcpy(s, ".");
    return 1;
}

char *ctime(const time_t *t)
{
    return "<today's date>";
}

static void process_file_name(char *filename, char *old, size_t n)
/*
 * This procedure maps filenames by expanding some environment
 * variables.  It is very thoroughly system specific, which is why it
 * is in this file.  See also LONGEST_LEGAL_FILENAME in "tags.h" for a
 * limit on the permitted size of an expanded filename.
 * The input (old) is not necessarily properly terminated as a C string,
 * so n says how many characters to inspect.  Build a converted name
 * in filename.
 * At present the expansions I allow are:
 *
 *    $xxx   (terminated by '.', '/' or '\' with at least one char x)
 *    ${xxx} (self-terminating)
 *           First check for a Lisp variable $xxx. If this is set (and is
 *           a string or a symbol) then its value is used. If not then
 *           next inspect the environment variable xxx and dump its
 *           value into the output.  If the variable is unset then a check
 *           is made for the value of a global lisp variable called @xxx,
 *           and if that exists and is a string or symbol it is used.
 *           If @xxx is undefined a null string is inserted.
 *           If one of the variables is defined but has an improper value
 *           then the whole file-translation fails.
 *           The use of two Lisp variables makes it possible to control
 *           precedence between these and shell variables.
 *
 *    ~      ) followed by '.', '/' or '\'
 *    ~xxx   )
 *           On Unix these try to find home directories using
 *           getpwuid(getuid()) for '~' and getpwnam() for ~xxx.
 *           If that fails ~ expands into nothing at all.
 *           This syntax is only recognised at the very start of a file-name.
 *           For systems other than Unix this syntax will not be useful and
 *           should be avoided, however as an experimental place-holder I
 *           may do things with environment variables called HOME etc.
 * 
 * 
 * I convert file-names of the form aaa/bbb/ccc.ddd into something
 * acceptable to the system being used, even though this may result in
 * some native file titles that include '/' characters becoming unavailable.
 * The reasoning here is that scripts and programs can then use Unix-like
 * names and non-Unix hosts will treat them forgivingly.
 *
 *
 */
{
    int i;
    int c;
    char *o;
    if (n == 0)
    {   *filename = 0;
        return;    /* deem zero-length name to be illegal */
    }
    o = filename;
    c = *old;
/*
 * First I deal with a leading "~"
 */
    if (c == '~')
    {   old++;
        n--;
        while (n != 0)
        {   c = *old;
            if (c == '.' || c == '/' || c == '\\') break;
            old++;
            n--;
            *o++ = (char)c;
        }
        *o = 0;
/*
 * actually deciding what the home directory is is passed down to a
 * system-specific call, but it is not to be relied upon especially
 * on personal computers.
 */
        if (o == filename)  /* '~' on its own */
        {   get_home_directory(filename, LONGEST_LEGAL_FILENAME);
            o = filename + strlen(filename);
        }
        else
        {   get_users_home_directory(filename, LONGEST_LEGAL_FILENAME);
            o = filename + strlen(filename);
        }
    }
/*
 * Having copies a user-name across (if there was one) I now copy the
 * rest of the file-name, expanding $xxx and ${xxx} as necessary.
 */
    while (n != 0)
    {   c = *old++;
        n--;
/*
 * If I find a "$" that is either at the end of the file-name or that is
 * immediately followed by ".", "/" or "\" then I will not use it for
 * parameter expansion. This at least gives me some help with the RISCOS
 * file-name $.abc.def where the "$" is used to indicate the root of the
 * current disc.
 */
        if (c == '$' && n != 0 &&
            (c = *old) != '.' && c != '/' && c != '\\')
        {   char *p = o;
            const char *w;
/*
 * I collect the name of the parameter at the end of my file-name buffer,
 * but will over-write it later on when I actually do the expansion.
 */
            if (c == '{')
            {   old++;
                n--;
                while (n != 0)
                {   c = *old++;
                    n--;
                    if (c == '}') break;
                    *p++ = (char)c;
                }
            }
            else
            {   while (n != 0)
                {   c = *old;
                    if (c == '.' || c == '/' || c == '\\') break;
                    old++;
                    n--;
                    *p++ = (char)c;
                }
            }
            *p = 0;
            i = strlen(o) + 2;
            while (i-- != 0) o[i] = o[i-1];
#ifdef CSL
            if ((p = look_in_lisp_variable(o, '$')) != NULL &&
                p != o) o = p;
            else 
#endif
            if ((w = my_getenv(o+1)) != NULL)    /* Shell variable? */
            {   strcpy(o, w);
                o = o + strlen(o);
            }
#ifdef CSL
            else if ((p = look_in_lisp_variable(o, '@')) != NULL)
                o = p;
#endif
            else
            {   *filename = 0;  /* return reporting failure */
                return;
            }
        }
        else *o++ = (char)c;
    }
    *o = 0;


#ifdef WIN32
/*
 * Now the filename has had $ and ~ prefix things expanded - I "just"
 * need to deal with sub-directory representation issues. Specifically I need
 * to map "/" separators into "\" so that if a user presents a file
 * name such as aaa/bbb/ccc.d it gets passed to the operating system
 * as aaa\bbb\ccc.d
 * Note that I enable this code under the heading MS_DOS but really it
 * means any file-system (eg Windows too) that uses "\" as its main
 * directory separator character.
 * As of September 2004 I will also map an intial sequence
 *         /cygdrive/x/
 * onto    x:\
 */

    if (strncmp(filename, "/cygdrive/", 10) == 0 &&
                filename[11] == '/')
    {   char *p = filename+2, *tail = filename+11;
        filename[0] = filename[10];
        filename[1] = ':';
        while (*tail != 0) *p++ = *tail++;
        *p = 0;
    }
/*
 * I map "/" characters in MSDOS filenames into "\" so that users
 * can give file names with Unix-like slashes as separators if they want.
 * People who WANT to use filenames with '/' in them will be hurt.
 */
    {   int j;
        char *tail = filename;
        while ((j = *tail) != 0)
        {   if (j == '/') *tail = '\\';
            tail++;
        }
/*
 * stat and friends do not like directories referred to as "\foo\", so check
 * for a trailing slash, being careful to respect directories with names
 * like "\" and "a:\".
 */
       j = strlen(filename);
       if (j > 0 && j != 1 && !(j == 3 && *(filename+1) == ':'))
       {
           if ( (*(tail - 1) == '\\')) *(tail - 1) = 0;
       }
    }
#endif /* WIN32 */
}

FILE *open_file(char *filename, char *old, size_t n,
                char *mode, FILE *old_file)
{
/*
 * mode is something like "r" or "w" or "rb", as needed by fopen(),
 * and old_file is NULL normally, but can be a (FILE *) to indicate
 * the use of freopen rather than fopen.
 */
    FILE *ff;
    process_file_name(filename, old, n);
ce_print("Filename given as: "); ce_print(old);
ce_print("\nConverted to: "); ce_print(filename);
ce_print("\n");
    if (*filename == 0) return NULL;
#ifdef NO_BINARY_FOPEN
/*
 * On some Unix implementations (I mean DECs version on its MIPS workstations
 * and on the microvax I tried) the library does not support "rb" and "wb"
 * modes, so I work around that here.  Explicit selection of binary file
 * access will be needed on some non-Unix operating systems, but should
 * never be relevant under Unix, hence my choice of a flag for the conditional
 * compilation here.
 */
    if (mode[0] == 'w')
    {   if (mode[1] == '+') mode = "w+";
        else mode = "w";
    }
    else if (mode[1] == '+') mode = "r+";
    else mode = "r";    /* That ought to patch it up */
#endif

    if (old_file == NULL) ff = fopen(filename, mode);
    else 
    {   fclose(old_file);
        ff = fopen(filename, mode);
    }
/*
 * In suitable cases when the first attempt to open the file fails I
 * will try creating any necessary directories and then try again.
 */
    if (ff==NULL && *mode=='w')
    {   char *p = filename;
        while (*p != 0)
        {   int ch = *p;
            if (ch == '/' || ch == '\\')
            {   *p = 0;
                // Cmkdir(filename);  CAN NOT DO THIS YET
                *p = ch;
            }
            p++;
        }
        if (old_file == NULL) ff = fopen(filename, mode);
        else
        {   fclose(old_file);
            ff = fopen(filename, mode);
        }
    }
    return ff;
}

int fwin_linelength = 67;

int fwin_pause_at_end = 0;

void abort()
{
    exit(1);
}

int isatty(int n)
{
    return 0;
}

long file_length(char *filename, char *old, size_t n)
{
    return 0;
}

int file_readable(char *filename, char *old, size_t n)
{
    FILE *ff;
    process_file_name(filename, old, n);
    ff = fopen(filename, "r");
    if (ff == NULL) return 0;
    fclose(ff);
    return 1;
}

int file_writeable(char *filename, char *old, size_t n)
{
    process_file_name(filename, old, n);
    return 1;
}

int directoryp(char *filename, char *old, size_t n)
{
    process_file_name(filename, old, n);
    return 0;
}

char *get_truename(char *filename, char *old, size_t n)
{
    process_file_name(filename, old, n);
    return filename;
}

extern CSLbool file_exists(char *filename, char *old, size_t n, char *tt)
{
    FILE *ff;
    process_file_name(filename, old, n);
    ff = fopen(filename, "r");
    if (ff == NULL) return 0;
    fclose(ff);
    strcpy(tt, "Today");
    return 1;
}

extern char *change_directory(char *filename, char *old, size_t n)
{
    return "change_directory not implemented";
}

/*
 * The interfaces to create_directory and delete_file are similar
 * to that for open_file. They do what their names suggest! They return
 * zero on success, and non-zero on failure. Each does file-name
 * conversion so that Unix-style names can be used even with Windows.
 */

extern int create_directory(char *filename, char *old, size_t n)
{
   return 0;
}

extern int delete_file(char *filename, char *old, size_t n)
{
    return 0;
}

extern int rename_file(char *from_name, char *from_old, size_t from_size,
                       char *to_name,   char *to_old,   size_t to_size)
{
    return 0;
}

int truncate_file(FILE *f, long int where)
{
    return 0;
}

char *tmpnam()
{
    return "tempfile.tmp";
}

char *my_getenv(char *s)
{
    return NULL;
}

int my_system(char *s)
{
    return 0;
}

/*
 * list_directory_members calls the given callback function handing it
 * the name of each file in given directory.
 */

typedef void directory_callback(char *, int, long int);

extern void list_directory_members(char *filename, char *old,
                                  size_t n, directory_callback *fn)
{
    return;
}

int scan_leafstart = 0;

/* end of sysipaq.c */
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]