/* xlopen - open a text or binary file */
LVAL xlopen(int binaryflag)
{
char *name,*mode=NULL;
FILE *fp;
LVAL dir;
/* get the file name and direction */
name = (char *)getstring(xlgetfname());
if (!xlgetkeyarg(k_direction,&dir))
dir = k_input;
/* get the mode */
if (dir == k_input)
mode = "r";
else if (dir == k_output)
mode = "w";
else
xlerror("bad direction",dir);
/* try to open the file */
if (binaryflag) {
fp = osbopen(name,mode);
} else {
fp = osaopen(name,mode);
}
return (fp ? cvfile(fp) : NIL);
}
/******************************************************************************
* Prim_POPEN - start a process and open a pipe for read/write
* (code stolen from xlfio.c:xopen())
*
* syntax: (popen <command line> :direction <direction>)
* <command line> is a string to be sent to the subshell (sh).
* <direction> is either :input (to read from the pipe) or
* :output (to write to the pipe).
* (:input is the default)
*
* Popen returns a stream, or NIL if files or processes couldn't be created.
* The success of the command execution can be checked by examining the
* return value of pclose.
*
* Added to XLISP by Niels Mayer
******************************************************************************/
LVAL Prim_POPEN()
{
extern LVAL k_direction, k_input, k_output;
char *name,*mode;
FILE *fp;
LVAL dir;
/* get the process name and direction */
name = (char *) getstring(xlgastring());
if (!xlgetkeyarg(k_direction, &dir))
dir = k_input;
/* get the mode */
if (dir == k_input)
mode = "r";
else if (dir == k_output)
mode = "w";
else
xlerror("bad direction",dir);
/* try to open the file */
return ((fp = popen(name,mode)) ? cvfile(fp) : NIL);
}
/* xlload - load a file of xlisp expressions */
int xlload(char *fname, int vflag, int pflag)
{
char fullname[STRMAX+1];
char *ptr;
LVAL fptr,expr;
XLCONTEXT cntxt;
FILE *fp;
int sts;
/* protect some pointers */
xlstkcheck(2);
xlsave(fptr);
xlsave(expr);
/* space for copy + extension? */
if (strlen(fname) > STRMAX - 4) goto toolong;
strcpy(fullname,fname);
#ifdef WINDOWS
#ifdef WINGUI
if (strcmp(fullname, "*") == 0) {
if (sfn_valid) {
strcpy(fullname, save_file_name);
} else {
strcpy(fullname, "*.*");
}
}
if (strcmp(fullname, "*.*") == 0) {
char *name = getfilename(NULL, "lsp", "r", "Load file");
if (name) {
strcpy(fullname, name);
strcpy(save_file_name, name);
sfn_valid = TRUE;
} else {
xlpopn(2);
return FALSE;
}
}
#endif
/* replace "/" with "\" so that (current-path) will work */
for (ptr = fullname; *ptr; ptr++) {
if (*ptr == '/') *ptr = '\\';
}
#endif
/* default the extension if there is room */
if (needsextension(fullname)) {
strcat(fullname,".lsp");
}
/* allocate a file node */
fptr = cvfile(NULL);
/* open the file */
if ((fp = osaopen(fullname,"r")) == NULL) {
#ifdef UNIX
if (fname[0] != '/') {
char *paths = getenv("XLISPPATH");
if (!paths || !*paths) {
char msg[512];
sprintf(msg, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the environment.",
"If you are using Nyquist, probably you should cd to the",
"nyquist directory and type:",
" setenv XLISPPATH `pwd`/runtime:`pwd`/lib",
"or set XLISPPATH in your .login or .cshrc file.");
errputstr(msg);
}
/* make sure we got paths, and the list is not empty */
while (paths && *paths) {
char *ptr = fullname;
/* skip over separator */
while (*paths == ':') paths++;
/* scan next directory into fullname */
while (*paths && (*paths != ':')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *paths++;
}
/* add "/" if needed */
if (ptr[-1] != '/') *ptr++ = '/';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef WINDOWS
/* is this a relative path? */
if (fname[0] != '\\' && (strlen(fname) < 2 || fname[1] != ':')) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
get_xlisp_path(paths, paths_max);
/* make sure we got paths, and the list is not empty */
if (!*p) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in the Registry.",
"You should follow the installation instructions. Enter an",
"empty string if you really want no search path.");
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add "\" if needed */
if (ptr[-1] != '\\') *ptr++ = '\\';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
#ifdef MACINTOSH
/* is this a relative path? I don't know how to do this
* correctly, so we'll assume it's relative if there is no
* embedded colon (:)
*/
if (strchr(fname, ':') == NULL) {
#define paths_max 1024
char paths[paths_max];
char *p = paths;
int prefs_found = false;
get_xlisp_path(paths, paths_max, &prefs_found);
/* make sure we got paths, and the list is not empty */
if (!*p) {
if (prefs_found) {
sprintf(paths, "\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLISPPATH in XLisp Preferences.",
"You should probably delete XLisp Preferences and let XLisp",
"create a new one for you.");
} else {
sprintf(paths, "\n%s\n%s\n%s\n%s\n%s\n",
"Warning: XLISP failed to find XLisp Preferences.",
"You should manually locate and load the file runtime:init.lsp",
"Nyquist will create an XLisp Preferences file to automatically",
"find the file next time. You may edit XLisp Preferences to add",
"additional search paths, using a comma as separator.");
}
errputstr(paths);
*p = 0;
}
while (*p) {
char *ptr = fullname;
/* skiip over separator */
while (*p == ',') p++;
/* scan next directory into fullname */
while (*p && (*p != ',')) {
if ((ptr - fullname) >= STRMAX) goto toolong;
*ptr++ = *p++;
}
/* add ":" if needed */
if (ptr[-1] != ':') *ptr++ = ':';
/* append the file name */
if ((ptr - fullname) + strlen(fname) + 4 > STRMAX)
goto toolong;
strcpy(ptr, fname);
/* append the .lsp extension */
if (needsextension(fullname)) {
strcat(fullname, ".lsp");
}
/* printf("Trying to open \"%s\"\n", fullname); */
if (fp = osaopen(fullname, "r")) goto gotfile;
}
}
#endif
xlpopn(2);
return (FALSE);
}
gotfile:
#ifdef MACINTOSH
/* We found the file ok, call setup_preferences to create
* XLisp Preferences file (this only happens if previous
* attempt to find the file failed
*/
setup_preferences(fullname);
#endif
setfile(fptr,fp);
setvalue(s_loadingfiles, cons(fptr, getvalue(s_loadingfiles)));
setvalue(s_loadingfiles, cons(cvstring(fullname), getvalue(s_loadingfiles)));
/* print the information line */
if (vflag)
{ sprintf(buf,"; loading \"%s\"\n",fullname); stdputstr(buf); }
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR,s_true);
if (setjmp(cntxt.c_jmpbuf))
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* close the file */
osclose(getfile(fptr));
setfile(fptr,NULL);
if (consp(getvalue(s_loadingfiles)) &&
consp(cdr(getvalue(s_loadingfiles))) &&
car(cdr(getvalue(s_loadingfiles))) == fptr) {
setvalue(s_loadingfiles, cdr(cdr(getvalue(s_loadingfiles))));
}
/* restore the stack */
xlpopn(2);
/* return status */
return (sts);
toolong:
xlcerror("ignore file", "file name too long", NIL);
xlpopn(2);
return FALSE;
}
/* xlsymbols - enter all of the symbols used by the interpreter */
void xlsymbols(void)
{
LVAL sym;
/* enter the unbound variable indicator (must be first) */
s_unbound = xlenter("*UNBOUND*");
setvalue(s_unbound,s_unbound);
/* enter the 't' symbol */
s_true = xlenter("T");
setvalue(s_true,s_true);
/* enter some important symbols */
s_dot = xlenter(".");
s_quote = xlenter("QUOTE");
s_function = xlenter("FUNCTION");
s_bquote = xlenter("BACKQUOTE");
s_comma = xlenter("COMMA");
s_comat = xlenter("COMMA-AT");
s_lambda = xlenter("LAMBDA");
s_macro = xlenter("MACRO");
s_eql = xlenter("EQL");
s_ifmt = xlenter("*INTEGER-FORMAT*");
s_ffmt = xlenter("*FLOAT-FORMAT*");
/* symbols set by the read-eval-print loop */
s_1plus = xlenter("+");
s_2plus = xlenter("++");
s_3plus = xlenter("+++");
s_1star = xlenter("*");
s_2star = xlenter("**");
s_3star = xlenter("***");
s_minus = xlenter("-");
/* enter setf place specifiers */
s_setf = xlenter("*SETF*");
s_car = xlenter("CAR");
s_cdr = xlenter("CDR");
s_nth = xlenter("NTH");
s_aref = xlenter("AREF");
s_get = xlenter("GET");
s_svalue = xlenter("SYMBOL-VALUE");
s_sfunction = xlenter("SYMBOL-FUNCTION");
s_splist = xlenter("SYMBOL-PLIST");
/* enter the readtable variable and keywords */
s_rtable = xlenter("*READTABLE*");
k_wspace = xlenter(":WHITE-SPACE");
k_const = xlenter(":CONSTITUENT");
k_nmacro = xlenter(":NMACRO");
k_tmacro = xlenter(":TMACRO");
k_sescape = xlenter(":SESCAPE");
k_mescape = xlenter(":MESCAPE");
/* enter parameter list keywords */
k_test = xlenter(":TEST");
k_tnot = xlenter(":TEST-NOT");
/* "open" keywords */
k_direction = xlenter(":DIRECTION");
k_input = xlenter(":INPUT");
k_output = xlenter(":OUTPUT");
/* enter *print-case* symbol and keywords */
s_printcase = xlenter("*PRINT-CASE*");
k_upcase = xlenter(":UPCASE");
k_downcase = xlenter(":DOWNCASE");
/* other keywords */
k_start = xlenter(":START");
k_end = xlenter(":END");
k_1start = xlenter(":START1");
k_1end = xlenter(":END1");
k_2start = xlenter(":START2");
k_2end = xlenter(":END2");
k_verbose = xlenter(":VERBOSE");
k_print = xlenter(":PRINT");
k_count = xlenter(":COUNT");
k_key = xlenter(":KEY");
/* enter lambda list keywords */
lk_optional = xlenter("&OPTIONAL");
lk_rest = xlenter("&REST");
lk_key = xlenter("&KEY");
lk_aux = xlenter("&AUX");
lk_allow_other_keys = xlenter("&ALLOW-OTHER-KEYS");
/* enter *standard-input*, *standard-output* and *error-output* */
s_stdin = xlenter("*STANDARD-INPUT*");
setvalue(s_stdin,cvfile(stdin));
s_stdout = xlenter("*STANDARD-OUTPUT*");
setvalue(s_stdout,cvfile(stdout));
s_stderr = xlenter("*ERROR-OUTPUT*");
setvalue(s_stderr,cvfile(STDERR));
/* enter *debug-io* and *trace-output* */
s_debugio = xlenter("*DEBUG-IO*");
setvalue(s_debugio,getvalue(s_stderr));
s_traceout = xlenter("*TRACE-OUTPUT*");
setvalue(s_traceout,getvalue(s_stderr));
/* enter the eval and apply hook variables */
s_evalhook = xlenter("*EVALHOOK*");
s_applyhook = xlenter("*APPLYHOOK*");
/* enter the symbol pointing to the list of functions being traced */
s_tracelist = xlenter("*TRACELIST*");
/* enter the error traceback and the error break enable flags */
s_tracenable = xlenter("*TRACENABLE*");
s_tlimit = xlenter("*TRACELIMIT*");
s_breakenable = xlenter("*BREAKENABLE*");
s_profile = xlenter("*PROFILE*");
/* enter the symbol pointing to the list of loading files */
s_loadingfiles = xlenter("*LOADINGFILES*");
/* enter a symbol to control printing of garbage collection messages */
s_gcflag = xlenter("*GC-FLAG*");
s_gchook = xlenter("*GC-HOOK*");
/* enter the symbol for the search path */
s_search_path = xlenter("*SEARCH-PATH*");
/* enter a copyright notice into the oblist */
sym = xlenter("**Copyright-1988-by-David-Betz**");
setvalue(sym,s_true);
/* enter type names */
a_subr = xlenter("SUBR");
a_fsubr = xlenter("FSUBR");
a_cons = xlenter("CONS");
a_symbol = xlenter("SYMBOL");
a_fixnum = xlenter("FIXNUM");
a_flonum = xlenter("FLONUM");
a_string = xlenter("STRING");
a_object = xlenter("OBJECT");
a_stream = xlenter("FILE-STREAM");
a_vector = xlenter("ARRAY");
a_extern = xlenter("EXTERN");
a_closure = xlenter("CLOSURE");
a_char = xlenter("CHARACTER");
a_ustream = xlenter("UNNAMED-STREAM");
/* add the object-oriented programming symbols and os specific stuff */
obsymbols(); /* object-oriented programming symbols */
ossymbols(); /* os specific symbols */
localsymbols(); /* lisp extension symbols */
}
