1 /* -*- tab-width:4; -*-
2 * File and string ports
3 *
4 * $Id: port.c 1.35 Wed, 19 Apr 2000 22:43:15 +0200 crad $
5 *
6 */
7
8 #include "s.h"
9 #include "vm2.h"
10 #include "heap.h"
11 #include <unistd.h>
12
13 /************************************************************************
14 * Variables
15 ************************************************************************/
16 static PORT *scm_inp, *scm_outp, *scm_errp;
17
18 SOBJ scm_in_port;
19 SOBJ scm_out_port;
20 SOBJ scm_err_port;
21 SOBJ scm_eof;
22
23 static int scm_float_digits = 10;
24
25 #define SCM_INP SCM_PORT(scm_in_port)
26 #define SCM_OUTP SCM_PORT(scm_out_port)
27 #define SCM_ERRP SCM_PORT(scm_err_port)
28
29 /************************************************************************
30 * Common port routines
31 ************************************************************************/
32
port_new(int type,int flag)33 static PORT *port_new(int type, int flag)
34 {
35 PORT *p = scm_must_alloc(sizeof(PORT));
36 scm_mem_clear(p, sizeof(PORT));
37 p->type = type;
38 p->io_flag = flag;
39 return(p);
40 }
41
42
43 /************************************************************************
44 * File ports
45 ************************************************************************/
46
port_file_getc(PORT * p)47 static int port_file_getc(PORT *p)
48 {
49 int c;
50 if ((c = getc(p->descr.f)) == EOF) return(PORT_EOF);
51 if (c == '\n') p->line++;
52 return(c);
53 }
54
port_file_peekc(PORT * p)55 static int port_file_peekc(PORT *p)
56 {
57 int c;
58 if ((c = getc(p->descr.f)) == EOF) return(PORT_EOF);
59 ungetc(c, p->descr.f);
60 return(c);
61 }
62
port_file_putc(PORT * p,char c)63 static void port_file_putc(PORT *p, char c)
64 {
65 putc(c, p->descr.f);
66 if (c == '\n') p->line++;
67 }
68
port_file_close(PORT * p)69 static void port_file_close(PORT *p)
70 {
71 if (p->descr.f) fclose(p->descr.f);
72 scm_free(p);
73 }
74
port_file_seek(PORT * p,int pos)75 static void port_file_seek(PORT *p, int pos)
76 {
77 fseek(p->descr.f, pos, 0);
78 }
79
port_file_read(PORT * p,SOBJ str,int len)80 static int port_file_read(PORT *p, SOBJ str, int len)
81 {
82 scm_str_resize(str, len);
83 return(fread(SCM_STR_VALUE(str), 1, len, p->descr.f));
84 }
85
port_file_write(PORT * p,SOBJ str,int len)86 static int port_file_write(PORT *p, SOBJ str, int len)
87 {
88 if (len > SCM_STR_LEN(str)) SCM_ERR("string not long enough", str);
89 return(fwrite(SCM_STR_VALUE(str), 1, len, p->descr.f));
90 }
91
92 #define QTUM 128
93
port_file_getline(PORT * p,SOBJ str)94 static int port_file_getline(PORT *p, SOBJ str)
95 {
96 int r;
97 char *buf = NULL;
98 int len = 0;
99
100 r = getline(&buf, &len, p->descr.f);
101 if (r < 0) {
102 if (buf) free(buf);
103 } else {
104 /* strip newline */
105 if (r > 0 && buf[r-1] == '\n') buf[--r] = 0;
106 scm_malloc_allocated++; /* keep correct alloc count */
107 if (scm_str_lenq(r) <= len) {
108 scm_free(SCM_STR_VALUE(str));
109 SCM_STR_VALUE(str) = buf;
110 } else {
111 SCM_STR_VALUE(str) = scm_must_realloc(buf, scm_str_lenq(r));
112 }
113 SCM_STR_LEN(str) = r;
114 }
115 return(r);
116 }
117
port_file_putline(PORT * p,SOBJ str)118 static int port_file_putline(PORT *p, SOBJ str)
119 {
120 int len = fwrite(SCM_STR_VALUE(str), 1, SCM_STR_LEN(str), p->descr.f);
121 if (len >= 0) {
122 putc('\n', p->descr.f);
123 len++;
124 }
125 return(len);
126 }
127
port_file_open(void * filename,int mode)128 static PORT *port_file_open(void *filename, int mode)
129 {
130 PORT *port;
131 FILE *fd;
132 int eflag, io;
133
134 eflag = 0;
135 switch(mode) {
136 case PORT_READ: fd = fopen(filename, "r"); io = PORT_IO_R; break;
137 case PORT_CREATE: fd = fopen(filename, "w"); io = PORT_IO_W; break;
138 case PORT_APPEND: fd = fopen(filename, "a"); io = PORT_IO_W; break;
139 case PORT_UPDATE: fd = fopen(filename, "r+"); io = PORT_IO_RW; break;
140 case PORT_UPDATE_CREATE: fd = fopen(filename, "w+"); io = PORT_IO_RW; break;
141 case PORT_UPDATE_APPEND: fd = fopen(filename, "a+"); io = PORT_IO_RW; break;
142 default:
143 return(NULL);
144 }
145 if (fd) {
146 port = port_new(PORT_T_FILE, io);
147 port->open_mode = mode;
148 port->io_flag = io;
149 port->descr.f = fd;
150 return(port);
151 }
152 return(NULL);
153 }
154
155
156 /************************************************************************
157 * string ports
158 ************************************************************************/
159
port_string_getc(PORT * p)160 static int port_string_getc(PORT *p)
161 {
162 if (p->descr.s.index >= p->descr.s.length) return(PORT_EOF);
163 return(p->descr.s.data[p->descr.s.index++]);
164 }
165
port_string_peekc(PORT * p)166 static int port_string_peekc(PORT *p)
167 {
168 if (p->descr.s.index >= p->descr.s.length) return(PORT_EOF);
169 return(p->descr.s.data[p->descr.s.index]);
170 }
171
port_string_putc(PORT * p,char c)172 static void port_string_putc(PORT *p, char c)
173 {
174 if (p->descr.s.index >= (p->descr.s.alloced-1)) {
175 if (p->descr.s.data != NULL) {
176 p->descr.s.data = scm_must_realloc(p->descr.s.data,
177 p->descr.s.alloced + PORT_STR_QTUM);
178 p->descr.s.alloced += PORT_STR_QTUM;
179 } else {
180 p->descr.s.data = scm_must_alloc(PORT_STR_QTUM);
181 p->descr.s.alloced = PORT_STR_QTUM;
182 }
183 }
184 p->descr.s.data[p->descr.s.index++] = c;
185 p->descr.s.length = p->descr.s.index;
186 p->descr.s.data[p->descr.s.index] = 0;
187 }
188
port_string_output_string(PORT * p)189 char *port_string_output_string(PORT *p)
190 {
191 return(p->descr.s.data);
192 }
193
port_string_close(PORT * p)194 static void port_string_close(PORT *p)
195 {
196 if (p->descr.s.data) scm_free(p->descr.s.data);
197 scm_free(p);
198 }
199
port_string_seek(PORT * p,int pos)200 static void port_string_seek(PORT *p, int pos)
201 {
202 if (pos >= p->descr.s.length) return;
203 p->descr.s.index = pos;
204 }
205
port_string_read(PORT * p,SOBJ str,int len)206 static int port_string_read(PORT *p, SOBJ str, int len)
207 {
208 char *s, *l, *d, *dl;
209
210 s = p->descr.s.data + p->descr.s.index;
211 l = p->descr.s.data + p->descr.s.length;
212 if (s >= l) return(-1);
213
214 scm_str_resize(str, len);
215 d = SCM_STR_VALUE(str);
216 dl= d + len;
217 while(s < l && d < dl) {
218 *d++ = *s++;
219 }
220 *d = 0;
221 return(d - SCM_STR_VALUE(str));
222 }
223
port_string_write(PORT * p,SOBJ str,int len)224 static int port_string_write(PORT *p, SOBJ str, int len)
225 {
226 if (len > SCM_STR_LEN(str))
227 SCM_ERR("string not long enough", str);
228
229 if ((p->descr.s.index + len) >= (p->descr.s.alloced - 1)) {
230 if (p->descr.s.data != NULL) {
231 p->descr.s.data =
232 scm_must_realloc(p->descr.s.data,
233 p->descr.s.alloced + len + PORT_STR_QTUM);
234 p->descr.s.alloced += len + PORT_STR_QTUM;
235 } else {
236 p->descr.s.data =
237 scm_must_alloc(len + PORT_STR_QTUM);
238 p->descr.s.alloced += len + PORT_STR_QTUM;
239 }
240 }
241 memcpy(p->descr.s.data + p->descr.s.index, SCM_STR_VALUE(str), len);
242 p->descr.s.index += len;
243 return(len);
244 }
245
port_string_getline(PORT * p,SOBJ str)246 static int port_string_getline(PORT *p, SOBJ str)
247 {
248 int c, len;
249 char *start, *s, *l, *d;
250
251 start = p->descr.s.data + p->descr.s.index;
252 l = p->descr.s.data + p->descr.s.length;
253 if (start >= l) return(-1);
254
255 s = start; len = 0;
256 while(s < l) {
257 c = *s++;
258 if (c == '\r') continue;
259 if (c == '\n') break;
260 len++;
261 }
262 scm_str_resize(str, len);
263 l = s;
264 s = start;
265 d = SCM_STR_VALUE(str);
266 while(s < l) {
267 c = *s++;
268 if (c == '\r') continue;
269 if (c == '\n') break;
270 *d++ = c;
271 }
272 *d = 0;
273 return(len);
274 }
275
port_string_putline(PORT * p,SOBJ str)276 static int port_string_putline(PORT *p, SOBJ str)
277 {
278 int len = port_string_write(p, str, SCM_STR_LEN(str));
279 if (len >= 0) {
280 port_string_putc(p, '\n');
281 len++;
282 }
283 return(len);
284 }
285
port_string_open(void * p,int flag)286 static PORT *port_string_open(void *p, int flag)
287 {
288 PORT *port = port_new(PORT_T_STRING, 0);
289
290 switch(flag) {
291 case PORT_CREATE:
292 port->io_flag = PORT_IO_W;
293 break;
294 case PORT_UPDATE:
295 case PORT_UPDATE_CREATE:
296 case PORT_UPDATE_APPEND:
297 port->io_flag = PORT_IO_RW;
298 break;
299 case PORT_READ:
300 port->descr.s.data = scm_must_strdup(p);
301 port->descr.s.length = strlen(p);
302 port->descr.s.index = 0;
303 port->descr.s.alloced = port->descr.s.length+1;
304 port->io_flag = PORT_IO_R;
305 break;
306 case PORT_APPEND:
307 port->descr.s.data = scm_must_strdup(p);
308 port->descr.s.length = strlen(p);
309 port->descr.s.index = port->descr.s.length;
310 port->descr.s.alloced = port->descr.s.length+1;
311 port->io_flag = PORT_IO_W;
312 break;
313 }
314 return(port);
315 }
316
317 /************************************************************************
318 * Port table driver
319 ************************************************************************/
320
321 PORT_DESCR port_driver[PORT_MAX_TYPES] =
322 {
323 { "file",
324 port_file_close,
325 port_file_getc, port_file_peekc, port_file_putc,
326 port_file_seek,
327 port_file_read, port_file_write,
328 port_file_getline, port_file_putline
329 },
330
331 { "string",
332 port_string_close,
333 port_string_getc, port_string_peekc, port_string_putc,
334 port_string_seek,
335 port_string_read, port_string_write,
336 port_string_getline, port_string_putline
337 }
338 };
339
340
341 /************************************************************************
342 * Public interface
343 ************************************************************************/
344
port_close(PORT * p)345 void port_close(PORT *p)
346 {
347 (*port_driver[p->type].close)(p);
348 }
349
port_getc(PORT * p)350 int port_getc(PORT *p)
351 {
352 return( (*port_driver[p->type].getc)(p) );
353 }
354
port_peekc(PORT * p)355 int port_peekc(PORT *p)
356 {
357 return( (*port_driver[p->type].peekc)(p) );
358 }
359
port_putc(PORT * p,char c)360 void port_putc(PORT *p, char c)
361 {
362 (*port_driver[p->type].putc)(p, c);
363 }
364
port_seek(PORT * p,int pos)365 void port_seek(PORT *p, int pos)
366 {
367 (*port_driver[p->type].seek)(p, pos);
368 }
369
port_read(PORT * p,SOBJ str,int len)370 int port_read(PORT *p, SOBJ str, int len)
371 {
372 return (*port_driver[p->type].read)(p, str, len);
373 }
374
port_write(PORT * p,SOBJ str,int len)375 int port_write(PORT *p, SOBJ str, int len)
376 {
377 return (*port_driver[p->type].write)(p, str, len);
378 }
379
port_getline(PORT * p,SOBJ str)380 int port_getline(PORT *p, SOBJ str)
381 {
382 return (*port_driver[p->type].getline)(p, str);
383 }
384
port_putline(PORT * p,SOBJ str)385 int port_putline(PORT *p, SOBJ str)
386 {
387 return (*port_driver[p->type].putline)(p, str);
388 }
389
390 /*-- high level interface */
port_open_input_file(char * fname)391 PORT *port_open_input_file(char *fname)
392 {
393 return(port_file_open(fname, PORT_READ));
394 }
395
port_open_output_file(char * fname)396 PORT *port_open_output_file(char *fname)
397 {
398 return(port_file_open(fname, PORT_CREATE));
399 }
400
port_open_input_string(char * string)401 PORT *port_open_input_string(char *string)
402 {
403 return(port_string_open(string, PORT_READ));
404 }
405
port_open_output_string()406 PORT *port_open_output_string()
407 {
408 return(port_string_open(NULL, PORT_CREATE));
409 }
410
port_puts(PORT * p,char * str)411 void port_puts(PORT *p, char *str)
412 {
413 SOBJ s = scm_mkstring(str);
414 port_write(p, s, SCM_STR_LEN(s));
415 scm_freecell(s);
416 }
417
port_putn(PORT * p,long n)418 void port_putn(PORT *p, long n)
419 {
420 char buf[32];
421 sprintf(buf, "%ld", n);
422 port_puts(p, buf);
423 }
424
port_putx(PORT * p,void * ptr)425 void port_putx(PORT *p, void *ptr)
426 {
427 char buf[32];
428 sprintf(buf, "%p", ptr);
429 port_puts(p, buf);
430 }
431
port_putd(PORT * p,double n)432 void port_putd(PORT *p, double n)
433 {
434 char buf[128];
435 sprintf(buf, "%.*g", (scm_float_digits >= 16) ? 16: scm_float_digits, n);
436 port_puts(p, buf);
437 }
438
439 /************************************************************************
440 * Type related functions
441 ************************************************************************/
scm_mkport(PORT * port)442 SOBJ scm_mkport(PORT *port)
443 {
444 SOBJ new = scm_newcell(SOBJ_T_PORT);
445 SCM_PORT(new) = port;
446 return(new);
447 }
448
449 /*** make a new port using file number */
scm_mk_fn_port(int fn,int is_read)450 SOBJ scm_mk_fn_port(int fn, int is_read)
451 {
452 PORT *port;
453 if (is_read) {
454 port = port_new(PORT_T_FILE, PORT_READ);
455 port->descr.f = fdopen(fn, "r");
456 } else {
457 port = port_new(PORT_T_FILE, PORT_CREATE);
458 port->descr.f = fdopen(fn, "w");
459 }
460 return(scm_mkport(port));
461 }
462
463
scm_port_sweep(SOBJ port)464 void scm_port_sweep(SOBJ port)
465 {
466 /* scm_puts("; gc: sweep port: "); scm_cprint(port); */
467 if (SCM_PORT(port) != NULL) port_close(SCM_PORT(port));
468 }
469
scm_port_print(SOBJ port,PORT * p)470 void scm_port_print(SOBJ port, PORT *p)
471 {
472 port_puts(p, "#<port ");
473 if (SCM_PORT(port)) {
474 port_putx(p, SCM_PORT(port));
475 } else {
476 port_puts(p, "nil");
477 }
478 port_putc(p, '>');
479 }
480
scm_eof_print(SOBJ port,PORT * p)481 void scm_eof_print(SOBJ port, PORT *p)
482 {
483 port_puts(p, "#eof");
484 }
485
scm_eof_write(SOBJ port,PORT * p)486 void scm_eof_write(SOBJ port, PORT *p)
487 {
488 port_puts(p, "#eof");
489 }
490
491 /************************************************************************
492 * scheme functions
493 ************************************************************************/
494
scm_write_obj(SOBJ obj,PORT * port,int raw)495 void scm_write_obj(SOBJ obj, PORT *port, int raw)
496 {
497 SOBJ p;
498 int otype;
499
500 if (port == NULL) port = SCM_OUTP;
501
502 if (obj == NULL) { port_puts(port, "()"); return; }
503 if (SCM_INUMP(obj)) { port_putn(port, SCM_INUM(obj)); return; }
504
505 if (scm_is_opcode_address(obj)) {
506 port_puts(port, "#<vm-opcode ");
507 port_puts(port, scm_search_opcode_name(obj));
508 port_putc(port, '>');
509 return;
510 }
511 if (obj >= (SOBJ)scm_stack && obj <= (SOBJ)scm_stack_limit) {
512 port_puts(port, "#<sref "); port_putx(port, obj); port_putc(port, '>');
513 return;
514 }
515 if (!scm_is_pointer_to_heap(obj) && !scm_is_pointer_to_chr_array(obj)) {
516 port_puts(port, "#<ptr "); port_putx(port, obj); port_putc(port, '>');
517 return;
518 }
519
520 /* should never occur */
521 if (obj->type & SCM_GCMARK_MASK) {
522 fprintf(stderr, "scm_write_obj: cell at %p is gc-marked\n",obj);
523 return;
524 }
525
526 otype = obj->type & ~(SCM_GCMARK_MASK);
527 switch(otype) {
528 case SOBJ_T_VOID: port_puts(port, "#void"); break;
529 case SOBJ_T_FNUM: port_putd(port, SCM_FNUM(obj)); break;
530 case SOBJ_T_BNUM:
531 {
532 char *s = mpz_get_str(NULL, 10, SCM_BNUM(obj));
533 port_puts(port, s);
534 scm_free(s);
535 break;
536 }
537 case SOBJ_T_KEYWORD:
538 port_puts(port, scm_keyword_write_prefix);
539 port_puts(port, SCM_ATOM_NAME(SCM_KEYW_NAME(obj)));
540 port_puts(port, scm_keyword_write_suffix);
541 break;
542
543 case SOBJ_T_SYMBOL:
544 port_puts(port, "#<symbol ");
545 port_puts(port, SCM_ATOM_NAME(SCM_SYM_NAME(obj)));
546 port_putc(port, '>');
547 break;
548
549 case SOBJ_T_LSYMBOL:
550 port_puts(port, "#<lsym ");
551 port_puts(port, SCM_ATOM_NAME(SCM_LSYM_NAME(obj)));
552 port_putc(port, ' ');
553 port_putn(port, SCM_LSYM_OFS(obj));
554 port_putc(port, '>');
555 break;
556
557 case SOBJ_T_PAIR:
558 port_putc(port, '(');
559 for (p = obj; p; p = SCM_CDR(p)) {
560 if (p != obj) port_putc(port, ' ');
561 if (SCM_OBJTYPE(p) != SOBJ_T_PAIR) {
562 if (SCM_OBJREF(p) != SCM_OBJREF(obj)) port_puts(port, ". ");
563 scm_write_obj(p, port, raw);
564 break;
565 }
566 scm_write_obj(SCM_CAR(p), port, raw);
567 }
568 port_putc(port, ')');
569 break;
570 case SOBJ_T_PRIM:
571 port_puts(port, "#<prim "); port_puts(port, SCM_PRIM(obj)->name);
572 port_putc(port, ' '); port_putn(port, SCM_PRIM(obj)->nargs);
573 port_putc(port, '>');
574 break;
575
576 case SOBJ_T_CPRIM:
577 port_puts(port, "#<cprim "); port_putx(port, SCM_CPRIM_FUNC(obj));
578 port_putc(port, ' '); port_putn(port, SCM_CPRIM_NARGS(obj));
579 port_putc(port, '>');
580 break;
581
582 case SOBJ_T_BOOLEAN:
583 port_puts(port, (obj == scm_false) ? "#f" : "#t");
584 break;
585 case SOBJ_T_UNBOUND: port_puts(port, "#unbound"); break;
586 case SOBJ_T_UNDEFINED: port_puts(port, "#undefined"); break;
587 case SOBJ_T_FREE: port_puts(port, "#<free>"); break;
588 default:
589 if (otype < SOBJ_T_MAX) {
590 if (!raw && scm_type_hook[otype].write != NULL) {
591 (*scm_type_hook[otype].write)(obj, port);
592 return;
593 }
594 if (scm_type_hook[otype].print != NULL) {
595 (*scm_type_hook[otype].print)(obj, port);
596 return;
597 }
598 }
599 scm_puts("#<"); scm_puts(scm_type_hook[otype].name);
600 scm_puts(" "); scm_putx(obj);
601 scm_puts(">");
602 #ifdef COMMENT
603 port_puts(SCM_ERRP, "scm_write_obj: object type ");
604 port_putn(SCM_ERRP, otype);
605 port_puts(SCM_ERRP, " not reconized\n");
606 #endif
607 }
608 }
609
610 /* get PORT from SCM_PORT : signal error if port is not a valid port*/
get_port(SOBJ port)611 static PORT *get_port(SOBJ port)
612 {
613 if (port == NULL) return(SCM_OUTP);
614 if (!SCM_PORTP(port)) SCM_ERR("bad port", port);
615 return(SCM_PORT(port));
616 }
617
scm_display2(SOBJ obj,SOBJ port)618 SOBJ scm_display2(SOBJ obj, SOBJ port)
619 {
620 scm_write_obj(obj, get_port(port), 1);
621 return(scm_undefined);
622 }
623
scm_write2(SOBJ obj,SOBJ port)624 SOBJ scm_write2(SOBJ obj, SOBJ port)
625 {
626 scm_write_obj(obj, get_port(port), 0);
627 return(scm_undefined);
628 }
629
scm_newline1(SOBJ port)630 SOBJ scm_newline1(SOBJ port)
631 {
632 port_putc(get_port(port), '\n');
633 return(scm_undefined);
634 }
635
scm_print2(SOBJ obj,SOBJ port)636 SOBJ scm_print2(SOBJ obj, SOBJ port)
637 {
638 PORT *p = get_port(port);
639 scm_write_obj(obj, p, 1); port_putc(p, '\n');
640 return(scm_undefined);
641 }
642
643 /*-- output to current-output port */
scm_putc(int c)644 SOBJ scm_putc(int c)
645 {
646 port_putc(SCM_OUTP, c); return(NULL);
647 }
648
scm_puts(char * s)649 SOBJ scm_puts(char *s)
650 {
651 port_puts(SCM_OUTP, s); return(NULL);
652 }
653
scm_putn(int n)654 SOBJ scm_putn(int n)
655 {
656 port_putn(SCM_OUTP, n); return(NULL);
657 }
658
scm_putx(void * ptr)659 SOBJ scm_putx(void *ptr)
660 {
661 port_putx(SCM_OUTP, ptr); return(NULL);
662 }
663
scm_cdisplay(SOBJ obj)664 SOBJ scm_cdisplay(SOBJ obj)
665 {
666 return(scm_display2(obj, NULL));
667 }
668
scm_cwrite(SOBJ obj)669 SOBJ scm_cwrite(SOBJ obj)
670 {
671 return(scm_write2(obj, NULL));
672 }
673
scm_cprint(SOBJ obj)674 SOBJ scm_cprint(SOBJ obj)
675 {
676 return(scm_print2(obj, NULL));
677 }
678
679 /*E* (port? OBJ) => BOOLEAN */
680 /*D* Returns #t if OBJ is a port, #f otherwise. */
scm_portp(SOBJ x)681 SOBJ scm_portp(SOBJ x)
682 {
683 return(SCM_MKBOOL(SCM_PORTP(x)));
684 }
685
686 /*S* (input-port? OBJ) => BOOLEAN */
687 /*D* Returns #t if OBJ is a port and is a readable port, #f
688 otherwise. */
scm_input_portp(SOBJ x)689 SOBJ scm_input_portp(SOBJ x)
690 {
691 return(SCM_MKBOOL( (SCM_PORTP(x) &&
692 SCM_PORT(x) &&
693 (SCM_PORT(x)->io_flag & PORT_IO_R)) ));
694 }
695
696 /*S* (output-port? OBJ) => BOOLEAN */
697 /*D* Returns #t if OBJ is a port and is a writeable port, #f
698 otherwise. */
scm_output_portp(SOBJ x)699 SOBJ scm_output_portp(SOBJ x)
700 {
701 return(SCM_MKBOOL( (SCM_PORTP(x) &&
702 SCM_PORT(x) &&
703 (SCM_PORT(x)->io_flag & PORT_IO_W)) ));
704 }
705
706 /*S* (current-input-port) => PORT */
707 /*D* Returns the current input port. */
scm_current_input_port()708 SOBJ scm_current_input_port()
709 {
710 return(scm_in_port);
711 }
712
713 /*S* (current-output-port) => PORT */
714 /*D* Returns the current output port. */
scm_current_output_port()715 SOBJ scm_current_output_port()
716 {
717 return(scm_out_port);
718 }
719
720 /*E* (current-error-port) => PORT */
721 /*D* Returns the current error port. */
scm_current_error_port()722 SOBJ scm_current_error_port()
723 {
724 return(scm_err_port);
725 }
726
727 /*** Redirector for input and output */
728
scm_port_redirect(SOBJ * old_port,SOBJ (* open)(),int open_nargs,SOBJ (* close)(SOBJ),int ret_close,char * errmsg,SOBJ filename,SOBJ thunk)729 static SOBJ scm_port_redirect(SOBJ *old_port,
730 SOBJ (*open)(), int open_nargs,
731 SOBJ (*close)(SOBJ), int ret_close,
732 char *errmsg, SOBJ filename, SOBJ thunk)
733 {
734 SOBJ port_save;
735 SOBJ rval = NULL;
736 jmp_buf handler_save;
737 char errbuf[128];
738 int k;
739
740 if (open_nargs > 0 && !SCM_STRINGP(filename)) {
741 sprintf(errbuf, "%s: bad filename", errmsg);
742 SCM_ERR(errbuf, filename);
743 }
744 port_save = *old_port;
745 *old_port = (*open)(filename);
746 memcpy(handler_save, scm_errjmp, sizeof(jmp_buf));
747 if ((k = setjmp(scm_errjmp)) == 0) { /* no err catched */
748 rval = scm_apply0(thunk);
749 } else {
750 rval = NULL; /* have peace with compiler */
751 }
752 if (ret_close) {
753 rval = (*close)(*old_port);
754 } else {
755 (*close)(*old_port);
756 }
757
758 *old_port = port_save;
759 memcpy(scm_errjmp, handler_save, sizeof(jmp_buf));
760 if (k != 0) {
761 sprintf(errbuf, "%s: io error on", errmsg);
762 SCM_ERR(errbuf, filename);
763 }
764 return(rval);
765 }
766
767 /*S* (with-input-from-file FILENAME THUNK) => OBJ */
768 /*D* The file FILENAME is open for reading and the THUNK procedure is
769 evaluated with it's current-input-port pointing to the just opened
770 file. */
scm_with_input_from_file(SOBJ filename,SOBJ thunk)771 SOBJ scm_with_input_from_file(SOBJ filename, SOBJ thunk)
772 {
773 return(scm_port_redirect(&scm_in_port,
774 scm_open_input_file, 1, scm_close_port, FALSE,
775 "with-input-from-file", filename, thunk));
776 }
777
778 /*S* (with-output-to-file FILENAME THUNK) => OBJ */
779 /*D* The file FILENAME is open for writing and the THUNK procedure is
780 evaluated with it's current-output-port pointing to the just opened
781 file. */
scm_with_output_to_file(SOBJ filename,SOBJ thunk)782 SOBJ scm_with_output_to_file(SOBJ filename, SOBJ thunk)
783 {
784 return(scm_port_redirect(&scm_out_port,
785 scm_open_output_file, 1, scm_close_port, FALSE,
786 "with-output-to-file", filename, thunk));
787 }
788
789
790 /*E* (with-input-from-string STRING THUNK) => OBJ */
791 /*D* The file STRING is opened for reading and the THUNK procedure is
792 evaluated with it's current-input-port pointing to the just opened
793 string. */
794
scm_with_input_from_string(SOBJ str,SOBJ thunk)795 SOBJ scm_with_input_from_string(SOBJ str, SOBJ thunk)
796 {
797 return(scm_port_redirect(&scm_in_port,
798 scm_open_input_string, 1, scm_close_port, FALSE,
799 "with-input-from-string", str, thunk));
800 }
801
802 /*E* (with-output-to-string THUNK) => OBJ */
803 /*D* The file STRING is opened for writing and the THUNK procedure is
804 evaluated with it's current-output-port pointing to the just opened
805 string. */
scm_with_output_to_string(SOBJ thunk)806 SOBJ scm_with_output_to_string(SOBJ thunk)
807 {
808 return(scm_port_redirect(&scm_out_port,
809 scm_open_output_string, 0, scm_close_port, TRUE,
810 "with-output-to-string", NULL, thunk));
811 }
812
813 /*S* (open-input-file NAME) => PORT */
814 /*D* Open file NAME for reading. If file does not exist an error
815 occurs. */
scm_open_input_file(SOBJ filename)816 SOBJ scm_open_input_file(SOBJ filename)
817 {
818 SOBJ port = NULL;
819 PORT *p;
820
821 if (!SCM_STRINGP(filename))
822 SCM_ERR("open-input-file: bad filename", filename);
823
824 p = port_open_input_file(SCM_STR_VALUE(filename));
825 if (p == NULL || (port = scm_mkport(p)) == NULL)
826 SCM_ERR("open-input-file: cannot open file", filename);
827 return(port);
828 }
829
830 /*S* (open-output-file NAME) => PORT */
831 /*D* Open file NAME for writing. File is truncated or created. */
scm_open_output_file(SOBJ filename)832 SOBJ scm_open_output_file(SOBJ filename)
833 {
834 SOBJ port = NULL;
835 PORT *p;
836
837 if (!SCM_STRINGP(filename)) SCM_ERR("open-output-file: bad filename", filename);
838 p = port_open_output_file(SCM_STR_VALUE(filename));
839 if (p == NULL || (port = scm_mkport(p)) == NULL)
840 SCM_ERR("open-output-file: cannot open file", filename);
841 return(port);
842 }
843
844 /*E* (open-input-string STRING) => PORT */
845 /*D* Open STRING for reading. */
scm_open_input_string(SOBJ string)846 SOBJ scm_open_input_string(SOBJ string)
847 {
848 SOBJ port = NULL;
849 PORT *p;
850
851 if (!SCM_STRINGP(string))
852 SCM_ERR("open-input-string: bad string", string);
853
854 p = port_open_input_string(SCM_STR_VALUE(string));
855 if (p == NULL || (port = scm_mkport(p)) == NULL)
856 SCM_ERR("open-input-string: cannot open string", string);
857
858 return(port);
859 }
860
861 /*E* (open-output-string) => PORT */
862 /*D* Open a new string for writing. The string will be returned when port is closed. */
scm_open_output_string()863 SOBJ scm_open_output_string()
864 {
865 SOBJ port = NULL;
866 PORT *p;
867
868 p = port_open_output_string();
869 if (p == NULL || (port = scm_mkport(p)) == NULL)
870 SCM_ERR("open-output-string: cannot open string", NULL);
871
872 return(port);
873 }
874
875 /*E* (get-output-string PORT) => STRING */
876 /*D* Get current string for an output string port. */
877
scm_get_output_string(SOBJ port)878 SOBJ scm_get_output_string(SOBJ port)
879 {
880 SOBJ str;
881
882 if (!SCM_PORTP(port)) SCM_ERR("get-output-string: bad port", port);
883 if (!SCM_STRING_PORTP(port) || !SCM_WRITE_PORTP(port))
884 SCM_ERR("get-output-string: bad port type", port);
885
886 str = scm_str_alloc(SCM_PORT(port)->descr.s.length);
887 strncpy(SCM_STR_VALUE(str),
888 SCM_PORT(port)->descr.s.data,
889 SCM_PORT(port)->descr.s.length);
890 return(str);
891 }
892
893 /*S* (close-port PORT) => BOOLEAN | STRING */
894 /*D* Close this port. Returns a STRING if port is an output string
895 port, a BOOLEAN otherwise. */
scm_close_port(SOBJ port)896 SOBJ scm_close_port(SOBJ port)
897 {
898 SOBJ rval;
899
900 if (!SCM_PORTP(port)) SCM_ERR("close-port: bad port", port);
901
902 rval = scm_true;
903 if (SCM_PORT(port)) {
904
905 if (SCM_STRING_PORTP(port) && SCM_WRITE_PORTP(port))
906 rval = scm_get_output_string(port);
907
908 port_close(SCM_PORT(port));
909 SCM_PORT(port) = NULL;
910 }
911 return(rval);
912 }
913
914 /*S* (close-input-port PORT) => BOOLEAN */
915 /*D* Close PORT and returns #t if no error ocurred, #f otherwise */
916
scm_close_input_port(SOBJ port)917 SOBJ scm_close_input_port(SOBJ port)
918 {
919 return(scm_close_port(port));
920 }
921
922 /*S* (close-output-port PORT) => BOOLEAN | STRING */
923 /*D* Close PORT and return a STRING if port was an output string, a
924 BOOLEAN otherwise. */
925
scm_close_output_port(SOBJ port)926 SOBJ scm_close_output_port(SOBJ port)
927 {
928 return(scm_close_port(port));
929 }
930
931 /*S* (read [PORT]) => OBJ */
932 /*D* Read and parse an object from PORT if specified or from
933 current-input-port. */
scm_read(int argc,SOBJ * arg)934 SOBJ scm_read(int argc, SOBJ *arg)
935 {
936 PORT *port;
937
938 if (argc >= 1) {
939 if (!SCM_PORTP(arg[0])) SCM_ERR("read: bad port", arg[0]);
940 port = SCM_PORT(arg[0]);
941 } else {
942 port = SCM_INP;
943 }
944 return(scm_read_port(port));
945 }
946
947 /*S* (read-char [PORT]) => CHAR */
948 /*D* Read a char from a PORT if specified or from
949 current-input-port. */
scm_read_char(int argc,SOBJ * arg)950 SOBJ scm_read_char(int argc, SOBJ *arg)
951 {
952 PORT *port;
953 int c;
954
955 if (argc >= 1) {
956 if (!SCM_PORTP(arg[0])) SCM_ERR("read-char: bad port", arg[0]);
957 port = SCM_PORT(arg[0]);
958 } else {
959 port = SCM_INP;
960 }
961 if (port == NULL) SCM_ERR("read-char: port closed", NULL);
962 if ((c = port_getc(port)) == PORT_EOF)
963 return(scm_eof);
964 return(scm_mkchar(c));
965 }
966
967 /*S* (peek-char [PORT]) => CHAR */
968 /*D* Read a char from a PORT if specified or from
969 current-input-port. The file pointer is not advanced, so next call
970 to read-char or peek-char will return the same CHAR.*/
scm_peek_char(int argc,SOBJ * arg)971 SOBJ scm_peek_char(int argc, SOBJ *arg)
972 {
973 PORT *port;
974 int c;
975
976 if (argc >= 1) {
977 if (!SCM_PORTP(arg[0])) SCM_ERR("read-char: bad port", arg[0]);
978 port = SCM_PORT(arg[0]);
979 } else {
980 port = SCM_INP;
981 }
982 if (port == NULL) SCM_ERR("read-char: port closed", NULL);
983 if ((c = port_peekc(port)) == PORT_EOF)
984 return(scm_eof);
985 return(scm_mkchar(c));
986 }
987
988 /*S* (eof-object? OBJ) => BOOLEAN */
989 /*D* Returns #t if OBJ is the eof object, #f otherwise */
scm_eof_objectp(SOBJ obj)990 SOBJ scm_eof_objectp(SOBJ obj)
991 {
992 return(SCM_MKBOOL(obj == scm_eof));
993 }
994
995 /*E* (read-line STR PORT) => BOOL */
996 /*D* Read a full line from PORT. If end-of file is reached, #f is
997 * returned. NOTE: STRING will not contain a newline character. */
scm_read_line(SOBJ str,SOBJ port)998 SOBJ scm_read_line(SOBJ str, SOBJ port)
999 {
1000 if (!SCM_PORTP(port)) SCM_ERR("read-line: bad port", port);
1001 return(SCM_MKBOOL( port_getline(SCM_PORT(port), str) >= 0 ));
1002 }
1003
1004 #ifdef OLD
scm_read_line(SOBJ port)1005 SOBJ scm_read_line(SOBJ port)
1006 {
1007 SOBJ str;
1008 int c;
1009
1010 if (!SCM_PORTP(port)) SCM_ERR("read-line: bad port", port);
1011
1012 str = scm_mkstring("");
1013 while( (c = port_getc(SCM_PORT(port))) != PORT_EOF) {
1014 if (c == '\r') continue; /* ignore cr */
1015 if (c == '\n') return(str); /* terminate when lf */
1016 scm_string_append_char(str, SCM_MKINUM(c));
1017 }
1018 return(scm_false);
1019 }
1020 #endif
1021
scm_read_line_old(SOBJ port)1022 SOBJ scm_read_line_old(SOBJ port)
1023 {
1024 SOBJ str;
1025 char *p, *l;
1026 int len, c;
1027
1028 if (!SCM_PORTP(port)) SCM_ERR("read-line: bad port", port);
1029
1030 str = scm_str_alloc(128);
1031 p = SCM_STR_VALUE(str);
1032 l = p + 128;
1033 while( (c = port_getc(SCM_PORT(port))) != PORT_EOF) {
1034 if (c == '\r') continue;
1035 if (c == '\n') {
1036 SCM_STR_LEN(str) = p - SCM_STR_VALUE(str);
1037 *p = 0;
1038 return(str);
1039 }
1040
1041 if (p >= l) {
1042 len = SCM_STR_LEN(str);
1043 scm_str_resize(str, len + 128);
1044 p = SCM_STR_VALUE(str) + len;
1045 l = p + 128;
1046 }
1047 *p++ = c;
1048 }
1049 return(scm_false);
1050 }
1051
1052
1053 /*S* (char-ready? [PORT]) => BOOLEAN */
1054 /*D* NOT IMPLEMENTED */
scm_char_readyp(int argc,SOBJ * arg)1055 SOBJ scm_char_readyp(int argc, SOBJ *arg)
1056 {
1057 SCM_ERR("char-ready?: not implemented", NULL);
1058 return(NULL);
1059 }
1060
1061 /*S* (write OBJ [PORT]) => #undefined */
1062 /*D* Writes a written representation of obj to the given port. Strings
1063 that appear in the written representation are enclosed in
1064 doublequotes, and within those strings backslash and doublequote
1065 characters are escaped by backslashes. If no PORT argument is given,
1066 the current-output-port is used.*/
1067
1068 /*S* (display OBJ [PORT]) => #undefined */
1069 /*D* Writes a representation of obj to the given port. Strings that
1070 appear in the written representation are not enclosed in
1071 doublequotes, and no characters are escaped within those strings.
1072 Character objects appear in the representation as if written by
1073 write-char instead of by write. If no PORT argument is given, the
1074 current-output-port is used.*/
1075
1076 /*S* (newline [PORT]) => #undefined */
1077 /*D* Writes an end of line to port. If no PORT argument is given, the
1078 current-output-port is used. */
1079
1080 /*S* (write-char CHAR [PORT]) */
1081 /*D* Writes the character CHAR to the given PORT. If no PORT argument
1082 is given, the current-output-port is used. */
scm_write_char(int argc,SOBJ * arg)1083 SOBJ scm_write_char(int argc, SOBJ *arg)
1084 {
1085 PORT *p;
1086
1087 if (argc != 1 && argc != 2) SCM_ERR("write-char: bad number of args", NULL);
1088
1089 if (!SCM_CHARP(arg[0])) SCM_ERR("write-char: bad char", arg[0]);
1090 if (argc == 1) {
1091 p = SCM_OUTP;
1092 } else {
1093 if (!SCM_PORTP(arg[1])) SCM_ERR("write-char: bad port", arg[1]);
1094 p = SCM_PORT(arg[1]);
1095 }
1096 port_putc(p, SCM_CHAR(arg[0]));
1097 return(scm_true);
1098 }
1099
1100 /*E* (flush-output [PORT]) => #undefined */
1101 /*D* Write anything that have been buffered in the PORT. If no PORT
1102 argument is given, the current-output-port is used. */
scm_flush_output(int argc,SOBJ * arg)1103 SOBJ scm_flush_output(int argc, SOBJ *arg)
1104 {
1105 SOBJ port;
1106 if (argc > 1) SCM_ERR("flush-output: bad number of args", NULL);
1107
1108 port = (argc == 1) ? arg[0] : scm_out_port;
1109 if (!SCM_PORTP(port)) SCM_ERR("flush-output: bad port", port);
1110
1111 if (SCM_FILE_PORTP(port) && SCM_WRITE_PORTP(port)) {
1112 fflush(SCM_PORT(port)->descr.f);
1113 }
1114 return(scm_true);
1115 }
1116
1117 /*E* (file-position PORT [POS]) => NUMBER | BOOLEAN */
1118 /*D* When POS is given, set the file position for the port, if
1119 possible and returns a #t if operation was successfull. If POS is
1120 not given, returns the position number for the PORT. */
scm_file_position(int argc,SOBJ * arg)1121 SOBJ scm_file_position(int argc, SOBJ *arg)
1122 {
1123 SOBJ port, pos;
1124
1125 if (argc > 2 || argc < 1)
1126 SCM_ERR("file-position: bad number of args", NULL);
1127
1128 port = arg[0];
1129 if (!SCM_PORTP(port)) SCM_ERR("file-position: bad port", port);
1130 if (argc == 2) { /* set position */
1131 pos = arg[0];
1132 if (!SCM_NUMBERP(pos)) SCM_ERR("file-position: bad number", pos);
1133 return( fseek(SCM_PORT(port)->descr.f, scm_number2long(pos), 0) == 0 ?
1134 scm_true : scm_false);
1135 } else { /* get position */
1136 return(scm_int2num(ftell(SCM_PORT(port)->descr.f)));
1137 }
1138 }
1139
1140
1141 /*S* (load FILENAME) => VALUE */
1142 /*D* FILENAME should be a string naming an existing file containing
1143 Scheme source code. The load procedure reads expressions and
1144 definitions from the file and evaluates them sequentially. Returns
1145 the value of last evaluated expression. */
1146
1147
1148 /*S* (transcript-on STRING) => #undefined */
1149 /*D* NOT IMPLEMENTED */
1150
1151 /*S* (transcript-off) => #undefined */
1152 /*D* NOT IMPLEMENTED */
1153
1154 /* The idea of this extensions is to bind FILE and PORT
1155 * Examples:
1156 * (define p (open-file "/tmp/tst.txt" "w+"))
1157 * (fseek (port-file p) 10 0)
1158 * (fputs (prot-file p) "Hello")
1159 * (close-port p)
1160 *
1161 * (let ((f (make-file-port (fopen "/tmp/tst.txt" "w"))))
1162 * (fputs (port->file f) "hello world\n")
1163 * (port-close f))
1164 */
1165
1166 /*I* (open-file FILENAME MODE) -> PORT */
1167 /*I* (open-string STRING MODE) -> PORT */
1168 /*I* (make-file-port FILE) -> PORT */
1169 /*I* (port->file PORT) -> FILE */
1170
1171 /************************************************************************
1172 * Initialization
1173 ************************************************************************/
1174
scm_port_init_default_files()1175 void scm_port_init_default_files()
1176 {
1177
1178 /* reopen stdin out and err to SCM_INP, SCM_OUTP, SCM_ERRP ports*/
1179 #ifdef KILL_STDIO
1180 int fn;
1181
1182 fn = dup(0); fclose(stdin); if (dup(fn) != 0) exit(2);
1183 SCM_INP = port_new(PORT_T_FILE, PORT_IO_R);
1184 SCM_INP->descr.f = fdopen(0, "r");
1185
1186 fn = dup(1); fclose(stdout); if (dup(fn) != 1) exit(2);
1187 SCM_OUTP = port_new(PORT_T_FILE, PORT_IO_W);
1188 SCM_OUTP->descr.f = fdopen(1, "w");
1189
1190 fn = dup(2); fclose(stderr); if (dup(fn) != 2) exit(2);
1191 SCM_ERRP = port_new(PORT_T_FILE, PORT_IO_W);
1192 SCM_ERRP->descr.f = fdopen(2, "w");
1193 #else
1194 scm_inp = port_new(PORT_T_FILE, PORT_IO_R); scm_inp->descr.f = stdin;
1195 scm_outp = port_new(PORT_T_FILE, PORT_IO_W); scm_outp->descr.f = stdout;
1196 scm_errp = port_new(PORT_T_FILE, PORT_IO_W); scm_errp->descr.f = stderr;
1197 #endif
1198
1199 }
1200
1201 /*E* (float-precision N) => OLDPREC */
1202 /*D* Set the default number of fractional position that will be
1203 outputed when writing float numbers. Returns the precision that was
1204 in effect before calling this function. */
1205
scm_float_precision(SOBJ x)1206 SOBJ scm_float_precision(SOBJ x)
1207 {
1208 int old;
1209
1210 if (!SCM_INUMP(x)) SCM_ERR("bad precision", x);
1211 if (SCM_INUM(x) < 0 || SCM_INUM(x) > 100)
1212 SCM_ERR("precision out of [0..100] range", x);
1213 old = scm_float_digits;
1214 scm_float_digits = SCM_INUM(x);
1215 return(SCM_MKINUM(old));
1216 }
1217
scm_init_port()1218 void scm_init_port()
1219 {
1220 scm_in_port = scm_mkport(scm_inp);
1221 SCM_PORT(scm_in_port)->io_flag = PORT_IO_R;
1222
1223 scm_out_port = scm_mkport(scm_outp);
1224 SCM_PORT(scm_out_port)->io_flag = PORT_IO_W;
1225
1226 scm_err_port = scm_mkport(scm_errp);
1227 SCM_PORT(scm_err_port)->io_flag = PORT_IO_W;
1228
1229 scm_gc_protect(&scm_in_port);
1230 scm_gc_protect(&scm_out_port);
1231 scm_gc_protect(&scm_err_port);
1232 scm_eof= scm_newcell(SOBJ_T_EOF); scm_gc_protect(&scm_eof);
1233
1234 scm_add_cprim("port?", scm_portp, 1);
1235 scm_add_cprim("input-port?", scm_input_portp, 1);
1236 scm_add_cprim("output-port?", scm_output_portp, 1);
1237 scm_add_cprim("current-input-port", scm_current_input_port, 0);
1238 scm_add_cprim("current-output-port", scm_current_output_port, 0);
1239 scm_add_cprim("current-error-port", scm_current_error_port, 0);
1240
1241 scm_add_cprim("with-input-from-file", scm_with_input_from_file, 2);
1242 scm_add_cprim("with-output-to-file", scm_with_output_to_file, 2);
1243
1244 scm_add_cprim("with-input-from-string",scm_with_input_from_string,2);
1245 scm_add_cprim("with-output-to-string", scm_with_output_to_string, 1);
1246
1247 scm_add_cprim("open-input-file", scm_open_input_file, 1);
1248 scm_add_cprim("open-output-file", scm_open_output_file, 1);
1249 scm_add_cprim("open-input-string", scm_open_input_string, 1);
1250 scm_add_cprim("open-output-string", scm_open_output_string, 0);
1251 scm_add_cprim("get-output-string", scm_get_output_string, 1);
1252 scm_add_cprim("close-port", scm_close_port, 1);
1253 scm_add_cprim("close-input-port", scm_close_input_port, 1);
1254 scm_add_cprim("close-output-port", scm_close_output_port, 1);
1255 scm_add_cprim("read", scm_read, -1);
1256 scm_add_cprim("read-char", scm_read_char, -1);
1257 scm_add_cprim("peek-char", scm_peek_char, -1);
1258 scm_add_cprim("eof-object?", scm_eof_objectp, 1);
1259 scm_add_cprim("char-ready?", scm_char_readyp, 1);
1260 scm_add_cprim("read-line", scm_read_line, 2);
1261 scm_add_cprim("write-char", scm_write_char, -1);
1262 scm_add_cprim("flush-output", scm_flush_output, -1);
1263 scm_add_cprim("file-position", scm_file_position, -1);
1264 scm_add_cprim("float-precision", scm_float_precision, 1);
1265 }
1266