1 /*-
2 * Copyright (c) 2007-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)port.c 2.2 2/1/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 /* === PORT-IO === */
37
38 typedef struct {
39 FTH read_char; /* Procs */
40 FTH write_char; /* ... */
41 FTH read_line;
42 FTH write_line;
43 FTH flush;
44 FTH close;
45 } FIO_Softport;
46
47 #define FTH_SOFT_PORT_REF(Obj) ((FIO_Softport *)(Obj))
48 #define FTH_SOFT_PORT_READ_CHAR(Obj) FTH_SOFT_PORT_REF(Obj)->read_char
49 #define FTH_SOFT_PORT_WRITE_CHAR(Obj) FTH_SOFT_PORT_REF(Obj)->write_char
50 #define FTH_SOFT_PORT_READ_LINE(Obj) FTH_SOFT_PORT_REF(Obj)->read_line
51 #define FTH_SOFT_PORT_WRITE_LINE(Obj) FTH_SOFT_PORT_REF(Obj)->write_line
52 #define FTH_SOFT_PORT_FLUSH(Obj) FTH_SOFT_PORT_REF(Obj)->flush
53 #define FTH_SOFT_PORT_CLOSE(Obj) FTH_SOFT_PORT_REF(Obj)->close
54
55 static void default_error_cb(ficlVm *, char *);
56 static void default_print_cb(ficlVm *, char *);
57 static char *default_read_cb(ficlVm *);
58 static void ficl_make_soft_input_port(ficlVm *);
59 static void ficl_make_soft_output_port(ficlVm *);
60 static void ficl_make_soft_port(ficlVm *);
61 static void ficl_port_close(ficlVm *);
62 static void ficl_port_closed_p(ficlVm *);
63 static void ficl_port_display(ficlVm *);
64 static void ficl_port_flush(ficlVm *);
65 static void ficl_port_getc(ficlVm *);
66 static void ficl_port_gets(ficlVm *);
67 static void ficl_port_input_p(ficlVm *);
68 static void ficl_port_output_p(ficlVm *);
69 static void ficl_port_p(ficlVm *);
70 static void ficl_port_putc(ficlVm *);
71 static void ficl_port_puts(ficlVm *);
72 static void ficl_port_puts_format(ficlVm *);
73 static void ficl_port_to_string(ficlVm *);
74 static void ficl_with_error_to_port(ficlVm *);
75 static void ficl_with_input_from_port(ficlVm *);
76 static void ficl_with_input_port(ficlVm *);
77 static void ficl_with_output_port(ficlVm *);
78 static void ficl_with_output_to_port(ficlVm *);
79 static FTH fth_init_soft_port_procs(void);
80 static FTH fth_make_soft_port(FTH, char *, int);
81 static FTH fth_set_soft_port_from_optkey(FTH, int);
82 static void port_close(void *);
83 static void port_flush(void *);
84 static int port_read_char(void *);
85 static char *port_read_line(void *);
86 static void port_write_char(void *, int);
87 static void port_write_line(void *, const char *);
88 static void soft_close(void);
89 static void soft_flush(void);
90 static FTH soft_read_char(void);
91 static FTH soft_read_line(void);
92 static void soft_write_char(FTH);
93 static void soft_write_line(FTH);
94
95 #define h_list_of_port_functions "\
96 *** PORT PRIMITIVES ***\n\
97 make-soft-input-port ( :key args -- prt )\n\
98 make-soft-output-port ( :key args -- prt )\n\
99 make-soft-port ( :key args -- prt )\n\
100 port->string ( prt -- str )\n\
101 port-close ( prt -- )\n\
102 port-closed? ( obj -- f )\n\
103 port-display ( prt obj -- )\n\
104 port-flush ( prt -- )\n\
105 port-getc ( prt -- c )\n\
106 port-gets ( prt -- str )\n\
107 port-input? ( obj -- f )\n\
108 port-output? ( obj -- f )\n\
109 port-putc ( prt c -- )\n\
110 port-puts ( prt str -- )\n\
111 port-puts-format ( prt fmt fmt-args -- )\n\
112 port-read alias for port-gets\n\
113 port-write alias for port-puts\n\
114 port-write-format alias for port-puts-format\n\
115 port? ( obj -- f )\n\
116 with-error-to-port ( obj :key args -- )\n\
117 with-input-from-port ( obj :key args -- str )\n\
118 with-input-port ( obj :key args -- str )\n\
119 with-output-port ( obj :key args -- )\n\
120 with-output-to-port ( obj :key args -- )"
121
122 static int
port_read_char(void * ptr)123 port_read_char(void *ptr)
124 {
125 FTH ch;
126
127 ch = fth_proc_call(FTH_SOFT_PORT_READ_CHAR(ptr), "port_read_char", 0);
128
129 if (FTH_FALSE_P(ch))
130 return (EOF);
131
132 return (FTH_TO_CHAR(ch));
133 }
134
135 static void
port_write_char(void * ptr,int c)136 port_write_char(void *ptr, int c)
137 {
138 FTH ch;
139
140 ch = CHAR_TO_FTH(c);
141 fth_proc_call(FTH_SOFT_PORT_WRITE_CHAR(ptr), "port_write_char", 1, ch);
142 }
143
144 static char *
port_read_line(void * ptr)145 port_read_line(void *ptr)
146 {
147 FTH fs;
148
149 fs = fth_proc_call(FTH_SOFT_PORT_READ_LINE(ptr), "port_read_line", 0);
150
151 if (FTH_FALSE_P(fs))
152 return (NULL);
153
154 return (fth_string_ref(fs));
155 }
156
157 static void
port_write_line(void * ptr,const char * line)158 port_write_line(void *ptr, const char *line)
159 {
160 FTH fs;
161
162 fs = fth_make_string(line);
163 fth_proc_call(FTH_SOFT_PORT_WRITE_LINE(ptr), "port_write_line", 1, fs);
164 }
165
166 static void
port_flush(void * ptr)167 port_flush(void *ptr)
168 {
169 fth_proc_call(FTH_SOFT_PORT_FLUSH(ptr), "port_flush", 0);
170 }
171
172 static void
port_close(void * ptr)173 port_close(void *ptr)
174 {
175 fth_proc_call(FTH_SOFT_PORT_CLOSE(ptr), "port_close", 0);
176 }
177
178 /* --- Soft Port Procs --- */
179
180 static FTH gn_read_char;
181 static FTH gn_write_char;
182 static FTH gn_read_line;
183 static FTH gn_write_line;
184 static FTH gn_flush;
185 static FTH gn_close;
186
187 static FTH
soft_read_char(void)188 soft_read_char(void)
189 {
190 return (FTH_FALSE);
191 }
192
193 /* ARGSUSED */
194 static void
soft_write_char(FTH c)195 soft_write_char(FTH c)
196 {
197 (void) c;
198 }
199
200 static FTH
soft_read_line(void)201 soft_read_line(void)
202 {
203 return (FTH_FALSE);
204 }
205
206 /* ARGSUSED */
207 static void
soft_write_line(FTH line)208 soft_write_line(FTH line)
209 {
210 (void) line;
211 }
212
213 static void
soft_flush(void)214 soft_flush(void)
215 {
216 }
217
218 static void
soft_close(void)219 soft_close(void)
220 {
221 }
222
223 static FTH
fth_init_soft_port_procs(void)224 fth_init_soft_port_procs(void)
225 {
226 FTH prcs;
227
228 prcs = fth_make_array_len((ficlInteger) PORT_TYPE_LAST);
229 fth_array_set(prcs, (ficlInteger) PORT_READ_CHAR, gn_read_char);
230 fth_array_set(prcs, (ficlInteger) PORT_WRITE_CHAR, gn_write_char);
231 fth_array_set(prcs, (ficlInteger) PORT_READ_LINE, gn_read_line);
232 fth_array_set(prcs, (ficlInteger) PORT_WRITE_LINE, gn_write_line);
233 fth_array_set(prcs, (ficlInteger) PORT_FLUSH, gn_flush);
234 fth_array_set(prcs, (ficlInteger) PORT_CLOSE, gn_close);
235 return (prcs);
236 }
237
238 static FTH
fth_set_soft_port_from_optkey(FTH prcs,int kind)239 fth_set_soft_port_from_optkey(FTH prcs, int kind)
240 {
241 ficlInteger type;
242 FTH proc;
243
244 type = (ficlInteger) kind;
245 FTH_ASSERT_ARGS(fth_array_length(prcs) >= PORT_TYPE_LAST,
246 prcs, FTH_ARG1, "an array of length 6");
247 FTH_ASSERT_ARGS((type >= 0) || (type < PORT_TYPE_LAST),
248 fth_make_int(type), FTH_ARG2, "an int");
249
250 switch (type) {
251 case PORT_READ_CHAR:
252 proc = fth_get_optkey(FTH_KEYWORD_READ_CHAR, gn_read_char);
253 break;
254 case PORT_WRITE_CHAR:
255 proc = fth_get_optkey(FTH_KEYWORD_WRITE_CHAR, gn_write_char);
256 break;
257 case PORT_READ_LINE:
258 proc = fth_get_optkey(FTH_KEYWORD_READ_LINE, gn_read_line);
259 break;
260 case PORT_WRITE_LINE:
261 proc = fth_get_optkey(FTH_KEYWORD_WRITE_LINE, gn_write_line);
262 break;
263 case PORT_FLUSH:
264 proc = fth_get_optkey(FTH_KEYWORD_FLUSH, gn_flush);
265 break;
266 case PORT_CLOSE:
267 default:
268 proc = fth_get_optkey(FTH_KEYWORD_CLOSE, gn_close);
269 break;
270 }
271
272 fth_array_set(prcs, type, proc);
273 return (prcs);
274 }
275
276 static FTH
fth_make_soft_port(FTH prcs,char * name,int fam)277 fth_make_soft_port(FTH prcs, char *name, int fam)
278 {
279 FIO_Softport *prt;
280 FTH io;
281
282 io = make_io_base(fam);
283 prt = FTH_MALLOC(sizeof(FIO_Softport));
284 prt->read_char = fth_array_ref(prcs, (ficlInteger) PORT_READ_CHAR);
285 prt->write_char = fth_array_ref(prcs, (ficlInteger) PORT_WRITE_CHAR);
286 prt->read_line = fth_array_ref(prcs, (ficlInteger) PORT_READ_LINE);
287 prt->write_line = fth_array_ref(prcs, (ficlInteger) PORT_WRITE_LINE);
288 prt->flush = fth_array_ref(prcs, (ficlInteger) PORT_FLUSH);
289 prt->close = fth_array_ref(prcs, (ficlInteger) PORT_CLOSE);
290 FTH_IO_FILENAME(io) = fth_make_string(name);
291 FTH_IO_NAME(io) = fth_make_string("port");
292 FTH_IO_TYPE(io) = FTH_IO_PORT;
293 FTH_IO_DATA(io) = (void *) prt;
294 FTH_IO_OBJECT(io)->read_char = port_read_char;
295 FTH_IO_OBJECT(io)->write_char = port_write_char;
296 FTH_IO_OBJECT(io)->read_line = port_read_line;
297 FTH_IO_OBJECT(io)->write_line = port_write_line;
298 FTH_IO_OBJECT(io)->flush = port_flush;
299 FTH_IO_OBJECT(io)->close = port_close;
300 return (io);
301 }
302
303 static void
ficl_port_p(ficlVm * vm)304 ficl_port_p(ficlVm *vm)
305 {
306 #define h_port_p "( obj -- f ) test if OBJ is a port\n\
307 nil port? => #f\n\
308 #f port? => #t\n\
309 \"foo\" io-open-input-file port? => #t\n\
310 Return #t if OBJ is an IO object or #f, otherwise #f.\n\
311 See also port-input? and port-output?."
312 int flag;
313 FTH obj;
314
315 FTH_STACK_CHECK(vm, 1, 1);
316 obj = fth_pop_ficl_cell(vm);
317 flag = FTH_FALSE_P(obj) || FTH_IO_P(obj);
318 ficlStackPushBoolean(vm->dataStack, flag);
319 }
320
321 static void
ficl_port_input_p(ficlVm * vm)322 ficl_port_input_p(ficlVm *vm)
323 {
324 #define h_port_input_p "( obj -- f ) test if OBJ is input port\n\
325 nil port-input? => #f\n\
326 #f port-input? => #t\n\
327 \"foo\" io-open-input-file port-input? => #t\n\
328 Return #t if OBJ is an input IO object or #f, otherwise #f.\n\
329 See also port? and port-output?."
330 int flag;
331 FTH obj;
332
333 FTH_STACK_CHECK(vm, 1, 1);
334 obj = fth_pop_ficl_cell(vm);
335 flag = FTH_FALSE_P(obj) || fth_io_input_p(obj);
336 ficlStackPushBoolean(vm->dataStack, flag);
337 }
338
339 static void
ficl_port_output_p(ficlVm * vm)340 ficl_port_output_p(ficlVm *vm)
341 {
342 #define h_port_output_p "( obj -- f ) test if OBJ is output port\n\
343 nil port-output? => #f\n\
344 #f port-output? => #t\n\
345 \"foo\" io-open-output-file port-output? => #t\n\
346 Return #t if OBJ is an output IO object or #f, otherwise #f.\n\
347 See also port? and port-input?."
348 int flag;
349 FTH obj;
350
351 FTH_STACK_CHECK(vm, 1, 1);
352 obj = fth_pop_ficl_cell(vm);
353 flag = FTH_FALSE_P(obj) || fth_io_output_p(obj);
354 ficlStackPushBoolean(vm->dataStack, flag);
355 }
356
357 static void
ficl_port_closed_p(ficlVm * vm)358 ficl_port_closed_p(ficlVm *vm)
359 {
360 #define h_port_closed_p "( io -- f ) test if IO is closed\n\
361 \"foo\" io-open-output-file value o1\n\
362 o1 port-closed? => #f\n\
363 o1 port-close\n\
364 o1 port-closed? => #t\n\
365 Return #t if IO object is closed, otherwise #f."
366 int flag;
367 FTH obj;
368
369 FTH_STACK_CHECK(vm, 1, 1);
370 obj = fth_pop_ficl_cell(vm);
371 flag = FTH_FALSE_P(obj) || fth_io_closed_p(obj);
372 ficlStackPushBoolean(vm->dataStack, flag);
373 }
374
375 #define h_port_keywords "\
376 Keywords:\n\
377 :fam r/o, w/o (default), r/w\n\
378 :port-name \"soft-port\"\n\
379 :read-char proc ( -- c )\n\
380 :write-char proc ( c -- )\n\
381 :read-line proc ( -- line )\n\
382 :write-line proc ( line -- )\n\
383 :flush proc ( -- )\n\
384 :close proc ( -- )\n\
385 Not all procs are required. \
386 If you want an object for reading, provide read procs, \
387 the same for writing.\n\
388 See also make-soft-port, make-soft-input-port, make-soft-output-port."
389
390 static void
ficl_make_soft_port(ficlVm * vm)391 ficl_make_soft_port(ficlVm *vm)
392 {
393 #define h_make_soft_port "( :key args -- io ) return soft port\n\
394 Input example:\n\
395 :port-name \"sndin\"\n\
396 :read-char lambda: <{ -- c }> *stdin* io-getc ;\n\
397 :read-line lambda: <{ -- line }> *stdin* io-read ;\n\
398 make-soft-port set-*stdin* value stdin-io\n\
399 Return soft port for reading. \
400 The *stdin* IO object is preserved in stdin-io for later use.\n\
401 Output example:\n\
402 :port-name \"sndout\"\n\
403 :write-char lambda: <{ c -- }> c snd-print .stdout ;\n\
404 :write-line lambda: <{ line -- }> line snd-print .stdout ;\n\
405 make-soft-port set-*stdout* value stdout-io\n\
406 Return soft port for writing. \
407 The *stdout* IO object is preserved in stdout-io for later use.\n\
408 Return new soft port IO object with corresponding procs.\n\
409 " h_port_keywords
410 int fam;
411 char *name;
412 FTH prcs;
413 FTH port;
414
415 fam = fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_WRITE);
416 name = fth_get_optkey_str(FTH_KEYWORD_PORT_NAME, "soft-port");
417 prcs = fth_init_soft_port_procs();
418 fth_set_soft_port_from_optkey(prcs, PORT_READ_CHAR);
419 fth_set_soft_port_from_optkey(prcs, PORT_WRITE_CHAR);
420 fth_set_soft_port_from_optkey(prcs, PORT_READ_LINE);
421 fth_set_soft_port_from_optkey(prcs, PORT_WRITE_LINE);
422 fth_set_soft_port_from_optkey(prcs, PORT_FLUSH);
423 fth_set_soft_port_from_optkey(prcs, PORT_CLOSE);
424 port = fth_make_soft_port(prcs, name, fam);
425 ficlStackPushFTH(vm->dataStack, port);
426 }
427
428 static void
ficl_make_soft_input_port(ficlVm * vm)429 ficl_make_soft_input_port(ficlVm *vm)
430 {
431 #define h_msiport "( :key args -- io ) return in soft port\n\
432 :port-name \"sndin\"\n\
433 :read-char lambda: <{ -- c }> *stdin* io-getc ;\n\
434 :read-line lambda: <{ -- line }> *stdin* io-read ;\n\
435 make-soft-port set-*stdin* value stdin-io\n\
436 Return soft port IO object for reading. \
437 The *stdin* IO object is preserved in stdin-io for later use.\n\
438 " h_port_keywords
439 char *name;
440 FTH prcs;
441 FTH port;
442
443 name = fth_get_optkey_str(FTH_KEYWORD_PORT_NAME, "soft-port");
444 prcs = fth_init_soft_port_procs();
445 fth_set_soft_port_from_optkey(prcs, PORT_READ_CHAR);
446 fth_set_soft_port_from_optkey(prcs, PORT_READ_LINE);
447 fth_set_soft_port_from_optkey(prcs, PORT_FLUSH);
448 fth_set_soft_port_from_optkey(prcs, PORT_CLOSE);
449 port = fth_make_soft_port(prcs, name, FICL_FAM_READ);
450 ficlStackPushFTH(vm->dataStack, port);
451 }
452
453 static void
ficl_make_soft_output_port(ficlVm * vm)454 ficl_make_soft_output_port(ficlVm *vm)
455 {
456 #define h_msop "( :key args -- io ) return out soft port\n\
457 :port-name \"sndout\"\n\
458 :write-char lambda: <{ c -- }> c snd-print .stdout ;\n\
459 :write-line lambda: <{ line -- }> line snd-print .stdout ;\n\
460 make-soft-port set-*stdout* value stdout-io\n\
461 Return soft port IO object for writing. \
462 The *stdout* IO object is preserved in stdout-io for later use.\n\
463 " h_port_keywords
464 char *name;
465 FTH prcs;
466 FTH port;
467
468 name = fth_get_optkey_str(FTH_KEYWORD_PORT_NAME, "soft-port");
469 prcs = fth_init_soft_port_procs();
470 fth_set_soft_port_from_optkey(prcs, PORT_WRITE_CHAR);
471 fth_set_soft_port_from_optkey(prcs, PORT_WRITE_LINE);
472 fth_set_soft_port_from_optkey(prcs, PORT_FLUSH);
473 fth_set_soft_port_from_optkey(prcs, PORT_CLOSE);
474 port = fth_make_soft_port(prcs, name, FICL_FAM_WRITE);
475 ficlStackPushFTH(vm->dataStack, port);
476 }
477
478 int
fth_port_getc(FTH port)479 fth_port_getc(FTH port)
480 {
481 if (FTH_FALSE_P(port))
482 port = ficlVmGetPortIn(FTH_FICL_VM());
483
484 if (FTH_IO_P(port))
485 return (fth_io_getc(port));
486
487 FTH_ASSERT_ARGS(0, port, FTH_ARG1, "an open IO object or #f");
488 /* NOTREACHED */
489 return (-1);
490 }
491
492 static void
ficl_port_getc(ficlVm * vm)493 ficl_port_getc(ficlVm *vm)
494 {
495 #define h_port_getc "( prt -- c ) return next char\n\
496 #f port-getc\n\
497 1 => 49\n\
498 Return next character from PRT IO object. \
499 If PRT is #f, read from current input port (stdin).\n\
500 See also port-gets."
501 int c;
502
503 FTH_STACK_CHECK(vm, 1, 1);
504 c = fth_port_getc(fth_pop_ficl_cell(vm));
505 ficlStackPushInteger(vm->dataStack, (ficlInteger) c);
506 }
507
508 char *
fth_port_gets(FTH port)509 fth_port_gets(FTH port)
510 {
511 if (FTH_FALSE_P(port))
512 port = ficlVmGetPortIn(FTH_FICL_VM());
513
514 if (FTH_IO_P(port))
515 return (fth_io_read(port));
516
517 FTH_ASSERT_ARGS(0, port, FTH_ARG1, "an open IO object or #f");
518 /* NOTREACHED */
519 return (NULL);
520 }
521
522 static void
ficl_port_gets(ficlVm * vm)523 ficl_port_gets(ficlVm *vm)
524 {
525 #define h_port_gets "( prt -- str ) return next line\n\
526 #f port-gets\n\
527 hello => \"hello\n\"\n\
528 Return one line from PRT IO object. \
529 If PRT is #f, read from current input port (stdin).\n\
530 See also port-getc."
531 FTH_STACK_CHECK(vm, 1, 1);
532 push_cstring(vm, fth_port_gets(fth_pop_ficl_cell(vm)));
533 }
534
535 void
fth_port_putc(FTH port,int c)536 fth_port_putc(FTH port, int c)
537 {
538 if (FTH_FALSE_P(port))
539 port = ficlVmGetPortOut(FTH_FICL_VM());
540
541 if (FTH_IO_P(port)) {
542 fth_io_putc(port, c);
543 return;
544 }
545 FTH_ASSERT_ARGS(0, port, FTH_ARG1, "an open IO object or #f");
546 }
547
548 static void
ficl_port_putc(ficlVm * vm)549 ficl_port_putc(ficlVm *vm)
550 {
551 #define h_port_putc "( prt c -- ) write char\n\
552 #f <char> a port-putc => a\n\
553 #f <char> b port-putc => b\n\
554 #f <char> c port-putc => c\n\
555 Write character C to PRT IO object. \
556 If PRT is #f, write to current output port (stout).\n\
557 See also port-puts and port-puts-format."
558 int c;
559 FTH prt;
560
561 FTH_STACK_CHECK(vm, 2, 0);
562 c = (int) ficlStackPopInteger(vm->dataStack);
563 prt = fth_pop_ficl_cell(vm);
564 fth_port_putc(prt, c);
565 }
566
567 /*
568 * Put C string STR to output port PORT. If PORT is FTH_FALSE, print
569 * to standard out.
570 */
571 void
fth_port_puts(FTH port,const char * str)572 fth_port_puts(FTH port, const char *str)
573 {
574 if (FTH_FALSE_P(port))
575 port = ficlVmGetPortOut(FTH_FICL_VM());
576
577 if (FTH_IO_P(port)) {
578 fth_io_write_and_flush(port, str);
579 return;
580 }
581 FTH_ASSERT_ARGS(0, port, FTH_ARG1, "an open IO object or #f");
582 }
583
584 static void
ficl_port_puts(ficlVm * vm)585 ficl_port_puts(ficlVm *vm)
586 {
587 #define h_port_puts "( prt str -- ) write STR to PRT\n\
588 #f \"hello\" port-puts => hello\n\
589 Write STR to PRT IO object. \
590 If PRT is #f, write to current output port (stout).\n\
591 See also port-putc and port-puts-format."
592 char *str;
593 FTH prt;
594
595 FTH_STACK_CHECK(vm, 2, 0);
596 str = pop_cstring(vm);
597 prt = fth_pop_ficl_cell(vm);
598 fth_port_puts(prt, str);
599 }
600
601 static void
ficl_port_puts_format(ficlVm * vm)602 ficl_port_puts_format(ficlVm *vm)
603 {
604 #define h_port_puts_fmt "( prt fmt fmt-args -- ) write formatted line\n\
605 #f \"hello, %s\" #( \"world\" ) port-puts-format => hello, world\n\
606 Write string built from FMT and array FMT-ARGS to PRT IO object. \
607 If PRT is #f, write to current output port (stout).\n\
608 See also port-putc and port-puts."
609 FTH prt;
610 FTH fmt;
611 FTH args;
612
613 FTH_STACK_CHECK(vm, 3, 0);
614 args = fth_pop_ficl_cell(vm);
615 fmt = fth_pop_ficl_cell(vm);
616 prt = fth_pop_ficl_cell(vm);
617 fth_port_puts(prt, fth_string_ref(fth_string_format(fmt, args)));
618 }
619
620 /*
621 * Put string representation of Fth object OBJ to output port PORT.
622 * If PORT is FTH_FALSE, print to standard out.
623 */
624 void
fth_port_display(FTH port,FTH obj)625 fth_port_display(FTH port, FTH obj)
626 {
627 if (FTH_FALSE_P(port))
628 port = ficlVmGetPortOut(FTH_FICL_VM());
629
630 if (FTH_IO_P(port)) {
631 fth_io_write_and_flush(port, fth_to_c_string(obj));
632 return;
633 }
634 FTH_ASSERT_ARGS(0, port, FTH_ARG1, "an open IO object or #f");
635 }
636
637 static void
ficl_port_display(ficlVm * vm)638 ficl_port_display(ficlVm *vm)
639 {
640 #define h_port_display "( prt obj -- ) write OBJ to PRT\n\
641 #f #( 0 1 2 ) port-display => #( 0 1 2 )\n\
642 Write the string representation of OBJ to PRT object. \
643 If PRT is #f, write to current output port (stout).\n\
644 See also port-puts and port-puts-format."
645 FTH prt;
646 FTH obj;
647
648 FTH_STACK_CHECK(vm, 2, 0);
649 obj = fth_pop_ficl_cell(vm);
650 prt = fth_pop_ficl_cell(vm);
651 fth_port_display(prt, obj);
652 }
653
654 /*
655 * Return content of PORT as Fth string. If PORT is FTH_FALSE, return
656 * FTH_FALSE.
657 */
658 FTH
fth_port_to_string(FTH port)659 fth_port_to_string(FTH port)
660 {
661 if (FTH_FALSE_P(port))
662 return (FTH_FALSE);
663
664 return (fth_io_to_string(port));
665 }
666
667 static void
ficl_port_to_string(ficlVm * vm)668 ficl_port_to_string(ficlVm *vm)
669 {
670 #define h_port_to_string "( prt -- str|#f ) return PRT as string\n\
671 \".fthrc\" io-open-read value prt\n\
672 prt port->string => \"...\"\n\
673 #f port->string => #f\n\
674 Return content of PRT object as string if available, otherwise #f."
675 FTH_STACK_CHECK(vm, 1, 1);
676 fth_push_ficl_cell(vm, fth_port_to_string(fth_pop_ficl_cell(vm)));
677 }
678
679 /*
680 * Flush PORT; if PORT is FTH_FALSE, do nothing.
681 */
682 void
fth_port_flush(FTH port)683 fth_port_flush(FTH port)
684 {
685 if (FTH_FALSE_P(port))
686 return;
687
688 fth_io_flush(port);
689 }
690
691 static void
ficl_port_flush(ficlVm * vm)692 ficl_port_flush(ficlVm *vm)
693 {
694 #define h_port_flush "( prt -- ) flush PRT\n\
695 #f port-flush \\ does nothing\n\
696 File and IO ports flush their streams, other kind of ports do nothing."
697 FTH_STACK_CHECK(vm, 1, 0);
698 fth_port_flush(fth_pop_ficl_cell(vm));
699 }
700
701 /*
702 * Close PORT; if PORT is FTH_FALSE, do nothing.
703 */
704 void
fth_port_close(FTH port)705 fth_port_close(FTH port)
706 {
707 if (FTH_FALSE_P(port))
708 return;
709
710 fth_io_close(port);
711 }
712
713 static void
ficl_port_close(ficlVm * vm)714 ficl_port_close(ficlVm *vm)
715 {
716 #define h_port_close "( prt -- ) close PRT\n\
717 #f port-close \\ does nothing\n\
718 File and IO ports close their streams, other kind of ports do nothing."
719 FTH_STACK_CHECK(vm, 1, 0);
720 fth_port_close(fth_pop_ficl_cell(vm));
721 }
722
723 /* --- with-input-port, with-output-port --- */
724
725 /*-
726 * :filename filename (string)
727 * :fam r/o
728 * :command cmd (string or array-of-strings)
729 * :fam r/o
730 * :string string (string)
731 * :fam r/o
732 * :socket host (string)
733 * :domain AF_INET (AF_UNIX) (integer)
734 * :port 1024 (integer)
735 * :soft-port port name (string)
736 * :fam r/o
737 * :port-name "soft-port-name"
738 * :read-char
739 * :write-char
740 * :read-line
741 * :write-line
742 * :flush
743 * :close
744 */
745
746 /*
747 * io-open-file in io.c needs this function too.
748 */
749
750 /*-
751 * Usage:
752 *
753 * FTH io = io_keyword_args_ref(FICL_FAM_READ)
754 * FTH io = io_keyword_args_ref(
755 * fth_get_optkey_fix(FTH_KEYWORD_FAM, FICL_FAM_READ));
756 */
757 FTH
io_keyword_args_ref(int fam)758 io_keyword_args_ref(int fam)
759 {
760 FTH arg;
761
762 arg = fth_get_optkey(FTH_KEYWORD_FILENAME, FTH_UNDEF);
763
764 if (FTH_BOUND_P(arg))
765 return (fth_io_open(fth_string_ref(arg), fam));
766
767 arg = fth_get_optkey(FTH_KEYWORD_COMMAND, FTH_UNDEF);
768
769 if (FTH_BOUND_P(arg))
770 return (fth_io_popen(arg, fam));
771
772 arg = fth_get_optkey(FTH_KEYWORD_STRING, FTH_UNDEF);
773
774 if (FTH_BOUND_P(arg))
775 return (fth_io_sopen(arg, fam));
776 #if HAVE_SOCKET
777 arg = fth_get_optkey(FTH_KEYWORD_SOCKET, FTH_UNDEF);
778
779 if (FTH_BOUND_P(arg)) {
780 int d;
781 int p;
782
783 d = fth_get_optkey_fix(FTH_KEYWORD_DOMAIN, FTH_DEFAULT_ADDRFAM);
784 p = fth_get_optkey_fix(FTH_KEYWORD_PORT, FTH_DEFAULT_PORT);
785 return (fth_io_nopen(fth_string_ref(arg), p, d));
786 }
787 #endif /* HAVE_SOCKET */
788 arg = fth_get_optkey(FTH_KEYWORD_SOFT_PORT, FTH_UNDEF);
789
790 if (FTH_BOUND_P(arg)) {
791 char *name;
792 char *s;
793 FTH prcs;
794
795 s = fth_string_ref(arg);
796 name = fth_get_optkey_str(FTH_KEYWORD_PORT_NAME, s);
797 prcs = fth_init_soft_port_procs();
798 fth_set_soft_port_from_optkey(prcs, PORT_READ_CHAR);
799 fth_set_soft_port_from_optkey(prcs, PORT_WRITE_CHAR);
800 fth_set_soft_port_from_optkey(prcs, PORT_READ_LINE);
801 fth_set_soft_port_from_optkey(prcs, PORT_WRITE_LINE);
802 fth_set_soft_port_from_optkey(prcs, PORT_FLUSH);
803 fth_set_soft_port_from_optkey(prcs, PORT_CLOSE);
804 return (fth_make_soft_port(prcs, name, fam));
805 }
806 fth_throw(FTH_ARGUMENT_ERROR,
807 "%s: wrong or empty keyword args", RUNNING_WORD());
808 return (FTH_FALSE);
809 }
810
811 static void
ficl_with_input_port(ficlVm * vm)812 ficl_with_input_port(ficlVm *vm)
813 {
814 #define h_with_iport "( obj :key args -- str ) read string\n\
815 % cat file.test\n\
816 hello\n\
817 %\n\
818 lambda: <{ io -- str }> io io-read ; :filename \"file.test\" with-input-port => \"hello\n\"\n\
819 \"hello\" value s\n\
820 lambda: <{ io -- str }> io io-read ; :string s with-input-port => \"hello\"\n\
821 nil :filename \"file.test\" with-input-port => \"hello\n\"\n\
822 Open IO object for input. \
823 If OBJ is NIL, read first line from IO object, \
824 otherwise execute OBJ as a proc or xt with stack effect ( io -- str ). \
825 Close IO object and return resulting string.\n\
826 " keyword_args_string "\n\
827 See also with-output-port, with-input-from-port, with-output-to-port, \
828 with-error-to-port."
829 FTH arg;
830 FTH res;
831 FTH io;
832 FTH proc;
833
834 io = io_keyword_args_ref(FICL_FAM_READ);
835 FTH_STACK_CHECK(vm, 1, 1);
836 arg = fth_pop_ficl_cell(vm);
837
838 if (FTH_NIL_P(arg))
839 res = fth_io_read_line(io);
840 else {
841 proc = proc_from_proc_or_xt(arg, 1, 0, 0);
842 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG1, "a proc");
843 res = fth_proc_call(proc, RUNNING_WORD(), 1, io);
844 }
845 fth_io_close(io);
846 fth_push_ficl_cell(vm, res);
847 }
848
849 static void
ficl_with_output_port(ficlVm * vm)850 ficl_with_output_port(ficlVm *vm)
851 {
852 #define h_with_oport "( obj :key args -- ) write string\n\
853 lambda: <{ io -- }>\n\
854 io \"hello\\n\" io-write\n\
855 ; :filename \"file.test\" with-output-port\n\
856 % cat file.test\n\
857 hello\n\
858 %\n\
859 \"\" value s\n\
860 lambda: <{ io -- }>\n\
861 io \"hello\" io-write\n\
862 ; :string s with-output-port\n\
863 s => \"hello\"\n\
864 \"file.test\" file-delete\n\
865 \"hello\\n\" :filename \"file.test\" with-output-port\n\
866 % cat file.test\n\
867 hello\n\
868 %\n\
869 Open IO object for output. \
870 If OBJ is a string, write string to IO object, \
871 otherwise execute OBJ as proc or xt with stack effect ( io -- ). \
872 Close IO object.\n\
873 " keyword_args_string "\n\
874 See also with-input-port, with-input-from-port, with-output-to-port, \
875 with-error-to-port."
876 FTH arg;
877 FTH io;
878 FTH proc;
879
880 io = io_keyword_args_ref(FICL_FAM_WRITE);
881 FTH_STACK_CHECK(vm, 1, 1);
882 arg = fth_pop_ficl_cell(vm);
883
884 if (FTH_STRING_P(arg))
885 fth_io_write(io, fth_string_ref(arg));
886 else {
887 proc = proc_from_proc_or_xt(arg, 1, 0, 0);
888 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG1, "a proc");
889 fth_proc_call(proc, RUNNING_WORD(), 1, io);
890 }
891 fth_io_close(io);
892 }
893
894 /* --- with-input-from-port, with-output-to-port, with-error-to-port --- */
895
896 static void
ficl_with_input_from_port(ficlVm * vm)897 ficl_with_input_from_port(ficlVm *vm)
898 {
899 #define h_wifport "( obj :key args -- str ) read string\n\
900 % cat file.test\n\
901 hello\n\
902 %\n\
903 lambda: <{ -- str }>\n\
904 *stdin* io-read\n\
905 ; :filename \"file.test\" with-input-from-port => \"hello\n\"\n\
906 \"hello\" value s\n\
907 lambda: <{ -- str }>\n\
908 *stdin* io-read\n\
909 ; :string s with-input-from-port => \"hello\"\n\
910 nil :filename \"file.test\" with-input-from-port => \"hello\"\n\
911 Open IO object for input and point IO to *STDIN*. \
912 If OBJ is NIL, read first line from IO object, \
913 otherwise execute OBJ as proc or xt with stack effect ( -- str ). \
914 Close IO object and return resulting string. \
915 *STDIN* will be reset to its previous value.\n\
916 " keyword_args_string "\n\
917 See also with-input-port, with-output-port, with-output-to-port, \
918 with-error-to-port."
919 FTH arg;
920 FTH res;
921 FTH old_io;
922 FTH io;
923
924 io = io_keyword_args_ref(FICL_FAM_READ);
925 FTH_STACK_CHECK(vm, 1, 1);
926 arg = fth_pop_ficl_cell(vm);
927 old_io = fth_set_io_stdin(io);
928
929 if (FTH_NIL_P(arg))
930 res = fth_io_read_line(io);
931 else {
932 FTH proc;
933
934 proc = proc_from_proc_or_xt(arg, 0, 0, 0);
935
936 if (!FTH_PROC_P(proc)) {
937 fth_io_close(fth_set_io_stdin(old_io));
938 FTH_ASSERT_ARGS(0, proc, FTH_ARG1, "a proc");
939 }
940 res = fth_proc_call(proc, RUNNING_WORD(), 0);
941 }
942 fth_io_close(fth_set_io_stdin(old_io));
943 fth_push_ficl_cell(vm, res);
944 }
945
946 static void
ficl_with_output_to_port(ficlVm * vm)947 ficl_with_output_to_port(ficlVm *vm)
948 {
949 #define h_wotport "( obj :key args -- ) write string\n\
950 lambda: <{ -- }>\n\
951 .\" hello\" cr\n\
952 ; :filename \"file.test\" with-output-to-port\n\
953 % cat test.file\n\
954 hello\n\
955 %\n\
956 \"\" value s\n\
957 lambda: <{ -- }>\n\
958 *stdout* \"hello\" io-write\n\
959 ; :string s with-output-to-port\n\
960 s => \"hello\"\n\
961 \"file.test\" file-delete\n\
962 \"hello\\n\" :filename \"file.test\" with-output-to-port\n\
963 % cat file.test\n\
964 hello\n\
965 %\n\
966 Open IO object for output and point IO to *STDOUT*. \
967 If OBJ is a string, write string to IO object, \
968 otherwise execute OBJ as proc or xt with stack effect ( -- ). \
969 Close IO object. \
970 *STDOUT* will be reset to its previous value.\n\
971 " keyword_args_string "\n\
972 See also with-input-port, with-output-port, with-input-from-port, \
973 with-error-to-port."
974 FTH arg;
975 FTH old_io;
976 FTH io;
977
978 io = io_keyword_args_ref(FICL_FAM_WRITE);
979 FTH_STACK_CHECK(vm, 1, 1);
980 arg = fth_pop_ficl_cell(vm);
981 old_io = fth_set_io_stdout(io);
982
983 if (FTH_STRING_P(arg))
984 fth_io_write(io, fth_string_ref(arg));
985 else {
986 FTH proc;
987
988 proc = proc_from_proc_or_xt(arg, 0, 0, 0);
989
990 if (!FTH_PROC_P(proc)) {
991 fth_io_close(fth_set_io_stdout(old_io));
992 FTH_ASSERT_ARGS(0, proc, FTH_ARG1, "a proc");
993 }
994 fth_proc_call(proc, RUNNING_WORD(), 0);
995 }
996 fth_io_close(fth_set_io_stdout(old_io));
997 }
998
999 static void
ficl_with_error_to_port(ficlVm * vm)1000 ficl_with_error_to_port(ficlVm *vm)
1001 {
1002 #define h_wetport "( obj :key args -- ) write string\n\
1003 lambda: <{ -- }>\n\
1004 \"hello\\n\" .stderr\n\
1005 ; :filename \"file.test\" with-error-to-port\n\
1006 % cat test.file\n\
1007 hello\n\
1008 %\n\
1009 \"\" value s\n\
1010 lambda: <{ -- }>\n\
1011 *stderr* \"hello\" io-write\n\
1012 ; :string s with-error-to-port\n\
1013 s => \"hello\"\n\
1014 \"file.test\" file-delete\n\
1015 \"hello\\n\" :filename \"file.test\" with-error-to-port\n\
1016 % cat file.test\n\
1017 hello\n\
1018 %\n\
1019 Open IO object for output and point IO to *STDERR*. \
1020 If OBJ is a string, write string to IO object, \
1021 otherwise execute OBJ as proc or xt with stack effect ( -- ). \
1022 Close IO object. \
1023 *STDERR* will be reset to its previous value.\n\
1024 " keyword_args_string "\n\
1025 See also with-input-port, with-output-port, with-input-from-port, \
1026 with-output-to-port."
1027 FTH arg;
1028 FTH old_io;
1029 FTH io;
1030
1031 io = io_keyword_args_ref(FICL_FAM_WRITE);
1032 FTH_STACK_CHECK(vm, 1, 1);
1033 arg = fth_pop_ficl_cell(vm);
1034 old_io = fth_set_io_stderr(io);
1035
1036 if (FTH_STRING_P(arg))
1037 fth_io_write(io, fth_string_ref(arg));
1038 else {
1039 FTH proc;
1040
1041 proc = proc_from_proc_or_xt(arg, 0, 0, 0);
1042
1043 if (!FTH_PROC_P(proc)) {
1044 fth_io_close(fth_set_io_stderr(old_io));
1045 FTH_ASSERT_ARGS(0, proc, FTH_ARG1, "a proc");
1046 }
1047 fth_proc_call(proc, RUNNING_WORD(), 0);
1048 }
1049 fth_io_close(fth_set_io_stderr(old_io));
1050 }
1051
1052 /* --- in- and output callbacks --- */
1053
1054 in_cb fth_read_hook;
1055 out_cb fth_print_hook;
1056 out_cb fth_error_hook;
1057
1058 static char *
default_read_cb(ficlVm * vm)1059 default_read_cb(ficlVm *vm)
1060 {
1061 FTH io;
1062
1063 io = ficlVmGetPortIn(vm);
1064 return (FTH_IO_READ_LINE(io));
1065 }
1066
1067 static void
default_print_cb(ficlVm * vm,char * str)1068 default_print_cb(ficlVm *vm, char *str)
1069 {
1070 FTH io;
1071
1072 io = ficlVmGetPortOut(vm);
1073 FTH_IO_WRITE_LINE(io, str);
1074 FTH_IO_FLUSH(io);
1075 }
1076
1077 static void
default_error_cb(ficlVm * vm,char * str)1078 default_error_cb(ficlVm *vm, char *str)
1079 {
1080 FTH io;
1081
1082 io = ficlVmGetPortErr(vm);
1083 FTH_IO_WRITE_LINE(io, str);
1084 FTH_IO_FLUSH(io);
1085 }
1086
1087 /* char *(*out_cb)(ficlVm *vm); */
1088 in_cb
fth_set_read_cb(in_cb cb)1089 fth_set_read_cb(in_cb cb)
1090 {
1091 in_cb old_cb;
1092
1093 old_cb = fth_read_hook;
1094 fth_read_hook = (cb != NULL) ? cb : default_read_cb;
1095 return (old_cb);
1096 }
1097
1098 /* void (*out_cb)(ficlVm *vm, char *msg); */
1099 out_cb
fth_set_print_cb(out_cb cb)1100 fth_set_print_cb(out_cb cb)
1101 {
1102 out_cb old_cb;
1103
1104 old_cb = fth_print_hook;
1105 fth_print_hook = (cb != NULL) ? cb : default_print_cb;
1106 return (old_cb);
1107 }
1108
1109 out_cb
fth_set_error_cb(out_cb cb)1110 fth_set_error_cb(out_cb cb)
1111 {
1112 out_cb old_cb;
1113
1114 old_cb = fth_error_hook;
1115 fth_error_hook = (cb != NULL) ? cb : default_error_cb;
1116 return (old_cb);
1117 }
1118
1119 out_cb
fth_set_print_and_error_cb(out_cb cb)1120 fth_set_print_and_error_cb(out_cb cb)
1121 {
1122 out_cb old_cb;
1123
1124 old_cb = fth_print_hook;
1125 fth_print_hook = (cb != NULL) ? cb : default_print_cb;
1126 fth_error_hook = (cb != NULL) ? cb : default_error_cb;
1127 return (old_cb);
1128 }
1129
1130 void
init_port(void)1131 init_port(void)
1132 {
1133 #define MPFF(Name, Args) fth_make_proc_from_func(NULL, Name, 0, Args, 0, 0)
1134 #define MPFVF(Name, Args) fth_make_proc_from_vfunc(NULL, Name, Args, 0, 0)
1135 gn_read_char = MPFF(soft_read_char, 0);
1136 gn_write_char = MPFVF(soft_write_char, 1);
1137 gn_read_line = MPFF(soft_read_line, 0);
1138 gn_write_line = MPFVF(soft_write_line, 1);
1139 gn_flush = MPFVF(soft_flush, 0);
1140 gn_close = MPFVF(soft_close, 0);
1141 FTH_PRI1("port?", ficl_port_p, h_port_p);
1142 FTH_PRI1("port-input?", ficl_port_input_p, h_port_input_p);
1143 FTH_PRI1("port-output?", ficl_port_output_p, h_port_output_p);
1144 FTH_PRI1("port-closed?", ficl_port_closed_p, h_port_closed_p);
1145 FTH_PRI1("make-soft-port", ficl_make_soft_port, h_make_soft_port);
1146 FTH_PRI1("make-soft-input-port", ficl_make_soft_input_port, h_msiport);
1147 FTH_PRI1("make-soft-output-port", ficl_make_soft_output_port, h_msop);
1148 FTH_PRI1("port-getc", ficl_port_getc, h_port_getc);
1149 FTH_PRI1("port-putc", ficl_port_putc, h_port_putc);
1150 FTH_PRI1("port-gets", ficl_port_gets, h_port_gets);
1151 FTH_PRI1("port-read", ficl_port_gets, h_port_gets);
1152 FTH_PRI1("port-puts", ficl_port_puts, h_port_puts);
1153 FTH_PRI1("port-write", ficl_port_puts, h_port_puts);
1154 FTH_PRI1("port-puts-format", ficl_port_puts_format, h_port_puts_fmt);
1155 FTH_PRI1("port-write-format", ficl_port_puts_format, h_port_puts_fmt);
1156 FTH_PRI1("port-display", ficl_port_display, h_port_display);
1157 FTH_PRI1("port->string", ficl_port_to_string, h_port_to_string);
1158 FTH_PRI1("port-flush", ficl_port_flush, h_port_flush);
1159 FTH_PRI1("port-close", ficl_port_close, h_port_close);
1160 FTH_PRI1("with-input-port", ficl_with_input_port, h_with_iport);
1161 FTH_PRI1("with-output-port", ficl_with_output_port, h_with_oport);
1162 FTH_PRI1("with-input-from-port", ficl_with_input_from_port, h_wifport);
1163 FTH_PRI1("with-output-to-port", ficl_with_output_to_port, h_wotport);
1164 FTH_PRI1("with-error-to-port", ficl_with_error_to_port, h_wetport);
1165 FTH_ADD_FEATURE_AND_INFO(FTH_STR_PORT, h_list_of_port_functions);
1166 }
1167
1168 /*
1169 * port.c ends here
1170 */
1171