zysen()
{
register struct fcblk *fcb = WA (struct fcblk *);
register struct ioblk *iob = MK_MP(fcb->iob, struct ioblk *);
/* ensure the file is open */
if ( !(iob->flg1 & IO_OPN) )
return EXIT_1;
/* now close it */
if (osclose( iob ))
return EXIT_3;
return NORMAL_RETURN;
}
/* xtranscript - open or close a transcript file */
LVAL xtranscript(void)
{
unsigned char *name;
/* get the transcript file name */
name = (moreargs() ? getstring(xlgetfname()) : NULL);
xllastarg();
/* close the current transcript */
if (tfp) osclose(tfp);
/* open the new transcript */
tfp = (name ? osaopen((char *) name,"w") : NULL);
/* return T if a transcript is open, NIL otherwise */
return (tfp ? s_true : NIL);
}
/* xclose - close a file */
LVAL xclose(void)
{
LVAL fptr;
/* get file pointer */
fptr = xlgastream();
xllastarg();
/* make sure the file exists */
if (getfile(fptr) == NULL)
xlfail("file not open");
/* close the file */
osclose(getfile(fptr));
setfile(fptr,NULL);
/* return nil */
return (NIL);
}
int fileclose(int fd,const char *name)
{
int rv = osclose(fd);
if (rv) oserror(0,"cannot close %s",name);
return rv;
}
/* 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;
}
/* dmazzoni: was LOCAL void sweep(void) */
void sweep(void)
{
SEGMENT *seg;
LVAL p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0L;
/* add all unmarked nodes */
for (seg = segs; seg; seg = seg->sg_next) {
if (seg == fixseg) /* don't sweep the fixnum segment */
continue;
else if (seg == charseg) /* don't sweep the character segment */
continue;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; --n >= 0; ++p) {
#ifdef DEBUG_MEM
if (xldmem_trace &&
ntype(p) == EXTERN &&
xldmem_trace == getinst(p)) {
printf("sweep: EXTERN node %lx is %smarked, points to %lx\n",
p, (p->n_flags & MARK ? "" : "un"), getinst(p));
}
#endif
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STRING:
if (getstring(p) != NULL) {
total -= (long)getslength(p);
free(getstring(p));
}
break;
case STREAM:
if (getfile(p))
osclose(getfile(p));
break;
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
if (p->n_vsize) {
total -= (long) (p->n_vsize * sizeof(LVAL));
free((void *) p->n_vdata);
}
break;
case EXTERN:
/* printf("GC about to free %x\n", p);
* fflush(stdout);
*/
if (getdesc(p)) { (*(getdesc(p)->free_meth))(getinst(p));
}
break;
}
p->n_type = FREE_NODE;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree += 1L;
}
else
p->n_flags &= ~MARK;
}
}
}
