1 /* xlfio.c - xlisp file i/o */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 /* CHANGE LOG
7 * --------------------------------------------------------------------
8 * 30Sep06 rbd added xbigendianp
9 * 28Apr03 dm eliminate some compiler warnings
10 */
11
12
13 #include "switches.h"
14
15 #include <string.h>
16
17 #include "xlisp.h"
18
19 /* do some sanity checking: */
20 #ifndef XL_BIG_ENDIAN
21 #ifndef XL_LITTLE_ENDIAN
22 #error configuration error -- either XL_BIG_ or XL_LITTLE_ENDIAN must be defined in xlisp.h
23 #endif
24 #endif
25 #ifdef XL_BIG_ENDIAN
26 #ifdef XL_LITTLE_ENDIAN
27 #error configuration error -- both XL_BIG_ and XL_LITTLE_ENDIAN are defined!
28 #endif
29 #endif
30
31 /* forward declarations */
32 FORWARD LOCAL LVAL getstroutput(LVAL stream);
33 FORWARD LOCAL LVAL printit(int pflag, int tflag);
34 FORWARD LOCAL LVAL flatsize(int pflag);
35
36 /* xread - read an expression */
xread(void)37 LVAL xread(void)
38 {
39 LVAL fptr,eof,rflag,val;
40
41 /* get file pointer and eof value */
42 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
43 eof = (moreargs() ? xlgetarg() : NIL);
44 rflag = (moreargs() ? xlgetarg() : NIL);
45 xllastarg();
46
47 /* read an expression */
48 if (!xlread(fptr,&val,rflag != NIL))
49 val = eof;
50
51 /* return the expression */
52 return (val);
53 }
54
55 /* xprint - built-in function 'print' */
xprint(void)56 LVAL xprint(void)
57 {
58 return (printit(TRUE,TRUE));
59 }
60
61 /* xprin1 - built-in function 'prin1' */
xprin1(void)62 LVAL xprin1(void)
63 {
64 return (printit(TRUE,FALSE));
65 }
66
67 /* xprinc - built-in function princ */
xprinc(void)68 LVAL xprinc(void)
69 {
70 return (printit(FALSE,FALSE));
71 }
72
73 /* xterpri - terminate the current print line */
xterpri(void)74 LVAL xterpri(void)
75 {
76 LVAL fptr;
77
78 /* get file pointer */
79 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
80 xllastarg();
81
82 /* terminate the print line and return nil */
83 xlterpri(fptr);
84 return (NIL);
85 }
86
87 /* printit - common print function */
printit(int pflag,int tflag)88 LOCAL LVAL printit(int pflag, int tflag)
89 {
90 LVAL fptr,val;
91
92 /* get expression to print and file pointer */
93 val = xlgetarg();
94 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
95 xllastarg();
96
97 /* print the value */
98 xlprint(fptr,val,pflag);
99
100 /* terminate the print line if necessary */
101 if (tflag)
102 xlterpri(fptr);
103
104 /* return the result */
105 return (val);
106 }
107
108 /* xflatsize - compute the size of a printed representation using prin1 */
xflatsize(void)109 LVAL xflatsize(void)
110 {
111 return (flatsize(TRUE));
112 }
113
114 /* xflatc - compute the size of a printed representation using princ */
xflatc(void)115 LVAL xflatc(void)
116 {
117 return (flatsize(FALSE));
118 }
119
120 /* flatsize - compute the size of a printed expression */
flatsize(int pflag)121 LOCAL LVAL flatsize(int pflag)
122 {
123 LVAL val;
124
125 /* get the expression */
126 val = xlgetarg();
127 xllastarg();
128
129 /* print the value to compute its size */
130 xlfsize = 0;
131 xlprint(NIL,val,pflag);
132
133 /* return the length of the expression */
134 return (cvfixnum((FIXTYPE)xlfsize));
135 }
136
137 /* xlopen - open a text or binary file */
xlopen(int binaryflag)138 LVAL xlopen(int binaryflag)
139 {
140 char *name,*mode=NULL;
141 FILE *fp;
142 LVAL dir;
143
144 /* get the file name and direction */
145 name = (char *)getstring(xlgetfname());
146 if (!xlgetkeyarg(k_direction,&dir))
147 dir = k_input;
148
149 /* get the mode */
150 if (dir == k_input)
151 mode = "r";
152 else if (dir == k_output)
153 mode = "w";
154 else
155 xlerror("bad direction",dir);
156
157 /* try to open the file */
158 if (binaryflag) {
159 fp = osbopen(name,mode);
160 } else {
161 fp = osaopen(name,mode);
162 }
163 return (fp ? cvfile(fp) : NIL);
164 }
165
166
167 /* xopen - open a file */
xopen(void)168 LVAL xopen(void)
169 {
170 return xlopen(FALSE);
171 }
172
173 /* xbopen - open a binary file */
xbopen(void)174 LVAL xbopen(void)
175 {
176 return xlopen(TRUE);
177 }
178
179 /* xclose - close a file */
xclose(void)180 LVAL xclose(void)
181 {
182 LVAL fptr;
183
184 /* get file pointer */
185 fptr = xlgastream();
186 xllastarg();
187
188 /* make sure the file exists */
189 if (getfile(fptr) == NULL)
190 xlfail("file not open");
191
192 /* close the file */
193 osclose(getfile(fptr));
194 setfile(fptr,NULL);
195
196 /* return nil */
197 return (NIL);
198 }
199
200 /* xrdchar - read a character from a file */
xrdchar(void)201 LVAL xrdchar(void)
202 {
203 LVAL fptr;
204 int ch;
205
206 /* get file pointer */
207 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
208 xllastarg();
209
210 /* get character and check for eof */
211 return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
212 }
213
214 /* xrdint - read an integer from a file */
215 /* positive byte count means big-endian, negative is little-endian */
xrdint(void)216 LVAL xrdint(void)
217 {
218 LVAL fptr;
219 unsigned char b[4];
220 long i;
221 int n = 4;
222 int index = 0; /* where to start in array */
223 int incr = 1; /* how to step through array */
224 int rslt;
225
226 /* get file pointer */
227 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
228 /* get byte count */
229 if (moreargs()) {
230 LVAL count = typearg(fixp);
231 n = (int) getfixnum(count);
232 if (n < 0) {
233 n = -n;
234 index = n - 1;
235 incr = -1;
236 }
237 if (n > 4) {
238 xlerror("4-byte limit", count);
239 }
240 }
241 xllastarg();
242 for (i = 0; i < n; i++) {
243 int ch = xlgetc(fptr);
244 if (ch == EOF)
245 return NIL;
246 b[index] = ch;
247 index += incr;
248 }
249 /* build result, b is now big-endian */
250 /* extend sign bit for short integers */
251 rslt = ((b[0] & 0x80) ? -1 : 0);
252 for (i = 0; i < n; i++) {
253 rslt = (rslt << 8) + b[i];
254 }
255 /* return integer result */
256 return cvfixnum(rslt);
257 }
258
259
260 /* xrdfloat - read a float from a file */
xrdfloat(void)261 LVAL xrdfloat(void)
262 {
263 LVAL fptr;
264 union {
265 char b[8];
266 float f;
267 double d;
268 } rslt;
269 int n = 4;
270 int i;
271 int index = 3; /* where to start in array */
272 int incr = -1; /* how to step through array */
273
274 /* get file pointer */
275 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
276 /* get byte count */
277 if (moreargs()) {
278 LVAL count = typearg(fixp);
279 n = (int) getfixnum(count);
280 if (n < 0) {
281 n = -n;
282 index = 0;
283 incr = 1;
284 }
285 if (n != 4 && n != 8) {
286 xlerror("must be 4 or 8 bytes", count);
287 }
288 }
289 xllastarg();
290
291 #ifdef XL_BIG_ENDIAN
292 /* flip the bytes */
293 index = n - 1 - index;
294 incr = -incr;
295 #endif
296 for (i = 0; i < n; i++) {
297 int ch = xlgetc(fptr);
298 if (ch == EOF) return NIL;
299 rslt.b[index] = ch;
300 index += incr;
301 }
302 /* return result */
303 return cvflonum(n == 4 ? rslt.f : rslt.d);
304 }
305
306
307 /* xrdbyte - read a byte from a file */
xrdbyte(void)308 LVAL xrdbyte(void)
309 {
310 LVAL fptr;
311 int ch;
312
313 /* get file pointer */
314 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
315 xllastarg();
316
317 /* get character and check for eof */
318 return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
319 }
320
321 /* xpkchar - peek at a character from a file */
xpkchar(void)322 LVAL xpkchar(void)
323 {
324 LVAL flag,fptr;
325 int ch;
326
327 /* peek flag and get file pointer */
328 flag = (moreargs() ? xlgetarg() : NIL);
329 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
330 xllastarg();
331
332 /* skip leading white space and get a character */
333 if (flag)
334 while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
335 xlgetc(fptr);
336 else
337 ch = xlpeek(fptr);
338
339 /* return the character */
340 return (ch == EOF ? NIL : cvchar(ch));
341 }
342
343 /* xwrchar - write a character to a file */
xwrchar(void)344 LVAL xwrchar(void)
345 {
346 LVAL fptr,chr;
347
348 /* get the character and file pointer */
349 chr = xlgachar();
350 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
351 xllastarg();
352
353 /* put character to the file */
354 xlputc(fptr,getchcode(chr));
355
356 /* return the character */
357 return (chr);
358 }
359
360 /* xwrbyte - write a byte to a file */
xwrbyte(void)361 LVAL xwrbyte(void)
362 {
363 LVAL fptr,chr;
364
365 /* get the byte and file pointer */
366 chr = xlgafixnum();
367 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
368 xllastarg();
369
370 /* put byte to the file */
371 xlputc(fptr,(int)getfixnum(chr));
372
373 /* return the character */
374 return (chr);
375 }
376
377 /* xwrint - write an integer to a file */
378 /* positive count means write big-endian */
xwrint(void)379 LVAL xwrint(void)
380 {
381 LVAL val, fptr;
382 unsigned char b[4];
383 long i;
384 int n = 4;
385 int index = 3; /* where to start in array */
386 int incr = -1; /* how to step through array */
387 int v; /* xwrint only allows up to 4 bytes, so int is enough */
388 /* get the int and file pointer and optional byte count */
389 val = xlgafixnum();
390 v = (int) getfixnum(val);
391 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
392 if (moreargs()) {
393 LVAL count = typearg(fixp);
394 n = (int) getfixnum(count);
395 index = n - 1;
396 if (n < 0) {
397 n = -n;
398 index = 0;
399 incr = 1;
400 }
401 if (n > 4) {
402 xlerror("4-byte limit", count);
403 }
404 }
405 xllastarg();
406 /* build output b as little-endian */
407 for (i = 0; i < n; i++) {
408 b[i] = (unsigned char) v;
409 v = v >> 8;
410 }
411
412 /* put bytes to the file */
413 while (n) {
414 n--;
415 xlputc(fptr, b[index]);
416 index += incr;
417 }
418
419 /* return the integer */
420 return val;
421 }
422
423 /* xwrfloat - write a float to a file */
xwrfloat(void)424 LVAL xwrfloat(void)
425 {
426 LVAL val, fptr;
427 union {
428 char b[8];
429 float f;
430 double d;
431 } v;
432 int n = 4;
433 int i;
434 int index = 3; /* where to start in array */
435 int incr = -1; /* how to step through array */
436
437 /* get the float and file pointer and optional byte count */
438 val = xlgaflonum();
439 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
440 if (moreargs()) {
441 LVAL count = typearg(fixp);
442 n = (int) getfixnum(count);
443 if (n < 0) {
444 n = -n;
445 index = 0;
446 incr = 1;
447 }
448 if (n != 4 && n != 8) {
449 xlerror("must be 4 or 8 bytes", count);
450 }
451 }
452 xllastarg();
453
454 #ifdef XL_BIG_ENDIAN
455 /* flip the bytes */
456 index = n - 1 - index;
457 incr = -incr;
458 #endif
459 /* build output v.b */
460 if (n == 4) v.f = (float) getflonum(val);
461 else v.d = getflonum(val);
462
463 /* put bytes to the file */
464 for (i = 0; i < n; i++) {
465 xlputc(fptr, v.b[index]);
466 index += incr;
467 }
468
469 /* return the flonum */
470 return val;
471 }
472
473 /* xreadline - read a line from a file */
xreadline(void)474 LVAL xreadline(void)
475 {
476 unsigned char buf[STRMAX+1],*p,*sptr;
477 LVAL fptr,str,newstr;
478 int len,blen,ch;
479
480 /* protect some pointers */
481 xlsave1(str);
482
483 /* get file pointer */
484 fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
485 xllastarg();
486
487 /* get character and check for eof */
488 len = blen = 0; p = buf;
489 while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
490
491 /* check for buffer overflow */
492 if (blen >= STRMAX) {
493 newstr = new_string(len + STRMAX + 1);
494 sptr = getstring(newstr); *sptr = '\0';
495 if (str) strcat((char *) sptr, (char *) getstring(str));
496 *p = '\0'; strcat((char *) sptr, (char *) buf);
497 p = buf; blen = 0;
498 len += STRMAX;
499 str = newstr;
500 }
501
502 /* store the character */
503 *p++ = ch; ++blen;
504 }
505
506 /* check for end of file */
507 if (len == 0 && p == buf && ch == EOF) {
508 xlpop();
509 return (NIL);
510 }
511
512 /* append the last substring */
513 if (str == NIL || blen) {
514 newstr = new_string(len + blen + 1);
515 sptr = getstring(newstr); *sptr = '\0';
516 if (str) strcat((char *) sptr, (char *) getstring(str));
517 *p = '\0'; strcat((char *) sptr, (char *) buf);
518 str = newstr;
519 }
520
521 /* restore the stack */
522 xlpop();
523
524 /* return the string */
525 return (str);
526 }
527
528
529 /* xmkstrinput - make a string input stream */
xmkstrinput(void)530 LVAL xmkstrinput(void)
531 {
532 int start,end,len,i;
533 unsigned char *str;
534 LVAL string,val;
535
536 /* protect the return value */
537 xlsave1(val);
538
539 /* get the string and length */
540 string = xlgastring();
541 str = getstring(string);
542 len = getslength(string) - 1;
543
544 /* get the starting offset */
545 if (moreargs()) {
546 val = xlgafixnum();
547 start = (int)getfixnum(val);
548 }
549 else start = 0;
550
551 /* get the ending offset */
552 if (moreargs()) {
553 val = xlgafixnum();
554 end = (int)getfixnum(val);
555 }
556 else end = len;
557 xllastarg();
558
559 /* check the bounds */
560 if (start < 0 || start > len)
561 xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
562 if (end < 0 || end > len)
563 xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
564
565 /* make the stream */
566 val = newustream();
567
568 /* copy the substring into the stream */
569 for (i = start; i < end; ++i)
570 xlputc(val,str[i]);
571
572 /* restore the stack */
573 xlpop();
574
575 /* return the new stream */
576 return (val);
577 }
578
579 /* xmkstroutput - make a string output stream */
xmkstroutput(void)580 LVAL xmkstroutput(void)
581 {
582 return (newustream());
583 }
584
585 /* xgetstroutput - get output stream string */
xgetstroutput(void)586 LVAL xgetstroutput(void)
587 {
588 LVAL stream;
589 stream = xlgaustream();
590 xllastarg();
591 return (getstroutput(stream));
592 }
593
594 /* xgetlstoutput - get output stream list */
xgetlstoutput(void)595 LVAL xgetlstoutput(void)
596 {
597 LVAL stream,val;
598
599 /* get the stream */
600 stream = xlgaustream();
601 xllastarg();
602
603 /* get the output character list */
604 val = gethead(stream);
605
606 /* empty the character list */
607 sethead(stream,NIL);
608 settail(stream,NIL);
609
610 /* return the list */
611 return (val);
612 }
613
614 /* xformat - formatted output function */
xformat(void)615 LVAL xformat(void)
616 {
617 unsigned char *fmt;
618 LVAL stream,val;
619 int ch;
620
621 /* protect stream in case it is a new ustream */
622 xlsave1(stream);
623
624 /* get the stream and format string */
625 stream = xlgetarg();
626 if (stream == NIL)
627 val = stream = newustream();
628 else {
629 if (stream == s_true)
630 stream = getvalue(s_stdout);
631 else if (!streamp(stream) && !ustreamp(stream))
632 xlbadtype(stream);
633 val = NIL;
634 }
635 fmt = getstring(xlgastring());
636
637 /* process the format string */
638 while ((ch = *fmt++))
639 if (ch == '~') {
640 switch (*fmt++) {
641 case '\0':
642 xlerror("expecting a format directive",cvstring((char *) (fmt-1)));
643 case 'a': case 'A':
644 xlprint(stream,xlgetarg(),FALSE);
645 break;
646 case 's': case 'S':
647 xlprint(stream,xlgetarg(),TRUE);
648 break;
649 case '%':
650 xlterpri(stream);
651 break;
652 case '~':
653 xlputc(stream,'~');
654 break;
655 case '\n':
656 case '\r':
657 /* mac may read \r -- this should be ignored */
658 if (*fmt == '\r') fmt++;
659 while (*fmt && *fmt != '\n' && isspace(*fmt))
660 ++fmt;
661 break;
662 default:
663 xlerror("unknown format directive",cvstring((char *) (fmt-1)));
664 }
665 }
666 else
667 xlputc(stream,ch);
668
669 /* return the value */
670 if (val) val = getstroutput(val);
671 xlpop();
672 return val;
673 }
674
675 /* getstroutput - get the output stream string (internal) */
getstroutput(LVAL stream)676 LOCAL LVAL getstroutput(LVAL stream)
677 {
678 unsigned char *str;
679 LVAL next,val;
680 int len,ch;
681
682 /* compute the length of the stream */
683 for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
684 ++len;
685
686 /* create a new string */
687 val = new_string(len + 1);
688
689 /* copy the characters into the new string */
690 str = getstring(val);
691 while ((ch = xlgetc(stream)) != EOF)
692 *str++ = ch;
693 *str = '\0';
694
695 /* return the string */
696 return (val);
697 }
698
699
xlistdir(void)700 LVAL xlistdir(void)
701 {
702 const char *path;
703 LVAL result = NULL;
704 LVAL *tail;
705 /* get the path, converting unsigned char * to char * */
706 path = (char *)getstring(xlgetfname());
707 /* try to start listing */
708 if (osdir_list_start(path)) {
709 const char *filename;
710 xlsave1(result);
711 tail = &result;
712 while ((filename = osdir_list_next())) {
713 *tail = cons(NIL, NIL);
714 rplaca(*tail, cvstring(filename));
715 tail = &cdr(*tail);
716 }
717 osdir_list_finish();
718 xlpop();
719 }
720 return result;
721 }
722
723
724 /* xbigendianp -- is this a big-endian machine? T or NIL */
xbigendianp()725 LVAL xbigendianp()
726 {
727 #ifdef XL_BIG_ENDIAN
728 return s_true;
729 #else
730 return NIL;
731 #endif
732 }
733
734
735