14 #include "EST_Pathname.h"
16 static void siod_string_print(LISP exp,
EST_String &sd);
18 LISP open_files = NIL;
20 void pprintf(FILE *fd,LISP exp,
int indent,
int width,
int depth,
int length)
33 fprintf(fd,
"%s",(
const char *)siod_sprint(exp));
37 if (p.
length() < width-indent)
38 fprintf(fd,
"%s",(
const char *)p);
47 pprintf(fd,car(exp),indent,width,depth-1,length);
48 for (ll=length,l=cdr(exp); l != NIL; l=cdr(l),ll--)
51 for (i=0; i<indent; i++)
55 pprintf(fd,rintern(
"..."),indent,width,
61 fprintf(fd,
" . %s",(
const char *)siod_sprint(l));
65 pprintf(fd,car(l),indent,width,depth-1,length);
73 void pprint_to_fd(FILE *fd,LISP exp)
75 pprintf(fd,exp,0,72,-1,-1);
79 static LISP siod_pprintf(LISP exp, LISP file)
84 (equal(file,rintern(
"t"))))
88 pprintf(get_c_file(file,stdout),exp,0,72,-1,-1);
89 fprintf(get_c_file(file,stdout),
"\n");
98 pprint_to_fd(stdout,exp);
101 static LISP fflush_l(LISP p)
105 else if NTYPEP(p,tc_c_file)
108 fflush(p->storage_as.c_file.f);
112 static
void siod_string_print(LISP exp,
EST_String &sd)
124 siod_string_print(car(exp),sd);
125 for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
128 siod_string_print(car(tmp),sd);
133 siod_string_print(tmp,sd);
138 if (FLONMPNAME(exp) == NULL)
140 sprintf(tkbuffer,
"%.8g",FLONM(exp));
141 FLONMPNAME(exp) = (
char *)must_malloc(strlen(tkbuffer)+1);
142 sprintf(FLONMPNAME(exp),
"%s",tkbuffer);
144 sprintf(tkbuffer,
"%s",FLONMPNAME(exp));
149 for (i=0; exp->storage_as.string.data[i] !=
'\0'; i++)
151 if (exp->storage_as.string.data[i] ==
'"')
153 if (exp->storage_as.string.data[i] ==
'\\')
155 sprintf(tkbuffer,
"%c",exp->storage_as.string.data[i]);
171 sprintf(tkbuffer,
"#<SUBR(%d) ",TYPE(exp));
173 sd += (*exp).storage_as.subr.name;
177 sprintf(tkbuffer,
"#<FILE %p ",(
void *)exp->storage_as.c_file.f);
179 if (exp->storage_as.c_file.name)
180 sd += exp->storage_as.c_file.name;
185 siod_string_print(car((*exp).storage_as.closure.code),sd);
187 siod_string_print(cdr((*exp).storage_as.closure.code),sd);
192 p = get_user_type_hooks(TYPE(exp));
194 (*p->print_string)(exp, tkbuffer);
198 sprintf(tkbuffer,
"#<%s %p>",p->name,(
void *)exp);
200 sprintf(tkbuffer,
"#<UNKNOWN %d %p>",TYPE(exp),(
void *)exp);
212 siod_string_print(exp,r);
218 static LISP fd_to_scheme_file(
int fd,
225 flag = no_interrupt(1);
226 sym = newcell(tc_c_file);
227 sym->storage_as.c_file.f = (FILE *)NULL;
228 sym->storage_as.c_file.name = (
char *)NULL;
230 if (fd != fileno(stderr))
231 open_files = cons(sym,open_files);
232 sym->storage_as.c_file.name = (
char *) must_malloc(strlen(name)+1);
233 if (fd == fileno(stdin))
234 sym->storage_as.c_file.f = stdin;
235 else if (fd == fileno(stdout))
236 sym->storage_as.c_file.f = stdout;
237 else if (fd == fileno(stderr))
238 sym->storage_as.c_file.f = stderr;
239 else if (!(sym->storage_as.c_file.f = fdopen(fd ,how)))
245 err(
"could not open file", name);
247 strcpy(sym->storage_as.c_file.name,name);
252 LISP fopen_c(
const char *name,
const char *how)
257 fd = fd_open_file(name, how);
260 err(
"could not open file", name);
262 sym = fd_to_scheme_file(fd, name, how, 1);
267 LISP siod_fdopen_c(
int fd,
const char *name,
char *how)
269 return fd_to_scheme_file(fd, name, how, 0);
272 LISP fopen_l(LISP what,
const char *r_or_w)
275 const char *filename = NULL;
280 fd = fd_open_stdinout(r_or_w);
282 else if (SYMBOLP(what) || STRINGP(what))
284 fd = fd_open_file((filename = get_c_string(what)), r_or_w);
286 else if (LIST1P(what))
288 fd = fd_open_file((filename = get_c_string(CAR(what))), r_or_w);
290 else if (CONSP(what) && !CONSP(CDR(what)))
292 filename =
"[tcp connection]";
293 fd = fd_open_url(
"tcp",
294 get_c_string(CAR(what)),
295 get_c_string(CDR(what)),
299 else if (LIST4P(what))
302 fd = fd_open_url(get_c_string(CAR1(what)),
303 get_c_string(CAR2(what)),
304 get_c_string(CAR3(what)),
305 get_c_string(CAR4(what)),
309 err(
"not openable", what);
312 err(
"can't open", what);
314 return fd_to_scheme_file(fd, filename, r_or_w, 1);
317 static void file_gc_free(LISP ptr)
318 {
if ((ptr->storage_as.c_file.f) &&
319 (ptr->storage_as.c_file.f != stdin) &&
320 (ptr->storage_as.c_file.f != stdout))
321 {fclose(ptr->storage_as.c_file.f);
322 ptr->storage_as.c_file.f = (FILE *) NULL;}
323 if (ptr->storage_as.c_file.name)
324 {wfree(ptr->storage_as.c_file.name);
325 ptr->storage_as.c_file.name = NULL;}}
327 LISP fclose_l(LISP p)
329 flag = no_interrupt(1);
330 if NTYPEP(p,tc_c_file) err("not a file",p);
332 open_files = delq(p,open_files);
336 static
void file_prin1(LISP ptr,FILE *f)
338 name = ptr->storage_as.c_file.name;
339 fput_st(f,
"#<FILE ");
340 sprintf(tkbuffer,
" %p",(
void *)ptr->storage_as.c_file.f);
347 FILE *get_c_file(LISP p,FILE *deflt)
348 {
if (NULLP(p) && deflt)
return(deflt);
349 if NTYPEP(p,tc_c_file) err("not a file",p);
350 if (!p->storage_as.c_file.f) err("file is closed",p);
351 return(p->storage_as.c_file.f);}
355 i = f_getc(get_c_file(p,stdin));
356 return((i == EOF) ? NIL : flocons((
double)i));}
358 LISP lputc(LISP c,LISP p)
362 f = get_c_file(p,stdout);
366 i = *get_c_string(c);
367 flag = no_interrupt(1);
372 LISP lputs(LISP str,LISP p)
373 {fput_st(get_c_file(p,stdout),get_c_string(str));
376 LISP lftell(LISP file)
377 {
return(flocons((
double)ftell(get_c_file(file,NULL))));}
379 LISP lfseek(LISP file,LISP offset,LISP direction)
380 {
return((fseek(get_c_file(file,NULL),get_c_int(offset),get_c_int(direction)))
383 static LISP directory_entries(LISP ldir, LISP lnoflagdir)
391 dir = dir.as_directory();
393 EST_StrList entries(dir.entries(lnoflagdir!=NIL?0:1));
396 for(item=entries.head(); item; item = item->next())
399 if (entry !=
"../" && entry !=
"./" && entry !=
".." && entry !=
".")
401 LISP litem = strintern(entry);
402 lentries = cons(litem, lentries);
409 static LISP fopen_l(LISP what,LISP how)
411 const char *r_or_w = NULLP(how) ?
"rb" : get_c_string(how);
413 return fopen_l(what, r_or_w);
417 static LISP lfread(LISP size,LISP file)
422 f = get_c_file(file,NULL);
423 flag = no_interrupt(1);
424 if TYPEP(size,tc_string)
426 buffer = s->storage_as.string.data;
427 n = s->storage_as.string.dim;
430 {n = get_c_int(size);
431 buffer = (
char *) must_malloc(n+1);
434 ret = fread(buffer,1,n,f);
444 s->storage_as.string.data = buffer;
445 s->storage_as.string.dim = n;}
447 {s = strcons(ret,NULL);
448 memcpy(s->storage_as.string.data,buffer,ret);
453 return(flocons((
double)ret));}
455 static LISP lfwrite(LISP
string,LISP file)
460 f = get_c_file(file,NULL);
461 if NTYPEP(
string,tc_string) err("not a
string",
string);
462 data =
string->storage_as.
string.data;
463 dim =
string->storage_as.
string.dim;
464 flag = no_interrupt(1);
465 fwrite(data,dim,1,f);
469 LISP lprin1f(LISP exp,FILE *f)
481 for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
482 {fput_st(f,
" ");lprin1f(car(tmp),f);}
483 if NNULLP(tmp) {fput_st(f,
" . ");lprin1f(tmp,f);}
487 if (FLONMPNAME(exp) == NULL)
489 sprintf(tkbuffer,
"%.8g",FLONM(exp));
490 FLONMPNAME(exp) = (
char *)must_malloc(strlen(tkbuffer)+1);
491 sprintf(FLONMPNAME(exp),
"%s",tkbuffer);
493 sprintf(tkbuffer,
"%s",FLONMPNAME(exp));
497 fput_st(f,PNAME(exp));
507 sprintf(tkbuffer,
"#<SUBR(%d) ",TYPE(exp));
509 fput_st(f,(*exp).storage_as.subr.name);
513 fput_st(f,
"#<CLOSURE ");
514 lprin1f(car((*exp).storage_as.closure.code),f);
516 lprin1f(cdr((*exp).storage_as.closure.code),f);
520 p = get_user_type_hooks(TYPE(exp));
526 sprintf(tkbuffer,
"#<%s %p>",p->name,USERVAL(exp));
528 sprintf(tkbuffer,
"#<UNKNOWN %d %p>",TYPE(exp),(
void *)exp);
529 fput_st(f,tkbuffer);}}
532 static LISP lprintfp(LISP exp,LISP file)
533 {lprin1f(exp,get_c_file(file,stdout));
536 static LISP terpri(LISP file)
537 {fput_st(get_c_file(file,stdout),
"\n");
540 static LISP lreadfp(LISP file)
541 {
return lreadf(get_c_file(file,stdout));}
543 LISP load(LISP fname,LISP cflag)
544 {
return(vload(get_c_string(fname),NULLP(cflag) ? 0 : 1));}
546 LISP lprint(LISP exp)
547 {lprin1f(exp,stdout);
552 {
return(lreadf(stdin));}
554 LISP get_eof_val(
void)
557 static LISP probe_file(LISP fname)
560 const char *filename;
562 filename = get_c_string(fname);
563 if (access(filename,R_OK) == 0)
569 static LISP lunlink(LISP name)
571 unlink(get_c_string(name));
575 static LISP save_forms(LISP fname,LISP forms,LISP how)
577 const char *chow = NULL;
580 cname = get_c_string(fname);
581 if EQ(how,NIL) chow = "wb";
582 else if EQ(how,cintern("a")) chow = "a";
583 else err("bad argument to save-forms",how);
584 fput_st(fwarn,(*chow == 'a') ? "appending" : "saving");
585 fput_st(fwarn," forms to ");
586 fput_st(fwarn,cname);
588 lf = fopen_c(cname,chow);
589 f = lf->storage_as.c_file.f;
590 for(l=forms;NNULLP(l);l=cdr(l))
594 fput_st(fwarn,
"done.\n");
597 void close_open_files_upto(LISP end)
599 for(l=open_files;((l!=end)&&(l!=NIL));l=cdr(l))
601 if (p->storage_as.c_file.f)
602 {fprintf(stderr,
"closing a file left open: %s\n",
603 (p->storage_as.c_file.name) ? p->storage_as.c_file.name :
"");
608 void close_open_files(
void)
610 close_open_files_upto(NIL);
613 static void check_first_line(FILE *lf)
616 if ((c0=getc(lf)) ==
'#')
618 if ((c1 = getc(lf)) ==
'!')
619 while (((c2=getc(lf)) !=
'\n') && (c2 != EOF));
630 LISP vload(
const char *fname_raw,
long cflag)
632 LISP form,result,tail,lf;
635 fput_st(fwarn,
"loading ");
636 fput_st(fwarn,fname);
638 lf = fopen_c(fname,
"rb");
639 f = lf->storage_as.c_file.f;
646 if EQ(form,eof_val) break;
648 {form = cons(form,NIL);
650 result = tail = form;
652 tail = setcdr(tail,form);}
656 fput_st(fwarn,"done.\n");
659 void init_subrs_file(
void)
662 set_gc_hooks(tc_c_file,FALSE,NULL,NULL,NULL,file_gc_free,NULL,&j);
663 set_print_hooks(tc_c_file,file_prin1, NULL);
664 setvar(cintern(
"stderr"),
665 fd_to_scheme_file(fileno(stderr),
"stderr",
"w",FALSE),NIL);
667 init_subr_2(
"fread",lfread,
668 "(fread BUFFER FILE)\n\
669 BUFFER is a string of length N, N bytes are read from FILE into\n\
671 init_subr_2(
"fwrite",lfwrite,
672 "(fwrite BUFFER FILE)\n\
673 Write BUFFER into FILE.");
675 init_subr_0(
"read",lread,
677 Read next s-expression from stdin and return it.");
678 init_subr_0(
"eof-val",get_eof_val,
680 Returns symbol used to indicate end of file. May be used (with eq?)\n\
681 to determine when end of file occurs while reading files.");
682 init_subr_1(
"print",lprint,
684 Print DATA to stdout if textual form. Not a pretty printer.");
685 init_subr_2(
"pprintf",siod_pprintf,
686 "(pprintf EXP [FD])\n\
687 Pretty print EXP to FD, if FD is nil print to the screen.");
688 init_subr_2(
"printfp",lprintfp,
689 "(printfp DATA FILEP)\n\
690 Print DATA to file indicated by file pointer FILEP. File pointers are\n\
691 are created by fopen.");
692 init_subr_1(
"readfp",lreadfp,
694 Read and return next s-expression from file indicated by file pointer\n\
695 FILEP. File pointers are created by fopen.");
696 init_subr_1(
"terpri",terpri,
698 Print newline to FILEP, is FILEP is nil or not specified a newline it\n\
699 is printed to stdout.");
700 init_subr_1(
"fflush",fflush_l,
702 Flush FILEP. If FILEP is nil, then flush stdout.");
703 init_subr_2(
"fopen",fopen_l,
704 "(fopen FILENAME HOW)\n\
705 Return file pointer for FILENAME opened in mode HOW.");
706 init_subr_1(
"fclose",fclose_l,
708 Close filepoint FILEP.");
709 init_subr_1(
"getc",lgetc,
711 Get next character from FILEP. Character is returned as a number. If\n\
712 FILEP is nil, or not specified input comes from stdin.");
713 init_subr_2(
"putc",lputc,
714 "(putc ECHAR FILEP)\n\
715 Put ECHAR (a number) as a character to FILEP. If FILEP is nil or not\n\
716 specified output goes to stdout.");
717 init_subr_2(
"puts",lputs,
718 "(puts STRING FILEP)\n\
719 Write STRING (print name of symbol) to FILEP. If FILEP is nil or not\n\
720 specified output goes to stdout.");
721 init_subr_1(
"ftell",lftell,
723 Returns position in file FILEP is currently pointing at.");
724 init_subr_3(
"fseek",lfseek,
725 "(fseek FILEP OFFSET DIRECTION)\n\
726 Position FILEP to OFFSET. If DIRECTION is 0 offset is from start of file.\n\
727 If DIRECTION is 1, offset is from current position. If DIRECTION is\n\
728 2 offset is from end of file.");
729 init_subr_1(
"probe_file",probe_file,
730 "(probe_file FILENAME)\n\
731 Returns t if FILENAME exists and is readable, nil otherwise.");
732 init_subr_1(
"delete-file",lunlink,
733 "(delete-file FILENAME)\n\
734 Delete named file.");
735 init_subr_2(
"load",load,
736 "(load FILENAME OPTION)\n\
737 Load s-expressions in FILENAME. If OPTION is nil or unspecified evaluate\n\
738 each s-expression in FILENAME as it is read, if OPTION is t, return them\n\
739 unevaluated in a list.");
741 init_subr_2(
"directory-entries", directory_entries,
742 "(directory-entries DIRECTORY &opt NOFLAGDIR)\n\
743 Return a list of the entries in the directory. If NOFLAGDIR is non-null\n\
744 don't check to see which are directories.");
746 init_subr_3(
"save-forms",save_forms,
747 "(save-forms FILENAME FORMS HOW)\n\
748 Save FORMS in FILENAME. If HOW is a appending FORMS to FILENAME,\n\
749 or if HOW is w start from the beginning of FILENAME.");