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