luke
/
magic
mirror of https://github.com/RTimothyEdwards/magic.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
magic/lisp/lispIO.c

382 lines
8.1 KiB
C
Raw Blame History

/*************************************************************************
*
* lispIO.c --
*
* This module contains the builtin mini-scheme I/O functions.
*
* (c) 1996 California Institute of Technology
* Department of Computer Science
* Pasadena, CA 91125.
*
* Permission to use, copy, modify, and distribute this software
* and its documentation for any purpose and without fee is hereby
* granted, provided that the above copyright notice appear in all
* copies. The California Institute of Technology makes no representations
* about the suitability of this software for any purpose. It is
* provided "as is" without express or implied warranty. Export of this
* software outside of the United States of America may require an
* export license.
*
* $Header$
*
*************************************************************************/
#include <stdio.h>
#include <stdlib.h>
#include "lisp/lisp.h"
#include "lispInt.h"
#include "lispargs.h"
#include "textio/textio.h"
#include "utils/malloc.h"
#include "utils/utils.h"
#include "utils/signals.h"
/*-----------------------------------------------------------------------------
*
* LispLoad --
*
* ("load-scm" "filename")
* Reads and evaluates file.
*
*
* Results:
* #t => file was opened successfully.
* #f => failure.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
LispObj *
LispLoad (name,s,f)
char *name;
Sexp *s;
Sexp *f;
{
extern int LispEchoResult;
LispObj *l, *inp, *res;
FILE *fp;
int val, pos;
char *buffer, *tmp;
int buflen;
int nest;
int line;
if (!ARG1P(s) || LTYPE(ARG1(s)) != S_STRING || ARG2P(s)) {
TxPrintf ("Usage: (%s string)\n", name);
RETURN;
}
l = LispFrameLookup (LispNewString ("scm-library-path"), f);
if (!l)
tmp = NULL;
else if (LTYPE(l) != S_STRING) {
TxPrintf ("%s: scm-library-path is not a string\n", name);
RETURN;
}
else
tmp = LSTR(l);
if (!(fp = PaOpen (LSTR(ARG1(s)), "r", NULL, ".", tmp, NULL))) {
TxPrintf ("%s: could not open file %s for reading\n",name,LSTR(ARG1(s)));
l = LispNewObj ();
LTYPE(l) = S_BOOL;
LBOOL(l) = 0;
RETURN;
}
LispGCAddSexp (s);
buffer = (char *) mallocMagic((unsigned) (buflen = 4096));
pos = 0;
nest = 0;
line = 1;
while ((val = fgetc (fp)) != EOF) {
if (pos == buflen) {
int i;
/* extend buffer */
tmp = buffer;
buflen += 1024;
buffer = (char *) mallocMagic((unsigned) buflen);
for (i=0; i < pos; i++)
buffer[i] = tmp[i];
freeMagic(tmp);
}
if (val == ';') {
/* skip to eol */
while ((val = fgetc(fp)) != EOF && val != '\n')
;
if (val == '\n') line++;
continue;
}
if (val == '\n') line++;
if (val == '\t' || val == '\n') val = ' ';
/* skip white space at nesting level zero */
if (nest == 0 && isspace (val))
continue;
if (nest == 0 && val != '(') {
TxPrintf ("Error reading file %s, line %d\n", LSTR(ARG1(s)), line);
l = LispNewObj ();
LTYPE(l) = S_BOOL;
LBOOL(l) = 0;
freeMagic(buffer);
fclose (fp);
LispGCRemoveSexp (s);
RETURN;
}
buffer[pos++] = val;
if (val == '(')
nest++;
else if (val == ')') {
nest--;
if (nest == 0) {
buffer[pos] = '\0';
inp = LispParseString (buffer);
if (inp) {
res = LispEval (inp, f);
inp = LispFrameLookup (LispNewString ("scm-echo-result"), f);
if (res && inp && LTYPE(inp) == S_BOOL && LBOOL(inp)) {
LispPrint (stdout,res);
TxPrintf ("\n");
}
if (!res) {
if (!SigInterruptPending)
TxPrintf ("Error evaluating file %s, line %d\n",
LSTR(ARG1(s)), line);
freeMagic(buffer);
fclose (fp);
LispGCRemoveSexp (s);
RETURN;
}
}
else {
TxPrintf ("Error parsing file %s, line %d\n", LSTR(ARG1(s)), line);
freeMagic(buffer);
fclose (fp);
LispGCRemoveSexp (s);
RETURN;
}
pos = 0;
}
if (nest < 0) {
TxPrintf ("Error reading file %s, line %d\n", LSTR(ARG1(s)), line);
l = LispNewObj ();
LTYPE(l) = S_BOOL;
LBOOL(l) = 0;
freeMagic(buffer);
fclose (fp);
LispGCRemoveSexp (s);
return l;
}
}
else if (val == '\"') {
while ((val = fgetc (fp)) != EOF && val != '\"') {
if (val == '\n') line++;
if (pos > buflen-1) {
/* extend buffer */
int i;
tmp = buffer;
buflen += 1024;
buffer = (char *) mallocMagic((unsigned) (buflen));
for (i=0; i < pos; i++)
buffer[i] = tmp[i];
freeMagic(tmp);
}
buffer[pos++] = val;
if (val == '\\') {
val = fgetc (fp);
buffer[pos++] = val;
if (val == '\n') line++;
}
}
if (val == EOF) {
TxPrintf ("Error reading file %s, line %d\n", LSTR(ARG1(s)), line);
freeMagic(buffer);
fclose (fp);
LispGCRemoveSexp (s);
RETURN;
}
buffer[pos++] = val;
}
}
freeMagic(buffer);
fclose (fp);
if (pos > 0) {
TxPrintf ("Error reading file %s, line %d\n", LSTR(ARG1(s)), line);
LispGCRemoveSexp (s);
RETURN;
}
else {
LispGCRemoveSexp (s);
l = LispNewObj ();
LTYPE(l) = S_BOOL;
LBOOL(l) = 1;
}
return l;
}
/*-----------------------------------------------------------------------------
*
* LispWrite --
*
* Write an object to a file.
*
* Results:
* none.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
LispObj *
LispWrite (name,s,f)
char *name;
Sexp *s;
Sexp *f;
{
FILE *fp;
LispObj *l;
if (!ARG1P(s) || LTYPE(ARG1(s)) != S_STRING || !ARG2P(s) || ARG3P(s)) {
TxPrintf ("Usage: (%s str obj)\n", name);
RETURN;
}
if (!(fp = PaOpen (LSTR(ARG1(s)), "a", NULL, ".", NULL, NULL))) {
TxPrintf ("%s: could not open file %s for writing\n",name,LSTR(ARG1(s)));
RETURN;
}
fprintf (fp, ";\n");
LispPrint (fp,ARG2(s));
fprintf (fp, "\n");
fclose (fp);
l = LispNewObj ();
LTYPE(l) = S_BOOL;
LBOOL(l) = 1;
return l;
}
/*-----------------------------------------------------------------------------
*
* LispSpawn --
*
* (spawn list-of-strings)
* Reads and evaluates file.
*
*
* Results:
* pid => the pid of the spawned process.
* -1 => if spawn failed.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
LispObj *
LispSpawn (name,s,f)
char *name;
Sexp *s;
Sexp *f;
{
LispObj *l;
int pid;
Sexp *t;
char **argv;
int n;
if (!ARG1P(s)) {
TxPrintf ("Usage: (%s string-list)\n", name);
RETURN;
}
t = s;
n = 1;
while (ARG1P(t)) {
if (LTYPE(CAR(t)) != S_STRING) {
TxPrintf ("Usage: (%s string-list)\n", name);
RETURN;
}
n++;
t = LLIST(CDR(t));
}
argv = (char **) mallocMagic((unsigned) (sizeof(char*)*n));
t = s;
n = 0;
while (ARG1P(t)) {
argv[n] = LSTR(CAR(t));
n++;
t = LLIST(CDR(t));
}
argv[n] = NULL;
FORK_f(pid);
if (pid < 0) {
TxPrintf ("Error: could not fork a process!\n");
freeMagic(argv);
RETURN;
}
else if (pid == 0) {
int i;
/* try closing all files, so that we don't mess up the state of
the parent */
for (i=3; i < 256; i++)
close (i);
execvp (argv[0], argv);
_exit (1000);
}
freeMagic(argv);
l = LispNewObj ();
LTYPE(l) = S_INT;
LINTEGER(l) = pid;
return l;
}
/*-----------------------------------------------------------------------------
*
* LispWait --
*
* (wait pid)
* Wait for pid to terminate.
*
* Results:
* The status, error if the pid is an invalid pid.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
LispObj *
LispWait (name,s,f)
char *name;
Sexp *s;
Sexp *f;
{
LispObj *l;
int stat;
if (!ARG1P(s) || LTYPE(ARG1(s)) != S_INT) {
TxPrintf ("Usage: (%s pid)\n", name);
RETURN;
}
if (WaitPid (LINTEGER(ARG1(s)), &stat) < 0) {
TxPrintf ("%s: waiting for an invalid pid\n", name);
RETURN;
}
l = LispNewObj ();
LTYPE(l) = S_INT;
LINTEGER(l) = stat;
return l;
}
Reference in New Issue View Git Blame Copy Permalink