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" | |
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" | |
52 | ||
53 | #include "ports.h" | |
0f2d19dd JB |
54 | |
55 | #ifdef HAVE_MALLOC_H | |
95b88819 | 56 | #include <malloc.h> |
0f2d19dd JB |
57 | #endif |
58 | ||
59 | #ifdef HAVE_UNISTD_H | |
60 | #include <unistd.h> | |
61 | #endif | |
62 | ||
95b88819 GH |
63 | #ifdef HAVE_SYS_IOCTL_H |
64 | #include <sys/ioctl.h> | |
65 | #endif | |
0f2d19dd JB |
66 | \f |
67 | ||
68 | ||
69 | /* scm_ptobs scm_numptob | |
70 | * implement a dynamicly resized array of ptob records. | |
71 | * Indexes into this table are used when generating type | |
72 | * tags for smobjects (if you know a tag you can get an index and conversely). | |
73 | */ | |
74 | scm_ptobfuns *scm_ptobs; | |
75 | scm_sizet scm_numptob; | |
76 | ||
1cc91f1b | 77 | |
0f2d19dd JB |
78 | SCM |
79 | scm_markstream (ptr) | |
80 | SCM ptr; | |
0f2d19dd JB |
81 | { |
82 | int openp; | |
83 | if (SCM_GC8MARKP (ptr)) | |
84 | return SCM_BOOL_F; | |
85 | openp = SCM_CAR (ptr) & SCM_OPN; | |
86 | SCM_SETGC8MARK (ptr); | |
87 | if (openp) | |
88 | return SCM_STREAM (ptr); | |
89 | else | |
90 | return SCM_BOOL_F; | |
91 | } | |
92 | ||
93 | ||
1cc91f1b | 94 | |
0f2d19dd JB |
95 | long |
96 | scm_newptob (ptob) | |
97 | scm_ptobfuns *ptob; | |
0f2d19dd JB |
98 | { |
99 | char *tmp; | |
100 | if (255 <= scm_numptob) | |
101 | goto ptoberr; | |
102 | SCM_DEFER_INTS; | |
103 | SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns))); | |
104 | if (tmp) | |
105 | { | |
106 | scm_ptobs = (scm_ptobfuns *) tmp; | |
107 | scm_ptobs[scm_numptob].mark = ptob->mark; | |
108 | scm_ptobs[scm_numptob].free = ptob->free; | |
109 | scm_ptobs[scm_numptob].print = ptob->print; | |
110 | scm_ptobs[scm_numptob].equalp = ptob->equalp; | |
111 | scm_ptobs[scm_numptob].fputc = ptob->fputc; | |
112 | scm_ptobs[scm_numptob].fputs = ptob->fputs; | |
113 | scm_ptobs[scm_numptob].fwrite = ptob->fwrite; | |
114 | scm_ptobs[scm_numptob].fflush = ptob->fflush; | |
115 | scm_ptobs[scm_numptob].fgetc = ptob->fgetc; | |
116 | scm_ptobs[scm_numptob].fclose = ptob->fclose; | |
117 | scm_numptob++; | |
118 | } | |
119 | SCM_ALLOW_INTS; | |
120 | if (!tmp) | |
121 | ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); | |
122 | return scm_tc7_port + (scm_numptob - 1) * 256; | |
123 | } | |
124 | ||
125 | \f | |
126 | /* internal SCM call */ | |
1cc91f1b | 127 | |
0f2d19dd JB |
128 | void |
129 | scm_fflush (port) | |
130 | SCM port; | |
0f2d19dd JB |
131 | { |
132 | scm_sizet i = SCM_PTOBNUM (port); | |
133 | (scm_ptobs[i].fflush) (SCM_STREAM (port)); | |
134 | } | |
135 | ||
136 | \f | |
137 | ||
0f2d19dd | 138 | SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p); |
1cc91f1b | 139 | |
0f2d19dd JB |
140 | SCM |
141 | scm_char_ready_p (port) | |
142 | SCM port; | |
0f2d19dd JB |
143 | { |
144 | if (SCM_UNBNDP (port)) | |
145 | port = scm_cur_inp; | |
146 | else | |
147 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p); | |
148 | if (SCM_CRDYP (port) || !SCM_FPORTP (port)) | |
149 | return SCM_BOOL_T; | |
5d09ff4e MD |
150 | return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p) |
151 | ? SCM_BOOL_T | |
152 | : SCM_BOOL_F); | |
0f2d19dd JB |
153 | } |
154 | ||
155 | ||
156 | \f | |
157 | ||
158 | SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p); | |
1cc91f1b | 159 | |
0f2d19dd JB |
160 | SCM |
161 | scm_ungetc_char_ready_p (port) | |
162 | SCM port; | |
0f2d19dd JB |
163 | { |
164 | if (SCM_UNBNDP (port)) | |
165 | port = scm_cur_inp; | |
166 | else | |
167 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p); | |
168 | return (SCM_CRDYP (port) | |
169 | ? SCM_BOOL_T | |
170 | : SCM_BOOL_F); | |
171 | } | |
172 | ||
173 | ||
174 | \f | |
175 | ||
176 | ||
177 | /* {Standard Ports} | |
178 | */ | |
179 | SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); | |
1cc91f1b | 180 | |
0f2d19dd JB |
181 | SCM |
182 | scm_current_input_port () | |
0f2d19dd JB |
183 | { |
184 | return scm_cur_inp; | |
185 | } | |
186 | ||
187 | SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); | |
1cc91f1b | 188 | |
0f2d19dd JB |
189 | SCM |
190 | scm_current_output_port () | |
0f2d19dd JB |
191 | { |
192 | return scm_cur_outp; | |
193 | } | |
194 | ||
195 | SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); | |
1cc91f1b | 196 | |
0f2d19dd JB |
197 | SCM |
198 | scm_current_error_port () | |
0f2d19dd JB |
199 | { |
200 | return scm_cur_errp; | |
201 | } | |
202 | ||
203 | SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); | |
1cc91f1b | 204 | |
0f2d19dd JB |
205 | SCM |
206 | scm_set_current_input_port (port) | |
207 | SCM port; | |
0f2d19dd JB |
208 | { |
209 | SCM oinp = scm_cur_inp; | |
210 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); | |
211 | scm_cur_inp = port; | |
212 | return oinp; | |
213 | } | |
214 | ||
215 | ||
216 | SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); | |
1cc91f1b | 217 | |
0f2d19dd JB |
218 | SCM |
219 | scm_set_current_output_port (port) | |
220 | SCM port; | |
0f2d19dd JB |
221 | { |
222 | SCM ooutp = scm_cur_outp; | |
223 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); | |
224 | scm_cur_outp = port; | |
225 | return ooutp; | |
226 | } | |
227 | ||
228 | ||
229 | SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); | |
1cc91f1b | 230 | |
0f2d19dd JB |
231 | SCM |
232 | scm_set_current_error_port (port) | |
233 | SCM port; | |
0f2d19dd JB |
234 | { |
235 | SCM oerrp = scm_cur_errp; | |
236 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); | |
237 | scm_cur_errp = port; | |
238 | return oerrp; | |
239 | } | |
240 | ||
241 | \f | |
242 | ||
243 | /* {Ports - in general} | |
244 | * | |
245 | */ | |
246 | ||
247 | /* Array of open ports, required for reliable MOVE->FDES etc. */ | |
248 | struct scm_port_table **scm_port_table; | |
249 | ||
250 | int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ | |
251 | int scm_port_table_room = 20; /* Size of the array. */ | |
252 | ||
253 | /* Add a port to the table. Call with SCM_DEFER_INTS active. */ | |
1cc91f1b | 254 | |
0f2d19dd JB |
255 | struct scm_port_table * |
256 | scm_add_to_port_table (port) | |
257 | SCM port; | |
0f2d19dd JB |
258 | { |
259 | if (scm_port_table_size == scm_port_table_room) | |
260 | { | |
261 | scm_port_table = ((struct scm_port_table **) | |
262 | realloc ((char *) scm_port_table, | |
263 | (long) (sizeof (struct scm_port_table) | |
264 | * scm_port_table_room * 2))); | |
265 | /* !!! error checking */ | |
266 | scm_port_table_room *= 2; | |
267 | } | |
268 | scm_port_table[scm_port_table_size] = ((struct scm_port_table *) | |
269 | scm_must_malloc (sizeof (struct scm_port_table), | |
270 | "system port table")); | |
271 | scm_port_table[scm_port_table_size]->port = port; | |
272 | scm_port_table[scm_port_table_size]->revealed = 0; | |
273 | scm_port_table[scm_port_table_size]->stream = 0; | |
ebf7394e | 274 | scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F; |
0f2d19dd JB |
275 | scm_port_table[scm_port_table_size]->line_number = 1; |
276 | scm_port_table[scm_port_table_size]->column_number = 0; | |
277 | scm_port_table[scm_port_table_size]->representation = scm_regular_port; | |
278 | return scm_port_table[scm_port_table_size++]; | |
279 | } | |
280 | ||
281 | /* Remove a port from the table. Call with SCM_DEFER_INTS active. */ | |
1cc91f1b | 282 | |
0f2d19dd JB |
283 | void |
284 | scm_remove_from_port_table (port) | |
285 | SCM port; | |
0f2d19dd JB |
286 | { |
287 | int i = 0; | |
288 | while (scm_port_table[i]->port != port) | |
289 | { | |
290 | i++; | |
291 | /* Error if not found: too violent? May occur in GC. */ | |
292 | if (i >= scm_port_table_size) | |
293 | scm_wta (port, "Port not in table", "scm_remove_from_port_table"); | |
294 | } | |
295 | scm_must_free ((char *)scm_port_table[i]); | |
296 | scm_mallocated -= sizeof (*scm_port_table[i]); | |
297 | scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; | |
298 | SCM_SETPTAB_ENTRY (port, 0); | |
299 | scm_port_table_size--; | |
300 | } | |
301 | ||
302 | #ifdef DEBUG | |
303 | /* Undocumented functions for debugging. */ | |
304 | /* Return the number of ports in the table. */ | |
1cc91f1b | 305 | |
1146b6cd | 306 | SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size); |
0f2d19dd JB |
307 | SCM |
308 | scm_pt_size () | |
0f2d19dd JB |
309 | { |
310 | return SCM_MAKINUM (scm_port_table_size); | |
311 | } | |
312 | ||
313 | /* Return the ith member of the port table. */ | |
1146b6cd | 314 | SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member); |
0f2d19dd JB |
315 | SCM |
316 | scm_pt_member (member) | |
317 | SCM member; | |
0f2d19dd JB |
318 | { |
319 | int i; | |
320 | SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); | |
321 | i = SCM_INUM (member); | |
322 | if (i < 0 || i >= scm_port_table_size) | |
323 | return SCM_BOOL_F; | |
324 | else | |
325 | return scm_port_table[i]->port; | |
326 | } | |
327 | #endif | |
328 | ||
329 | ||
8b13c6b3 GH |
330 | /* Find a port in the table and return its revealed count. |
331 | Also used by the garbage collector. | |
0f2d19dd | 332 | */ |
1cc91f1b | 333 | |
0f2d19dd JB |
334 | int |
335 | scm_revealed_count (port) | |
336 | SCM port; | |
0f2d19dd JB |
337 | { |
338 | return SCM_REVEALED(port); | |
339 | } | |
340 | ||
341 | ||
342 | ||
343 | /* Return the revealed count for a port. */ | |
344 | ||
345 | SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); | |
1cc91f1b | 346 | |
0f2d19dd JB |
347 | SCM |
348 | scm_port_revealed (port) | |
349 | SCM port; | |
0f2d19dd | 350 | { |
0f2d19dd | 351 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); |
8b13c6b3 | 352 | return SCM_MAKINUM (scm_revealed_count (port)); |
0f2d19dd JB |
353 | } |
354 | ||
355 | /* Set the revealed count for a port. */ | |
356 | SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); | |
1cc91f1b | 357 | |
0f2d19dd JB |
358 | SCM |
359 | scm_set_port_revealed_x (port, rcount) | |
360 | SCM port; | |
361 | SCM rcount; | |
0f2d19dd JB |
362 | { |
363 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); | |
364 | SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); | |
365 | SCM_DEFER_INTS; | |
366 | SCM_REVEALED (port) = SCM_INUM (rcount); | |
367 | SCM_ALLOW_INTS; | |
8b13c6b3 | 368 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
369 | } |
370 | ||
371 | /* scm_close_port | |
372 | * Call the close operation on a port object. | |
373 | */ | |
374 | SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); | |
1cc91f1b | 375 | |
0f2d19dd JB |
376 | SCM |
377 | scm_close_port (port) | |
378 | SCM port; | |
0f2d19dd JB |
379 | { |
380 | scm_sizet i; | |
381 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port); | |
382 | if (SCM_CLOSEDP (port)) | |
383 | return SCM_UNSPECIFIED; | |
384 | i = SCM_PTOBNUM (port); | |
385 | SCM_DEFER_INTS; | |
386 | if (scm_ptobs[i].fclose) | |
387 | SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port))); | |
388 | scm_remove_from_port_table (port); | |
898a256f | 389 | SCM_SETAND_CAR (port, ~SCM_OPN); |
0f2d19dd JB |
390 | SCM_ALLOW_INTS; |
391 | return SCM_UNSPECIFIED; | |
392 | } | |
393 | ||
394 | SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); | |
1cc91f1b | 395 | |
0f2d19dd JB |
396 | SCM |
397 | scm_close_all_ports_except (ports) | |
398 | SCM ports; | |
0f2d19dd JB |
399 | { |
400 | int i = 0; | |
401 | SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); | |
402 | SCM_DEFER_INTS; | |
403 | while (i < scm_port_table_size) | |
404 | { | |
405 | SCM thisport = scm_port_table[i]->port; | |
406 | int found = 0; | |
407 | SCM ports_ptr = ports; | |
408 | ||
409 | while (SCM_NNULLP (ports_ptr)) | |
410 | { | |
411 | SCM port = SCM_CAR (ports_ptr); | |
412 | if (i == 0) | |
413 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); | |
414 | if (port == thisport) | |
415 | found = 1; | |
416 | ports_ptr = SCM_CDR (ports_ptr); | |
417 | } | |
418 | if (found) | |
419 | i++; | |
420 | else | |
421 | /* i is not to be incremented here. */ | |
422 | scm_close_port (thisport); | |
423 | } | |
424 | SCM_ALLOW_INTS; | |
425 | return SCM_UNSPECIFIED; | |
426 | } | |
427 | ||
428 | SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); | |
1cc91f1b | 429 | |
0f2d19dd JB |
430 | SCM |
431 | scm_input_port_p (x) | |
432 | SCM x; | |
0f2d19dd JB |
433 | { |
434 | if (SCM_IMP (x)) | |
435 | return SCM_BOOL_F; | |
436 | return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
437 | } | |
438 | ||
439 | SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); | |
1cc91f1b | 440 | |
0f2d19dd JB |
441 | SCM |
442 | scm_output_port_p (x) | |
443 | SCM x; | |
0f2d19dd JB |
444 | { |
445 | if (SCM_IMP (x)) | |
446 | return SCM_BOOL_F; | |
447 | return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; | |
448 | } | |
449 | ||
450 | ||
451 | SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); | |
1cc91f1b | 452 | |
0f2d19dd JB |
453 | SCM |
454 | scm_eof_object_p (x) | |
455 | SCM x; | |
0f2d19dd JB |
456 | { |
457 | return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F; | |
458 | } | |
459 | ||
460 | SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); | |
1cc91f1b | 461 | |
0f2d19dd JB |
462 | SCM |
463 | scm_force_output (port) | |
464 | SCM port; | |
0f2d19dd JB |
465 | { |
466 | if (SCM_UNBNDP (port)) | |
467 | port = scm_cur_outp; | |
468 | else | |
469 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output); | |
470 | { | |
471 | scm_sizet i = SCM_PTOBNUM (port); | |
472 | SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port))); | |
473 | return SCM_UNSPECIFIED; | |
474 | } | |
475 | } | |
476 | ||
477 | ||
478 | SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); | |
1cc91f1b | 479 | |
0f2d19dd JB |
480 | SCM |
481 | scm_read_char (port) | |
482 | SCM port; | |
0f2d19dd JB |
483 | { |
484 | int c; | |
485 | if (SCM_UNBNDP (port)) | |
334341aa | 486 | port = scm_cur_inp; |
0f2d19dd JB |
487 | else |
488 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); | |
489 | c = scm_gen_getc (port); | |
490 | if (EOF == c) | |
491 | return SCM_EOF_VAL; | |
492 | return SCM_MAKICHR (c); | |
493 | } | |
494 | ||
495 | ||
496 | SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); | |
1cc91f1b | 497 | |
0f2d19dd JB |
498 | SCM |
499 | scm_peek_char (port) | |
500 | SCM port; | |
0f2d19dd JB |
501 | { |
502 | int c; | |
503 | if (SCM_UNBNDP (port)) | |
504 | port = scm_cur_inp; | |
505 | else | |
506 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); | |
507 | c = scm_gen_getc (port); | |
508 | if (EOF == c) | |
509 | return SCM_EOF_VAL; | |
510 | scm_gen_ungetc (c, port); | |
511 | return SCM_MAKICHR (c); | |
512 | } | |
513 | ||
514 | SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); | |
1cc91f1b | 515 | |
0f2d19dd JB |
516 | SCM |
517 | scm_unread_char (cobj, port) | |
518 | SCM cobj; | |
519 | SCM port; | |
0f2d19dd JB |
520 | { |
521 | int c; | |
522 | ||
523 | SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); | |
524 | ||
525 | if (SCM_UNBNDP (port)) | |
526 | port = scm_cur_inp; | |
527 | else | |
528 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); | |
529 | ||
530 | ||
531 | c = SCM_ICHR (cobj); | |
532 | ||
533 | scm_gen_ungetc (c, port); | |
534 | return cobj; | |
535 | } | |
536 | ||
537 | ||
538 | ||
d14af9f2 | 539 | SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line); |
1cc91f1b | 540 | |
0f2d19dd | 541 | SCM |
d14af9f2 | 542 | scm_port_line (port) |
0f2d19dd | 543 | SCM port; |
0f2d19dd JB |
544 | { |
545 | SCM p; | |
546 | p = ((port == SCM_UNDEFINED) | |
547 | ? scm_cur_inp | |
548 | : port); | |
549 | if (!(SCM_NIMP (p) && SCM_PORTP (p))) | |
550 | return SCM_BOOL_F; | |
551 | else | |
552 | return SCM_MAKINUM (SCM_LINUM (p)); | |
553 | } | |
554 | ||
d043d8c2 MD |
555 | SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x); |
556 | ||
557 | SCM | |
558 | scm_set_port_line_x (port, line) | |
559 | SCM port; | |
560 | SCM line; | |
561 | { | |
562 | if (line == SCM_UNDEFINED) | |
563 | { | |
564 | line = port; | |
565 | port = scm_cur_inp; | |
566 | } | |
567 | else | |
568 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
569 | port, | |
570 | SCM_ARG1, | |
571 | s_set_port_line_x); | |
572 | return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); | |
573 | } | |
574 | ||
d14af9f2 | 575 | SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column); |
1cc91f1b | 576 | |
0f2d19dd | 577 | SCM |
d14af9f2 | 578 | scm_port_column (port) |
0f2d19dd | 579 | SCM port; |
0f2d19dd JB |
580 | { |
581 | SCM p; | |
582 | p = ((port == SCM_UNDEFINED) | |
583 | ? scm_cur_inp | |
584 | : port); | |
585 | if (!(SCM_NIMP (p) && SCM_PORTP (p))) | |
586 | return SCM_BOOL_F; | |
587 | else | |
588 | return SCM_MAKINUM (SCM_COL (p)); | |
589 | } | |
590 | ||
d043d8c2 MD |
591 | SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x); |
592 | ||
593 | SCM | |
594 | scm_set_port_column_x (port, column) | |
595 | SCM port; | |
596 | SCM column; | |
597 | { | |
598 | if (column == SCM_UNDEFINED) | |
599 | { | |
600 | column = port; | |
601 | port = scm_cur_inp; | |
602 | } | |
603 | else | |
604 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
605 | port, | |
606 | SCM_ARG1, | |
607 | s_set_port_column_x); | |
608 | return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); | |
609 | } | |
610 | ||
d14af9f2 | 611 | SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename); |
1cc91f1b | 612 | |
0f2d19dd | 613 | SCM |
d14af9f2 | 614 | scm_port_filename (port) |
0f2d19dd | 615 | SCM port; |
0f2d19dd JB |
616 | { |
617 | SCM p; | |
618 | p = ((port == SCM_UNDEFINED) | |
619 | ? scm_cur_inp | |
620 | : port); | |
621 | if (!(SCM_NIMP (p) && SCM_PORTP (p))) | |
622 | return SCM_BOOL_F; | |
623 | else | |
624 | return SCM_PTAB_ENTRY (p)->file_name; | |
625 | } | |
626 | ||
d14af9f2 | 627 | SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x); |
1cc91f1b | 628 | |
d14af9f2 MD |
629 | SCM |
630 | scm_set_port_filename_x (port, filename) | |
631 | SCM port; | |
632 | SCM filename; | |
d14af9f2 MD |
633 | { |
634 | if (filename == SCM_UNDEFINED) | |
635 | { | |
636 | filename = port; | |
637 | port = scm_cur_inp; | |
638 | } | |
639 | else | |
640 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
641 | port, | |
642 | SCM_ARG1, | |
643 | s_set_port_filename_x); | |
644 | return SCM_PTAB_ENTRY (port)->file_name = filename; | |
645 | } | |
646 | ||
0f2d19dd JB |
647 | #ifndef ttyname |
648 | extern char * ttyname(); | |
649 | #endif | |
650 | ||
1cc91f1b | 651 | |
0f2d19dd JB |
652 | void |
653 | scm_prinport (exp, port, type) | |
654 | SCM exp; | |
655 | SCM port; | |
656 | char *type; | |
0f2d19dd JB |
657 | { |
658 | scm_gen_puts (scm_regular_string, "#<", port); | |
659 | if (SCM_CLOSEDP (exp)) | |
660 | scm_gen_puts (scm_regular_string, "closed: ", port); | |
661 | else | |
662 | { | |
663 | if (SCM_RDNG & SCM_CAR (exp)) | |
664 | scm_gen_puts (scm_regular_string, "input: ", port); | |
665 | if (SCM_WRTNG & SCM_CAR (exp)) | |
666 | scm_gen_puts (scm_regular_string, "output: ", port); | |
667 | } | |
668 | scm_gen_puts (scm_regular_string, type, port); | |
669 | scm_gen_putc (' ', port); | |
670 | #ifndef MSDOS | |
671 | #ifndef __EMX__ | |
672 | #ifndef _DCC | |
673 | #ifndef AMIGA | |
674 | #ifndef THINK_C | |
675 | if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) | |
676 | scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); | |
677 | else | |
678 | #endif | |
679 | #endif | |
680 | #endif | |
681 | #endif | |
682 | #endif | |
683 | if (SCM_OPFPORTP (exp)) | |
684 | scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); | |
685 | else | |
686 | scm_intprint (SCM_CDR (exp), 16, port); | |
687 | scm_gen_putc ('>', port); | |
688 | } | |
689 | ||
1cc91f1b | 690 | |
0f2d19dd JB |
691 | void |
692 | scm_ports_prehistory () | |
0f2d19dd JB |
693 | { |
694 | scm_numptob = 0; | |
695 | scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); | |
696 | ||
697 | /* WARNING: These scm_newptob calls must be done in this order. | |
698 | * They must agree with the port declarations in tags.h. | |
699 | */ | |
700 | /* scm_tc16_fport = */ scm_newptob (&scm_fptob); | |
701 | /* scm_tc16_pipe = */ scm_newptob (&scm_pipob); | |
702 | /* scm_tc16_strport = */ scm_newptob (&scm_stptob); | |
703 | /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); | |
704 | } | |
705 | \f | |
706 | ||
707 | \f | |
708 | /* {Void Ports} | |
709 | */ | |
710 | ||
711 | int scm_tc16_void_port = 0; | |
712 | ||
713 | static int | |
714 | print_void_port (exp, port, writing) | |
715 | SCM exp; | |
716 | SCM port; | |
717 | int writing; | |
718 | { | |
719 | scm_prinport (exp, port, "void"); | |
720 | return 1; | |
721 | } | |
722 | ||
723 | static int | |
724 | putc_void_port (c, strm) | |
725 | int c; | |
726 | SCM strm; | |
727 | { | |
728 | return 0; /* vestigial return value */ | |
729 | } | |
730 | ||
731 | static int | |
732 | puts_void_port (s, strm) | |
733 | char * s; | |
734 | SCM strm; | |
735 | { | |
736 | return 0; /* vestigial return value */ | |
737 | } | |
738 | ||
739 | static scm_sizet | |
740 | write_void_port (ptr, size, nitems, strm) | |
741 | void * ptr; | |
742 | int size; | |
743 | int nitems; | |
744 | SCM strm; | |
745 | { | |
746 | int len; | |
747 | len = size * nitems; | |
748 | return len; | |
749 | } | |
750 | ||
1cc91f1b JB |
751 | |
752 | static int flush_void_port SCM_P ((SCM strm)); | |
753 | ||
0f2d19dd JB |
754 | static int |
755 | flush_void_port (strm) | |
756 | SCM strm; | |
0f2d19dd JB |
757 | { |
758 | return 0; | |
759 | } | |
760 | ||
1cc91f1b JB |
761 | |
762 | static int getc_void_port SCM_P ((SCM strm)); | |
763 | ||
0f2d19dd JB |
764 | static int |
765 | getc_void_port (strm) | |
766 | SCM strm; | |
0f2d19dd JB |
767 | { |
768 | return EOF; | |
769 | } | |
770 | ||
1cc91f1b JB |
771 | |
772 | static int close_void_port SCM_P ((SCM strm)); | |
773 | ||
0f2d19dd JB |
774 | static int |
775 | close_void_port (strm) | |
776 | SCM strm; | |
0f2d19dd JB |
777 | { |
778 | return 0; /* this is ignored by scm_close_port. */ | |
779 | } | |
780 | ||
781 | ||
1cc91f1b JB |
782 | |
783 | static int noop0 SCM_P ((SCM stream)); | |
784 | ||
0f2d19dd JB |
785 | static int |
786 | noop0 (stream) | |
1cc91f1b | 787 | SCM stream; |
0f2d19dd JB |
788 | { |
789 | return 0; | |
790 | } | |
791 | ||
792 | ||
793 | static struct scm_ptobfuns void_port_ptob = | |
794 | { | |
795 | scm_mark0, | |
796 | noop0, | |
797 | print_void_port, | |
798 | 0, /* equal? */ | |
799 | putc_void_port, | |
800 | puts_void_port, | |
801 | write_void_port, | |
802 | flush_void_port, | |
803 | getc_void_port, | |
804 | close_void_port, | |
805 | }; | |
806 | ||
807 | \f | |
808 | ||
1cc91f1b | 809 | |
0f2d19dd JB |
810 | SCM |
811 | scm_void_port (mode_str) | |
812 | char * mode_str; | |
0f2d19dd JB |
813 | { |
814 | int mode_bits; | |
815 | SCM answer; | |
816 | struct scm_port_table * pt; | |
817 | ||
818 | SCM_NEWCELL (answer); | |
819 | SCM_DEFER_INTS; | |
820 | mode_bits = scm_mode_bits (mode_str); | |
821 | pt = scm_add_to_port_table (answer); | |
898a256f | 822 | SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); |
0f2d19dd JB |
823 | SCM_SETPTAB_ENTRY (answer, pt); |
824 | SCM_SETSTREAM (answer, SCM_BOOL_F); | |
825 | SCM_ALLOW_INTS; | |
826 | return answer; | |
827 | } | |
828 | ||
829 | ||
830 | SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); | |
1cc91f1b | 831 | |
0f2d19dd JB |
832 | SCM |
833 | scm_sys_make_void_port (mode) | |
834 | SCM mode; | |
0f2d19dd JB |
835 | { |
836 | SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode, | |
837 | SCM_ARG1, s_sys_make_void_port); | |
838 | ||
839 | return scm_void_port (SCM_ROCHARS (mode)); | |
840 | } | |
841 | ||
842 | ||
843 | ||
844 | \f | |
845 | ||
1cc91f1b | 846 | |
0f2d19dd JB |
847 | void |
848 | scm_init_ports () | |
0f2d19dd JB |
849 | { |
850 | scm_tc16_void_port = scm_newptob (&void_port_ptob); | |
851 | #include "ports.x" | |
852 | } | |
853 |