Commit | Line | Data |
---|---|---|
0f2d19dd JB |
1 | /* Copyright (C) 1995,1996 Free Software Foundation, Inc. |
2 | * | |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
15 | * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
16 | * | |
17 | * As a special exception, the Free Software Foundation gives permission | |
18 | * for additional uses of the text contained in its release of GUILE. | |
19 | * | |
20 | * The exception is that, if you link the GUILE library with other files | |
21 | * to produce an executable, this does not by itself cause the | |
22 | * resulting executable to be covered by the GNU General Public License. | |
23 | * Your use of that executable is in no way restricted on account of | |
24 | * linking the GUILE library code into it. | |
25 | * | |
26 | * This exception does not however invalidate any other reasons why | |
27 | * the executable file might be covered by the GNU General Public License. | |
28 | * | |
29 | * This exception applies only to the code released by the | |
30 | * Free Software Foundation under the name GUILE. If you copy | |
31 | * code from other Free Software Foundation releases into a copy of | |
32 | * GUILE, as the General Public License permits, the exception does | |
33 | * not apply to the code that you add in this way. To avoid misleading | |
34 | * anyone as to the status of such modified files, you must delete | |
35 | * this exception notice from them. | |
36 | * | |
37 | * If you write modifications of your own for GUILE, it is your choice | |
38 | * whether to permit this exception to apply to your modifications. | |
39 | * If you do not wish that, delete this exception notice. | |
40 | */ | |
41 | \f | |
42 | #include <stdio.h> | |
43 | #include "_scm.h" | |
44 | ||
45 | ||
46 | #ifdef HAVE_MALLOC_H | |
95b88819 | 47 | #include <malloc.h> |
0f2d19dd JB |
48 | #endif |
49 | ||
50 | #ifdef HAVE_UNISTD_H | |
51 | #include <unistd.h> | |
52 | #endif | |
53 | ||
95b88819 GH |
54 | #ifdef HAVE_SYS_IOCTL_H |
55 | #include <sys/ioctl.h> | |
56 | #endif | |
0f2d19dd JB |
57 | \f |
58 | ||
59 | ||
60 | /* scm_ptobs scm_numptob | |
61 | * implement a dynamicly resized array of ptob records. | |
62 | * Indexes into this table are used when generating type | |
63 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
64 | */ | |
65 | scm_ptobfuns *scm_ptobs; | |
66 | scm_sizet scm_numptob; | |
67 | ||
68 | #ifdef __STDC__ | |
69 | SCM | |
70 | scm_markstream (SCM ptr) | |
71 | #else | |
72 | SCM | |
73 | scm_markstream (ptr) | |
74 | SCM ptr; | |
75 | #endif | |
76 | { | |
77 | int openp; | |
78 | if (SCM_GC8MARKP (ptr)) | |
79 | return SCM_BOOL_F; | |
80 | openp = SCM_CAR (ptr) & SCM_OPN; | |
81 | SCM_SETGC8MARK (ptr); | |
82 | if (openp) | |
83 | return SCM_STREAM (ptr); | |
84 | else | |
85 | return SCM_BOOL_F; | |
86 | } | |
87 | ||
88 | ||
89 | #ifdef __STDC__ | |
90 | long | |
91 | scm_newptob (scm_ptobfuns *ptob) | |
92 | #else | |
93 | long | |
94 | scm_newptob (ptob) | |
95 | scm_ptobfuns *ptob; | |
96 | #endif | |
97 | { | |
98 | char *tmp; | |
99 | if (255 <= scm_numptob) | |
100 | goto ptoberr; | |
101 | SCM_DEFER_INTS; | |
102 | SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns))); | |
103 | if (tmp) | |
104 | { | |
105 | scm_ptobs = (scm_ptobfuns *) tmp; | |
106 | scm_ptobs[scm_numptob].mark = ptob->mark; | |
107 | scm_ptobs[scm_numptob].free = ptob->free; | |
108 | scm_ptobs[scm_numptob].print = ptob->print; | |
109 | scm_ptobs[scm_numptob].equalp = ptob->equalp; | |
110 | scm_ptobs[scm_numptob].fputc = ptob->fputc; | |
111 | scm_ptobs[scm_numptob].fputs = ptob->fputs; | |
112 | scm_ptobs[scm_numptob].fwrite = ptob->fwrite; | |
113 | scm_ptobs[scm_numptob].fflush = ptob->fflush; | |
114 | scm_ptobs[scm_numptob].fgetc = ptob->fgetc; | |
115 | scm_ptobs[scm_numptob].fclose = ptob->fclose; | |
116 | scm_numptob++; | |
117 | } | |
118 | SCM_ALLOW_INTS; | |
119 | if (!tmp) | |
120 | ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); | |
121 | return scm_tc7_port + (scm_numptob - 1) * 256; | |
122 | } | |
123 | ||
124 | \f | |
125 | /* internal SCM call */ | |
126 | #ifdef __STDC__ | |
127 | void | |
128 | scm_fflush (SCM port) | |
129 | #else | |
130 | void | |
131 | scm_fflush (port) | |
132 | SCM port; | |
133 | #endif | |
134 | { | |
135 | scm_sizet i = SCM_PTOBNUM (port); | |
136 | (scm_ptobs[i].fflush) (SCM_STREAM (port)); | |
137 | } | |
138 | ||
139 | \f | |
140 | ||
141 | ||
142 | #ifdef __IBMC__ | |
143 | # define MSDOS | |
144 | #endif | |
145 | #ifdef MSDOS | |
146 | # ifndef GO32 | |
147 | # include <io.h> | |
148 | # include <conio.h> | |
149 | #ifdef __STDC__ | |
150 | static int | |
151 | input_waiting (FILE *f) | |
152 | #else | |
153 | static int | |
154 | input_waiting (f) | |
155 | FILE *f; | |
156 | #endif | |
157 | { | |
158 | if (feof (f)) | |
159 | return 1; | |
160 | if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin)))) | |
161 | return kbhit (); | |
162 | return -1; | |
163 | } | |
164 | # endif | |
165 | #else | |
166 | # ifdef _DCC | |
167 | # include <ioctl.h> | |
168 | # else | |
169 | # ifndef AMIGA | |
170 | # ifndef vms | |
171 | # ifdef MWC | |
172 | # include <sys/io.h> | |
173 | # else | |
174 | # ifndef THINK_C | |
175 | # ifndef ARM_ULIB | |
176 | # include <sys/ioctl.h> | |
177 | # endif | |
178 | # endif | |
179 | # endif | |
180 | # endif | |
181 | # endif | |
182 | # endif | |
183 | ||
184 | ||
185 | #ifdef __STDC__ | |
186 | static int | |
187 | input_waiting(FILE *f) | |
188 | #else | |
189 | static int | |
190 | input_waiting(f) | |
191 | FILE *f; | |
192 | #endif | |
193 | { | |
194 | # ifdef FIONREAD | |
195 | long remir; | |
196 | if (feof(f)) return 1; | |
197 | ioctl(fileno(f), FIONREAD, &remir); | |
198 | return remir; | |
199 | # else | |
200 | return -1; | |
201 | # endif | |
202 | } | |
203 | #endif | |
204 | ||
205 | SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p); | |
206 | #ifdef __STDC__ | |
207 | SCM | |
208 | scm_char_ready_p (SCM port) | |
209 | #else | |
210 | SCM | |
211 | scm_char_ready_p (port) | |
212 | SCM port; | |
213 | #endif | |
214 | { | |
215 | if (SCM_UNBNDP (port)) | |
216 | port = scm_cur_inp; | |
217 | else | |
218 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p); | |
219 | if (SCM_CRDYP (port) || !SCM_FPORTP (port)) | |
220 | return SCM_BOOL_T; | |
221 | return input_waiting ((FILE *)SCM_STREAM (port)) ? SCM_BOOL_T : SCM_BOOL_F; | |
222 | } | |
223 | ||
224 | ||
225 | \f | |
226 | ||
227 | SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p); | |
228 | #ifdef __STDC__ | |
229 | SCM | |
230 | scm_ungetc_char_ready_p (SCM port) | |
231 | #else | |
232 | SCM | |
233 | scm_ungetc_char_ready_p (port) | |
234 | SCM port; | |
235 | #endif | |
236 | { | |
237 | if (SCM_UNBNDP (port)) | |
238 | port = scm_cur_inp; | |
239 | else | |
240 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p); | |
241 | return (SCM_CRDYP (port) | |
242 | ? SCM_BOOL_T | |
243 | : SCM_BOOL_F); | |
244 | } | |
245 | ||
246 | ||
247 | \f | |
248 | ||
249 | ||
250 | /* {Standard Ports} | |
251 | */ | |
252 | SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); | |
253 | #ifdef __STDC__ | |
254 | SCM | |
255 | scm_current_input_port (void) | |
256 | #else | |
257 | SCM | |
258 | scm_current_input_port () | |
259 | #endif | |
260 | { | |
261 | return scm_cur_inp; | |
262 | } | |
263 | ||
264 | SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); | |
265 | #ifdef __STDC__ | |
266 | SCM | |
267 | scm_current_output_port (void) | |
268 | #else | |
269 | SCM | |
270 | scm_current_output_port () | |
271 | #endif | |
272 | { | |
273 | return scm_cur_outp; | |
274 | } | |
275 | ||
276 | SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); | |
277 | #ifdef __STDC__ | |
278 | SCM | |
279 | scm_current_error_port (void) | |
280 | #else | |
281 | SCM | |
282 | scm_current_error_port () | |
283 | #endif | |
284 | { | |
285 | return scm_cur_errp; | |
286 | } | |
287 | ||
288 | SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); | |
289 | #ifdef __STDC__ | |
290 | SCM | |
291 | scm_set_current_input_port (SCM port) | |
292 | #else | |
293 | SCM | |
294 | scm_set_current_input_port (port) | |
295 | SCM port; | |
296 | #endif | |
297 | { | |
298 | SCM oinp = scm_cur_inp; | |
299 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); | |
300 | scm_cur_inp = port; | |
301 | return oinp; | |
302 | } | |
303 | ||
304 | ||
305 | SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); | |
306 | #ifdef __STDC__ | |
307 | SCM | |
308 | scm_set_current_output_port (SCM port) | |
309 | #else | |
310 | SCM | |
311 | scm_set_current_output_port (port) | |
312 | SCM port; | |
313 | #endif | |
314 | { | |
315 | SCM ooutp = scm_cur_outp; | |
316 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); | |
317 | scm_cur_outp = port; | |
318 | return ooutp; | |
319 | } | |
320 | ||
321 | ||
322 | SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); | |
323 | #ifdef __STDC__ | |
324 | SCM | |
325 | scm_set_current_error_port (SCM port) | |
326 | #else | |
327 | SCM | |
328 | scm_set_current_error_port (port) | |
329 | SCM port; | |
330 | #endif | |
331 | { | |
332 | SCM oerrp = scm_cur_errp; | |
333 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); | |
334 | scm_cur_errp = port; | |
335 | return oerrp; | |
336 | } | |
337 | ||
338 | \f | |
339 | ||
340 | /* {Ports - in general} | |
341 | * | |
342 | */ | |
343 | ||
344 | /* Array of open ports, required for reliable MOVE->FDES etc. */ | |
345 | struct scm_port_table **scm_port_table; | |
346 | ||
347 | int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ | |
348 | int scm_port_table_room = 20; /* Size of the array. */ | |
349 | ||
350 | /* Add a port to the table. Call with SCM_DEFER_INTS active. */ | |
351 | #ifdef __STDC__ | |
352 | struct scm_port_table * | |
353 | scm_add_to_port_table (SCM port) | |
354 | #else | |
355 | struct scm_port_table * | |
356 | scm_add_to_port_table (port) | |
357 | SCM port; | |
358 | #endif | |
359 | { | |
360 | if (scm_port_table_size == scm_port_table_room) | |
361 | { | |
362 | scm_port_table = ((struct scm_port_table **) | |
363 | realloc ((char *) scm_port_table, | |
364 | (long) (sizeof (struct scm_port_table) | |
365 | * scm_port_table_room * 2))); | |
366 | /* !!! error checking */ | |
367 | scm_port_table_room *= 2; | |
368 | } | |
369 | scm_port_table[scm_port_table_size] = ((struct scm_port_table *) | |
370 | scm_must_malloc (sizeof (struct scm_port_table), | |
371 | "system port table")); | |
372 | scm_port_table[scm_port_table_size]->port = port; | |
373 | scm_port_table[scm_port_table_size]->revealed = 0; | |
374 | scm_port_table[scm_port_table_size]->stream = 0; | |
375 | scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F; | |
376 | scm_port_table[scm_port_table_size]->line_number = 1; | |
377 | scm_port_table[scm_port_table_size]->column_number = 0; | |
378 | scm_port_table[scm_port_table_size]->representation = scm_regular_port; | |
379 | return scm_port_table[scm_port_table_size++]; | |
380 | } | |
381 | ||
382 | /* Remove a port from the table. Call with SCM_DEFER_INTS active. */ | |
383 | #ifdef __STDC__ | |
384 | void | |
385 | scm_remove_from_port_table (SCM port) | |
386 | #else | |
387 | void | |
388 | scm_remove_from_port_table (port) | |
389 | SCM port; | |
390 | #endif | |
391 | { | |
392 | int i = 0; | |
393 | while (scm_port_table[i]->port != port) | |
394 | { | |
395 | i++; | |
396 | /* Error if not found: too violent? May occur in GC. */ | |
397 | if (i >= scm_port_table_size) | |
398 | scm_wta (port, "Port not in table", "scm_remove_from_port_table"); | |
399 | } | |
400 | scm_must_free ((char *)scm_port_table[i]); | |
401 | scm_mallocated -= sizeof (*scm_port_table[i]); | |
402 | scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; | |
403 | SCM_SETPTAB_ENTRY (port, 0); | |
404 | scm_port_table_size--; | |
405 | } | |
406 | ||
407 | #ifdef DEBUG | |
408 | /* Undocumented functions for debugging. */ | |
409 | /* Return the number of ports in the table. */ | |
410 | static char s_pt_size[] = "pt-size"; | |
411 | #ifdef __STDC__ | |
412 | SCM | |
413 | scm_pt_size (void) | |
414 | #else | |
415 | SCM | |
416 | scm_pt_size () | |
417 | #endif | |
418 | { | |
419 | return SCM_MAKINUM (scm_port_table_size); | |
420 | } | |
421 | ||
422 | /* Return the ith member of the port table. */ | |
423 | static char s_pt_member[] = "pt-member"; | |
424 | #ifdef __STDC__ | |
425 | SCM | |
426 | scm_pt_member (SCM member) | |
427 | #else | |
428 | SCM | |
429 | scm_pt_member (member) | |
430 | SCM member; | |
431 | #endif | |
432 | { | |
433 | int i; | |
434 | SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); | |
435 | i = SCM_INUM (member); | |
436 | if (i < 0 || i >= scm_port_table_size) | |
437 | return SCM_BOOL_F; | |
438 | else | |
439 | return scm_port_table[i]->port; | |
440 | } | |
441 | #endif | |
442 | ||
443 | ||
8b13c6b3 GH |
444 | /* Find a port in the table and return its revealed count. |
445 | Also used by the garbage collector. | |
0f2d19dd JB |
446 | */ |
447 | #ifdef __STDC__ | |
448 | int | |
449 | scm_revealed_count (SCM port) | |
450 | #else | |
451 | int | |
452 | scm_revealed_count (port) | |
453 | SCM port; | |
454 | #endif | |
455 | { | |
456 | return SCM_REVEALED(port); | |
457 | } | |
458 | ||
459 | ||
460 | ||
461 | /* Return the revealed count for a port. */ | |
462 | ||
463 | SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); | |
464 | #ifdef __STDC__ | |
465 | SCM | |
466 | scm_port_revealed (SCM port) | |
467 | #else | |
468 | SCM | |
469 | scm_port_revealed (port) | |
470 | SCM port; | |
471 | #endif | |
472 | { | |
0f2d19dd | 473 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); |
8b13c6b3 | 474 | return SCM_MAKINUM (scm_revealed_count (port)); |
0f2d19dd JB |
475 | } |
476 | ||
477 | /* Set the revealed count for a port. */ | |
478 | SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); | |
479 | #ifdef __STDC__ | |
480 | SCM | |
481 | scm_set_port_revealed_x (SCM port, SCM rcount) | |
482 | #else | |
483 | SCM | |
484 | scm_set_port_revealed_x (port, rcount) | |
485 | SCM port; | |
486 | SCM rcount; | |
487 | #endif | |
488 | { | |
489 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); | |
490 | SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); | |
491 | SCM_DEFER_INTS; | |
492 | SCM_REVEALED (port) = SCM_INUM (rcount); | |
493 | SCM_ALLOW_INTS; | |
8b13c6b3 | 494 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
495 | } |
496 | ||
497 | /* scm_close_port | |
498 | * Call the close operation on a port object. | |
499 | */ | |
500 | SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); | |
501 | #ifdef __STDC__ | |
502 | SCM | |
503 | scm_close_port (SCM port) | |
504 | #else | |
505 | SCM | |
506 | scm_close_port (port) | |
507 | SCM port; | |
508 | #endif | |
509 | { | |
510 | scm_sizet i; | |
511 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port); | |
512 | if (SCM_CLOSEDP (port)) | |
513 | return SCM_UNSPECIFIED; | |
514 | i = SCM_PTOBNUM (port); | |
515 | SCM_DEFER_INTS; | |
516 | if (scm_ptobs[i].fclose) | |
517 | SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port))); | |
518 | scm_remove_from_port_table (port); | |
519 | SCM_CAR (port) &= ~SCM_OPN; | |
520 | SCM_ALLOW_INTS; | |
521 | return SCM_UNSPECIFIED; | |
522 | } | |
523 | ||
524 | SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); | |
525 | #ifdef __STDC__ | |
526 | SCM | |
527 | scm_close_all_ports_except (SCM ports) | |
528 | #else | |
529 | SCM | |
530 | scm_close_all_ports_except (ports) | |
531 | SCM ports; | |
532 | #endif | |
533 | { | |
534 | int i = 0; | |
535 | SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); | |
536 | SCM_DEFER_INTS; | |
537 | while (i < scm_port_table_size) | |
538 | { | |
539 | SCM thisport = scm_port_table[i]->port; | |
540 | int found = 0; | |
541 | SCM ports_ptr = ports; | |
542 | ||
543 | while (SCM_NNULLP (ports_ptr)) | |
544 | { | |
545 | SCM port = SCM_CAR (ports_ptr); | |
546 | if (i == 0) | |
547 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); | |
548 | if (port == thisport) | |
549 | found = 1; | |
550 | ports_ptr = SCM_CDR (ports_ptr); | |
551 | } | |
552 | if (found) | |
553 | i++; | |
554 | else | |
555 | /* i is not to be incremented here. */ | |
556 | scm_close_port (thisport); | |
557 | } | |
558 | SCM_ALLOW_INTS; | |
559 | return SCM_UNSPECIFIED; | |
560 | } | |
561 | ||
562 | SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); | |
563 | #ifdef __STDC__ | |
564 | SCM | |
565 | scm_input_port_p (SCM x) | |
566 | #else | |
567 | SCM | |
568 | scm_input_port_p (x) | |
569 | SCM x; | |
570 | #endif | |
571 | { | |
572 | if (SCM_IMP (x)) | |
573 | return SCM_BOOL_F; | |
574 | return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
575 | } | |
576 | ||
577 | SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); | |
578 | #ifdef __STDC__ | |
579 | SCM | |
580 | scm_output_port_p (SCM x) | |
581 | #else | |
582 | SCM | |
583 | scm_output_port_p (x) | |
584 | SCM x; | |
585 | #endif | |
586 | { | |
587 | if (SCM_IMP (x)) | |
588 | return SCM_BOOL_F; | |
589 | return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
590 | } | |
591 | ||
592 | ||
593 | SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); | |
594 | #ifdef __STDC__ | |
595 | SCM | |
596 | scm_eof_object_p (SCM x) | |
597 | #else | |
598 | SCM | |
599 | scm_eof_object_p (x) | |
600 | SCM x; | |
601 | #endif | |
602 | { | |
603 | return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F; | |
604 | } | |
605 | ||
606 | SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); | |
607 | #ifdef __STDC__ | |
608 | SCM | |
609 | scm_force_output (SCM port) | |
610 | #else | |
611 | SCM | |
612 | scm_force_output (port) | |
613 | SCM port; | |
614 | #endif | |
615 | { | |
616 | if (SCM_UNBNDP (port)) | |
617 | port = scm_cur_outp; | |
618 | else | |
619 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output); | |
620 | { | |
621 | scm_sizet i = SCM_PTOBNUM (port); | |
622 | SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port))); | |
623 | return SCM_UNSPECIFIED; | |
624 | } | |
625 | } | |
626 | ||
627 | ||
628 | SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); | |
629 | #ifdef __STDC__ | |
630 | SCM | |
631 | scm_read_char (SCM port) | |
632 | #else | |
633 | SCM | |
634 | scm_read_char (port) | |
635 | SCM port; | |
636 | #endif | |
637 | { | |
638 | int c; | |
639 | if (SCM_UNBNDP (port)) | |
640 | port = scm_cur_inp; | |
641 | else | |
642 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); | |
643 | c = scm_gen_getc (port); | |
644 | if (EOF == c) | |
645 | return SCM_EOF_VAL; | |
646 | return SCM_MAKICHR (c); | |
647 | } | |
648 | ||
649 | ||
650 | SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); | |
651 | #ifdef __STDC__ | |
652 | SCM | |
653 | scm_peek_char (SCM port) | |
654 | #else | |
655 | SCM | |
656 | scm_peek_char (port) | |
657 | SCM port; | |
658 | #endif | |
659 | { | |
660 | int c; | |
661 | if (SCM_UNBNDP (port)) | |
662 | port = scm_cur_inp; | |
663 | else | |
664 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); | |
665 | c = scm_gen_getc (port); | |
666 | if (EOF == c) | |
667 | return SCM_EOF_VAL; | |
668 | scm_gen_ungetc (c, port); | |
669 | return SCM_MAKICHR (c); | |
670 | } | |
671 | ||
672 | SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); | |
673 | #ifdef __STDC__ | |
674 | SCM | |
675 | scm_unread_char (SCM cobj, SCM port) | |
676 | #else | |
677 | SCM | |
678 | scm_unread_char (cobj, port) | |
679 | SCM cobj; | |
680 | SCM port; | |
681 | #endif | |
682 | { | |
683 | int c; | |
684 | ||
685 | SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); | |
686 | ||
687 | if (SCM_UNBNDP (port)) | |
688 | port = scm_cur_inp; | |
689 | else | |
690 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); | |
691 | ||
692 | ||
693 | c = SCM_ICHR (cobj); | |
694 | ||
695 | scm_gen_ungetc (c, port); | |
696 | return cobj; | |
697 | } | |
698 | ||
699 | ||
700 | ||
701 | SCM_PROC (s_line_number, "line-number", 0, 1, 0, scm_line_number); | |
702 | #ifdef __STDC__ | |
703 | SCM | |
704 | scm_line_number (SCM port) | |
705 | #else | |
706 | SCM | |
707 | scm_line_number (port) | |
708 | SCM port; | |
709 | #endif | |
710 | { | |
711 | SCM p; | |
712 | p = ((port == SCM_UNDEFINED) | |
713 | ? scm_cur_inp | |
714 | : port); | |
715 | if (!(SCM_NIMP (p) && SCM_PORTP (p))) | |
716 | return SCM_BOOL_F; | |
717 | else | |
718 | return SCM_MAKINUM (SCM_LINUM (p)); | |
719 | } | |
720 | ||
721 | SCM_PROC (s_column_number, "column-number", 0, 1, 0, scm_column_number); | |
722 | #ifdef __STDC__ | |
723 | SCM | |
724 | scm_column_number (SCM port) | |
725 | #else | |
726 | SCM | |
727 | scm_column_number (port) | |
728 | SCM port; | |
729 | #endif | |
730 | { | |
731 | SCM p; | |
732 | p = ((port == SCM_UNDEFINED) | |
733 | ? scm_cur_inp | |
734 | : port); | |
735 | if (!(SCM_NIMP (p) && SCM_PORTP (p))) | |
736 | return SCM_BOOL_F; | |
737 | else | |
738 | return SCM_MAKINUM (SCM_COL (p)); | |
739 | } | |
740 | ||
741 | /* !!! dubious feature */ | |
742 | SCM_PROC (s_port_file_name, "port-file-name", 0, 1, 0, scm_port_file_name); | |
743 | #ifdef __STDC__ | |
744 | SCM | |
745 | scm_port_file_name (SCM port) | |
746 | #else | |
747 | SCM | |
748 | scm_port_file_name (port) | |
749 | SCM port; | |
750 | #endif | |
751 | { | |
752 | SCM p; | |
753 | p = ((port == SCM_UNDEFINED) | |
754 | ? scm_cur_inp | |
755 | : port); | |
756 | if (!(SCM_NIMP (p) && SCM_PORTP (p))) | |
757 | return SCM_BOOL_F; | |
758 | else | |
759 | return SCM_PTAB_ENTRY (p)->file_name; | |
760 | } | |
761 | ||
762 | #ifndef ttyname | |
763 | extern char * ttyname(); | |
764 | #endif | |
765 | ||
766 | #ifdef __STDC__ | |
767 | void | |
768 | scm_prinport (SCM exp, SCM port, char *type) | |
769 | #else | |
770 | void | |
771 | scm_prinport (exp, port, type) | |
772 | SCM exp; | |
773 | SCM port; | |
774 | char *type; | |
775 | #endif | |
776 | { | |
777 | scm_gen_puts (scm_regular_string, "#<", port); | |
778 | if (SCM_CLOSEDP (exp)) | |
779 | scm_gen_puts (scm_regular_string, "closed: ", port); | |
780 | else | |
781 | { | |
782 | if (SCM_RDNG & SCM_CAR (exp)) | |
783 | scm_gen_puts (scm_regular_string, "input: ", port); | |
784 | if (SCM_WRTNG & SCM_CAR (exp)) | |
785 | scm_gen_puts (scm_regular_string, "output: ", port); | |
786 | } | |
787 | scm_gen_puts (scm_regular_string, type, port); | |
788 | scm_gen_putc (' ', port); | |
789 | #ifndef MSDOS | |
790 | #ifndef __EMX__ | |
791 | #ifndef _DCC | |
792 | #ifndef AMIGA | |
793 | #ifndef THINK_C | |
794 | if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) | |
795 | scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); | |
796 | else | |
797 | #endif | |
798 | #endif | |
799 | #endif | |
800 | #endif | |
801 | #endif | |
802 | if (SCM_OPFPORTP (exp)) | |
803 | scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); | |
804 | else | |
805 | scm_intprint (SCM_CDR (exp), 16, port); | |
806 | scm_gen_putc ('>', port); | |
807 | } | |
808 | ||
809 | #ifdef __STDC__ | |
810 | void | |
811 | scm_ports_prehistory (void) | |
812 | #else | |
813 | void | |
814 | scm_ports_prehistory () | |
815 | #endif | |
816 | { | |
817 | scm_numptob = 0; | |
818 | scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); | |
819 | ||
820 | /* WARNING: These scm_newptob calls must be done in this order. | |
821 | * They must agree with the port declarations in tags.h. | |
822 | */ | |
823 | /* scm_tc16_fport = */ scm_newptob (&scm_fptob); | |
824 | /* scm_tc16_pipe = */ scm_newptob (&scm_pipob); | |
825 | /* scm_tc16_strport = */ scm_newptob (&scm_stptob); | |
826 | /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); | |
827 | } | |
828 | \f | |
829 | ||
830 | \f | |
831 | /* {Void Ports} | |
832 | */ | |
833 | ||
834 | int scm_tc16_void_port = 0; | |
835 | ||
836 | static int | |
837 | print_void_port (exp, port, writing) | |
838 | SCM exp; | |
839 | SCM port; | |
840 | int writing; | |
841 | { | |
842 | scm_prinport (exp, port, "void"); | |
843 | return 1; | |
844 | } | |
845 | ||
846 | static int | |
847 | putc_void_port (c, strm) | |
848 | int c; | |
849 | SCM strm; | |
850 | { | |
851 | return 0; /* vestigial return value */ | |
852 | } | |
853 | ||
854 | static int | |
855 | puts_void_port (s, strm) | |
856 | char * s; | |
857 | SCM strm; | |
858 | { | |
859 | return 0; /* vestigial return value */ | |
860 | } | |
861 | ||
862 | static scm_sizet | |
863 | write_void_port (ptr, size, nitems, strm) | |
864 | void * ptr; | |
865 | int size; | |
866 | int nitems; | |
867 | SCM strm; | |
868 | { | |
869 | int len; | |
870 | len = size * nitems; | |
871 | return len; | |
872 | } | |
873 | ||
874 | #ifdef __STDC__ | |
875 | static int | |
876 | flush_void_port (SCM strm) | |
877 | #else | |
878 | static int | |
879 | flush_void_port (strm) | |
880 | SCM strm; | |
881 | #endif | |
882 | { | |
883 | return 0; | |
884 | } | |
885 | ||
886 | #ifdef __STDC__ | |
887 | static int | |
888 | getc_void_port (SCM strm) | |
889 | #else | |
890 | static int | |
891 | getc_void_port (strm) | |
892 | SCM strm; | |
893 | #endif | |
894 | { | |
895 | return EOF; | |
896 | } | |
897 | ||
898 | #ifdef __STDC__ | |
899 | static int | |
900 | close_void_port (SCM strm) | |
901 | #else | |
902 | static int | |
903 | close_void_port (strm) | |
904 | SCM strm; | |
905 | #endif | |
906 | { | |
907 | return 0; /* this is ignored by scm_close_port. */ | |
908 | } | |
909 | ||
910 | ||
911 | #ifdef __STDC__ | |
912 | static int | |
913 | noop0 (FILE *stream) | |
914 | #else | |
915 | static int | |
916 | noop0 (stream) | |
917 | FILE *stream; | |
918 | #endif | |
919 | { | |
920 | return 0; | |
921 | } | |
922 | ||
923 | ||
924 | static struct scm_ptobfuns void_port_ptob = | |
925 | { | |
926 | scm_mark0, | |
927 | noop0, | |
928 | print_void_port, | |
929 | 0, /* equal? */ | |
930 | putc_void_port, | |
931 | puts_void_port, | |
932 | write_void_port, | |
933 | flush_void_port, | |
934 | getc_void_port, | |
935 | close_void_port, | |
936 | }; | |
937 | ||
938 | \f | |
939 | ||
940 | #ifdef __STDC__ | |
941 | SCM | |
942 | scm_void_port (char * mode_str) | |
943 | #else | |
944 | SCM | |
945 | scm_void_port (mode_str) | |
946 | char * mode_str; | |
947 | #endif | |
948 | { | |
949 | int mode_bits; | |
950 | SCM answer; | |
951 | struct scm_port_table * pt; | |
952 | ||
953 | SCM_NEWCELL (answer); | |
954 | SCM_DEFER_INTS; | |
955 | mode_bits = scm_mode_bits (mode_str); | |
956 | pt = scm_add_to_port_table (answer); | |
957 | SCM_CAR (answer) = scm_tc16_void_port | mode_bits; | |
958 | SCM_SETPTAB_ENTRY (answer, pt); | |
959 | SCM_SETSTREAM (answer, SCM_BOOL_F); | |
960 | SCM_ALLOW_INTS; | |
961 | return answer; | |
962 | } | |
963 | ||
964 | ||
965 | SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); | |
966 | #ifdef __STDC__ | |
967 | SCM | |
968 | scm_sys_make_void_port (SCM mode) | |
969 | #else | |
970 | SCM | |
971 | scm_sys_make_void_port (mode) | |
972 | SCM mode; | |
973 | #endif | |
974 | { | |
975 | SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode, | |
976 | SCM_ARG1, s_sys_make_void_port); | |
977 | ||
978 | return scm_void_port (SCM_ROCHARS (mode)); | |
979 | } | |
980 | ||
981 | ||
982 | ||
983 | \f | |
984 | ||
985 | #ifdef __STDC__ | |
986 | void | |
987 | scm_init_ports (void) | |
988 | #else | |
989 | void | |
990 | scm_init_ports () | |
991 | #endif | |
992 | { | |
993 | scm_tc16_void_port = scm_newptob (&void_port_ptob); | |
994 | #include "ports.x" | |
995 | } | |
996 |