Commit | Line | Data |
---|---|---|
840ae05d | 1 | /* Copyright (C) 1995,1996,1997,1998,1999 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 | 41 | \f |
d68fee48 JB |
42 | /* Headers. */ |
43 | ||
0f2d19dd JB |
44 | #include <stdio.h> |
45 | #include "_scm.h" | |
f12733c9 MD |
46 | #include "objects.h" |
47 | #include "smob.h" | |
20e6290e | 48 | #include "chars.h" |
0f2d19dd | 49 | |
547e65b5 | 50 | #include "keywords.h" |
20e6290e JB |
51 | |
52 | #include "ports.h" | |
0f2d19dd JB |
53 | |
54 | #ifdef HAVE_MALLOC_H | |
95b88819 | 55 | #include <malloc.h> |
0f2d19dd JB |
56 | #endif |
57 | ||
58 | #ifdef HAVE_UNISTD_H | |
59 | #include <unistd.h> | |
60 | #endif | |
61 | ||
95b88819 GH |
62 | #ifdef HAVE_SYS_IOCTL_H |
63 | #include <sys/ioctl.h> | |
64 | #endif | |
d68fee48 | 65 | |
0f2d19dd | 66 | \f |
d68fee48 | 67 | /* The port kind table --- a dynamically resized array of port types. */ |
0f2d19dd JB |
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 | */ | |
f12733c9 | 75 | scm_ptob_descriptor *scm_ptobs; |
a1c95c45 | 76 | int scm_numptob; |
0f2d19dd | 77 | |
ee149d03 | 78 | /* GC marker for a port with stream of SCM type. */ |
0f2d19dd | 79 | SCM |
a284e297 | 80 | scm_markstream (SCM ptr) |
0f2d19dd JB |
81 | { |
82 | int openp; | |
0f2d19dd | 83 | openp = SCM_CAR (ptr) & SCM_OPN; |
0f2d19dd JB |
84 | if (openp) |
85 | return SCM_STREAM (ptr); | |
86 | else | |
87 | return SCM_BOOL_F; | |
88 | } | |
89 | ||
f12733c9 | 90 | /* |
f12733c9 | 91 | * We choose to use an interface similar to the smob interface with |
affc96b5 | 92 | * fill_input and write as standard fields, passed to the port |
f12733c9 MD |
93 | * type constructor, and optional fields set by setters. |
94 | */ | |
95 | ||
96 | static void flush_void_port (SCM port); | |
affc96b5 | 97 | static void end_input_void_port (SCM port, int offset); |
31703ab8 | 98 | static void write_void_port (SCM port, void *data, size_t size); |
0f2d19dd | 99 | |
0f2d19dd | 100 | long |
f12733c9 | 101 | scm_make_port_type (char *name, |
affc96b5 GH |
102 | int (*fill_input) (SCM port), |
103 | void (*write) (SCM port, void *data, size_t size)) | |
0f2d19dd JB |
104 | { |
105 | char *tmp; | |
106 | if (255 <= scm_numptob) | |
107 | goto ptoberr; | |
f12733c9 MD |
108 | SCM_DEFER_INTS; |
109 | SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, | |
110 | (1 + scm_numptob) | |
111 | * sizeof (scm_ptob_descriptor))); | |
0f2d19dd JB |
112 | if (tmp) |
113 | { | |
f12733c9 | 114 | scm_ptobs = (scm_ptob_descriptor *) tmp; |
affc96b5 | 115 | |
f12733c9 MD |
116 | scm_ptobs[scm_numptob].name = name; |
117 | scm_ptobs[scm_numptob].mark = 0; | |
118 | scm_ptobs[scm_numptob].free = scm_free0; | |
119 | scm_ptobs[scm_numptob].print = scm_port_print; | |
120 | scm_ptobs[scm_numptob].equalp = 0; | |
affc96b5 GH |
121 | scm_ptobs[scm_numptob].close = 0; |
122 | ||
123 | scm_ptobs[scm_numptob].write = write; | |
124 | scm_ptobs[scm_numptob].flush = flush_void_port; | |
125 | ||
126 | scm_ptobs[scm_numptob].end_input = end_input_void_port; | |
127 | scm_ptobs[scm_numptob].fill_input = fill_input; | |
128 | scm_ptobs[scm_numptob].input_waiting = 0; | |
129 | ||
f12733c9 | 130 | scm_ptobs[scm_numptob].seek = 0; |
affc96b5 GH |
131 | scm_ptobs[scm_numptob].truncate = 0; |
132 | ||
0f2d19dd JB |
133 | scm_numptob++; |
134 | } | |
f12733c9 | 135 | SCM_ALLOW_INTS; |
0f2d19dd | 136 | if (!tmp) |
f12733c9 MD |
137 | ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), |
138 | (char *) SCM_NALLOC, "scm_make_port_type"); | |
139 | /* Make a class object if Goops is present */ | |
140 | if (scm_port_class) | |
141 | scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1)); | |
0f2d19dd JB |
142 | return scm_tc7_port + (scm_numptob - 1) * 256; |
143 | } | |
144 | ||
f12733c9 | 145 | void |
6c747373 | 146 | scm_set_port_mark (long tc, SCM (*mark) (SCM)) |
f12733c9 MD |
147 | { |
148 | scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark; | |
149 | } | |
150 | ||
151 | void | |
6c747373 | 152 | scm_set_port_free (long tc, scm_sizet (*free) (SCM)) |
f12733c9 MD |
153 | { |
154 | scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free; | |
155 | } | |
156 | ||
157 | void | |
6c747373 | 158 | scm_set_port_print (long tc, int (*print) (SCM exp, SCM port, |
f12733c9 MD |
159 | scm_print_state *pstate)) |
160 | { | |
161 | scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print; | |
162 | } | |
163 | ||
164 | void | |
6c747373 | 165 | scm_set_port_equalp (long tc, SCM (*equalp) (SCM, SCM)) |
f12733c9 MD |
166 | { |
167 | scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp; | |
168 | } | |
169 | ||
31703ab8 | 170 | void |
affc96b5 | 171 | scm_set_port_flush (long tc, void (*flush) (SCM port)) |
31703ab8 | 172 | { |
affc96b5 | 173 | scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush; |
31703ab8 GH |
174 | } |
175 | ||
f12733c9 | 176 | void |
affc96b5 | 177 | scm_set_port_end_input (long tc, void (*end_input) (SCM port, int offset)) |
f12733c9 | 178 | { |
affc96b5 | 179 | scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input; |
f12733c9 MD |
180 | } |
181 | ||
182 | void | |
6c747373 | 183 | scm_set_port_close (long tc, int (*close) (SCM)) |
f12733c9 | 184 | { |
affc96b5 | 185 | scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close; |
f12733c9 MD |
186 | } |
187 | ||
188 | void | |
6c747373 | 189 | scm_set_port_seek (long tc, off_t (*seek) (SCM port, |
f12733c9 MD |
190 | off_t OFFSET, |
191 | int WHENCE)) | |
192 | { | |
193 | scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek; | |
194 | } | |
195 | ||
196 | void | |
6c747373 | 197 | scm_set_port_truncate (long tc, void (*truncate) (SCM port, off_t length)) |
f12733c9 | 198 | { |
affc96b5 | 199 | scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate; |
f12733c9 MD |
200 | } |
201 | ||
202 | void | |
affc96b5 | 203 | scm_set_port_input_waiting (long tc, int (*input_waiting) (SCM)) |
f12733c9 | 204 | { |
affc96b5 | 205 | scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting; |
f12733c9 MD |
206 | } |
207 | ||
0f2d19dd | 208 | \f |
0f2d19dd | 209 | |
44493941 | 210 | SCM_PROC(s_char_ready_p, "char-ready?", 0, 1, 0, scm_char_ready_p); |
1cc91f1b | 211 | |
0f2d19dd | 212 | SCM |
a284e297 | 213 | scm_char_ready_p (SCM port) |
0f2d19dd | 214 | { |
ae4c4016 | 215 | scm_port *pt; |
6c951427 | 216 | |
0f2d19dd JB |
217 | if (SCM_UNBNDP (port)) |
218 | port = scm_cur_inp; | |
219 | else | |
d68fee48 JB |
220 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, |
221 | s_char_ready_p); | |
222 | ||
ae4c4016 JB |
223 | pt = SCM_PTAB_ENTRY (port); |
224 | ||
6c951427 GH |
225 | /* if the current read buffer is filled, or the |
226 | last pushed-back char has been read and the saved buffer is | |
227 | filled, result is true. */ | |
228 | if (pt->read_pos < pt->read_end | |
229 | || (pt->read_buf == pt->putback_buf | |
230 | && pt->saved_read_pos < pt->saved_read_end)) | |
0f2d19dd | 231 | return SCM_BOOL_T; |
ee149d03 JB |
232 | else |
233 | { | |
f12733c9 | 234 | scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
ee149d03 | 235 | |
affc96b5 GH |
236 | if (ptob->input_waiting) |
237 | return (ptob->input_waiting (port)) ? SCM_BOOL_T : SCM_BOOL_F; | |
ee149d03 | 238 | else |
6c951427 | 239 | return SCM_BOOL_T; |
ee149d03 | 240 | } |
0f2d19dd | 241 | } |
0f2d19dd | 242 | |
6c951427 | 243 | /* Clear a port's read buffers, returning the contents. */ |
ee149d03 JB |
244 | SCM_PROC (s_drain_input, "drain-input", 1, 0, 0, scm_drain_input); |
245 | SCM | |
246 | scm_drain_input (SCM port) | |
247 | { | |
840ae05d JB |
248 | SCM result; |
249 | scm_port *pt = SCM_PTAB_ENTRY (port); | |
6c951427 | 250 | int count; |
840ae05d | 251 | char *dst; |
ee149d03 JB |
252 | |
253 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, | |
254 | s_drain_input); | |
840ae05d | 255 | |
6c951427 GH |
256 | count = pt->read_end - pt->read_pos; |
257 | if (pt->read_buf == pt->putback_buf) | |
258 | count += pt->saved_read_end - pt->saved_read_pos; | |
840ae05d | 259 | |
6c951427 GH |
260 | result = scm_makstr (count, 0); |
261 | dst = SCM_CHARS (result); | |
840ae05d JB |
262 | |
263 | while (pt->read_pos < pt->read_end) | |
6c951427 GH |
264 | *dst++ = *(pt->read_pos++); |
265 | ||
266 | if (pt->read_buf == pt->putback_buf) | |
840ae05d | 267 | { |
6c951427 GH |
268 | while (pt->saved_read_pos < pt->saved_read_end) |
269 | *dst++ = *(pt->saved_read_pos++); | |
840ae05d | 270 | } |
6c951427 | 271 | |
840ae05d | 272 | return result; |
ee149d03 | 273 | } |
0f2d19dd JB |
274 | |
275 | \f | |
d68fee48 | 276 | /* Standard ports --- current input, output, error, and more(!). */ |
0f2d19dd | 277 | |
0f2d19dd | 278 | SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); |
1cc91f1b | 279 | |
0f2d19dd JB |
280 | SCM |
281 | scm_current_input_port () | |
0f2d19dd JB |
282 | { |
283 | return scm_cur_inp; | |
284 | } | |
285 | ||
286 | SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); | |
1cc91f1b | 287 | |
0f2d19dd JB |
288 | SCM |
289 | scm_current_output_port () | |
0f2d19dd JB |
290 | { |
291 | return scm_cur_outp; | |
292 | } | |
293 | ||
294 | SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); | |
1cc91f1b | 295 | |
0f2d19dd JB |
296 | SCM |
297 | scm_current_error_port () | |
0f2d19dd JB |
298 | { |
299 | return scm_cur_errp; | |
300 | } | |
301 | ||
31614d8e MD |
302 | SCM_PROC(s_current_load_port, "current-load-port", 0, 0, 0, scm_current_load_port); |
303 | ||
304 | SCM | |
305 | scm_current_load_port () | |
306 | { | |
307 | return scm_cur_loadp; | |
308 | } | |
309 | ||
0f2d19dd | 310 | SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); |
1cc91f1b | 311 | |
0f2d19dd | 312 | SCM |
a284e297 | 313 | scm_set_current_input_port (SCM port) |
0f2d19dd JB |
314 | { |
315 | SCM oinp = scm_cur_inp; | |
316 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); | |
317 | scm_cur_inp = port; | |
318 | return oinp; | |
319 | } | |
320 | ||
321 | ||
322 | SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); | |
1cc91f1b | 323 | |
0f2d19dd | 324 | SCM |
a284e297 | 325 | scm_set_current_output_port (SCM port) |
0f2d19dd JB |
326 | { |
327 | SCM ooutp = scm_cur_outp; | |
78446828 | 328 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
329 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); |
330 | scm_cur_outp = port; | |
331 | return ooutp; | |
332 | } | |
333 | ||
334 | ||
335 | SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); | |
1cc91f1b | 336 | |
0f2d19dd | 337 | SCM |
a284e297 | 338 | scm_set_current_error_port (SCM port) |
0f2d19dd JB |
339 | { |
340 | SCM oerrp = scm_cur_errp; | |
78446828 | 341 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd JB |
342 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); |
343 | scm_cur_errp = port; | |
344 | return oerrp; | |
345 | } | |
346 | ||
347 | \f | |
840ae05d | 348 | /* The port table --- an array of pointers to ports. */ |
0f2d19dd | 349 | |
840ae05d | 350 | scm_port **scm_port_table; |
0f2d19dd JB |
351 | |
352 | int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ | |
353 | int scm_port_table_room = 20; /* Size of the array. */ | |
354 | ||
ee149d03 | 355 | /* Add a port to the table. */ |
1cc91f1b | 356 | |
840ae05d | 357 | scm_port * |
a284e297 | 358 | scm_add_to_port_table (SCM port) |
0f2d19dd | 359 | { |
840ae05d JB |
360 | scm_port *entry; |
361 | ||
0f2d19dd JB |
362 | if (scm_port_table_size == scm_port_table_room) |
363 | { | |
ee149d03 | 364 | void *newt = realloc ((char *) scm_port_table, |
840ae05d | 365 | (scm_sizet) (sizeof (scm_port *) |
ee149d03 JB |
366 | * scm_port_table_room * 2)); |
367 | if (newt == NULL) | |
840ae05d JB |
368 | scm_memory_error ("scm_add_to_port_table"); |
369 | scm_port_table = (scm_port **) newt; | |
0f2d19dd JB |
370 | scm_port_table_room *= 2; |
371 | } | |
840ae05d JB |
372 | entry = (scm_port *) malloc (sizeof (scm_port)); |
373 | if (entry == NULL) | |
374 | scm_memory_error ("scm_add_to_port_table"); | |
375 | ||
376 | entry->port = port; | |
377 | entry->entry = scm_port_table_size; | |
378 | entry->revealed = 0; | |
379 | entry->stream = 0; | |
380 | entry->file_name = SCM_BOOL_F; | |
381 | entry->line_number = 0; | |
382 | entry->column_number = 0; | |
6c951427 GH |
383 | entry->putback_buf = 0; |
384 | entry->putback_buf_size = 0; | |
61e452ba | 385 | entry->rw_active = SCM_PORT_NEITHER; |
0de97b83 | 386 | entry->rw_random = 0; |
840ae05d JB |
387 | |
388 | scm_port_table[scm_port_table_size] = entry; | |
389 | scm_port_table_size++; | |
390 | ||
391 | return entry; | |
0f2d19dd JB |
392 | } |
393 | ||
6c951427 | 394 | /* Remove a port from the table and destroy it. */ |
1cc91f1b | 395 | |
0f2d19dd | 396 | void |
a284e297 | 397 | scm_remove_from_port_table (SCM port) |
0f2d19dd | 398 | { |
840ae05d | 399 | scm_port *p = SCM_PTAB_ENTRY (port); |
ee1e7e13 | 400 | int i = p->entry; |
6c951427 | 401 | |
ee1e7e13 MD |
402 | if (i >= scm_port_table_size) |
403 | scm_wta (port, "Port not in table", "scm_remove_from_port_table"); | |
6c951427 GH |
404 | if (p->putback_buf) |
405 | free (p->putback_buf); | |
840ae05d | 406 | free (p); |
ee1e7e13 MD |
407 | /* Since we have just freed slot i we can shrink the table by moving |
408 | the last entry to that slot... */ | |
409 | if (i < scm_port_table_size - 1) | |
0f2d19dd | 410 | { |
ee1e7e13 MD |
411 | scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; |
412 | scm_port_table[i]->entry = i; | |
0f2d19dd | 413 | } |
0f2d19dd JB |
414 | SCM_SETPTAB_ENTRY (port, 0); |
415 | scm_port_table_size--; | |
416 | } | |
417 | ||
fea6b4ea | 418 | #ifdef GUILE_DEBUG |
0f2d19dd JB |
419 | /* Undocumented functions for debugging. */ |
420 | /* Return the number of ports in the table. */ | |
1cc91f1b | 421 | |
1146b6cd | 422 | SCM_PROC(s_pt_size, "pt-size", 0, 0, 0, scm_pt_size); |
0f2d19dd JB |
423 | SCM |
424 | scm_pt_size () | |
0f2d19dd JB |
425 | { |
426 | return SCM_MAKINUM (scm_port_table_size); | |
427 | } | |
428 | ||
429 | /* Return the ith member of the port table. */ | |
1146b6cd | 430 | SCM_PROC(s_pt_member, "pt-member", 1, 0, 0, scm_pt_member); |
0f2d19dd | 431 | SCM |
a284e297 | 432 | scm_pt_member (SCM member) |
0f2d19dd JB |
433 | { |
434 | int i; | |
435 | SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); | |
436 | i = SCM_INUM (member); | |
437 | if (i < 0 || i >= scm_port_table_size) | |
438 | return SCM_BOOL_F; | |
439 | else | |
440 | return scm_port_table[i]->port; | |
441 | } | |
442 | #endif | |
443 | ||
444 | ||
d68fee48 JB |
445 | \f |
446 | /* Revealed counts --- an oddity inherited from SCSH. */ | |
447 | ||
8b13c6b3 GH |
448 | /* Find a port in the table and return its revealed count. |
449 | Also used by the garbage collector. | |
0f2d19dd | 450 | */ |
1cc91f1b | 451 | |
0f2d19dd | 452 | int |
a284e297 | 453 | scm_revealed_count (SCM port) |
0f2d19dd JB |
454 | { |
455 | return SCM_REVEALED(port); | |
456 | } | |
457 | ||
458 | ||
459 | ||
460 | /* Return the revealed count for a port. */ | |
461 | ||
462 | SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); | |
1cc91f1b | 463 | |
0f2d19dd | 464 | SCM |
a284e297 | 465 | scm_port_revealed (SCM port) |
0f2d19dd | 466 | { |
78446828 | 467 | port = SCM_COERCE_OUTPORT (port); |
0f2d19dd | 468 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); |
8b13c6b3 | 469 | return SCM_MAKINUM (scm_revealed_count (port)); |
0f2d19dd JB |
470 | } |
471 | ||
472 | /* Set the revealed count for a port. */ | |
473 | SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); | |
1cc91f1b | 474 | |
0f2d19dd | 475 | SCM |
a284e297 | 476 | scm_set_port_revealed_x (SCM port, SCM rcount) |
0f2d19dd | 477 | { |
78446828 | 478 | port = SCM_COERCE_OUTPORT (port); |
a284e297 MD |
479 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), |
480 | port, SCM_ARG1, s_set_port_revealed_x); | |
0f2d19dd | 481 | SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); |
0f2d19dd | 482 | SCM_REVEALED (port) = SCM_INUM (rcount); |
8b13c6b3 | 483 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
484 | } |
485 | ||
d68fee48 JB |
486 | |
487 | \f | |
488 | /* Retrieving a port's mode. */ | |
489 | ||
eadd48de GH |
490 | /* Return the flags that characterize a port based on the mode |
491 | * string used to open a file for that port. | |
492 | * | |
493 | * See PORT FLAGS in scm.h | |
494 | */ | |
495 | ||
496 | long | |
a284e297 | 497 | scm_mode_bits (char *modes) |
eadd48de GH |
498 | { |
499 | return (SCM_OPN | |
500 | | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) | |
501 | | ( strchr (modes, 'w') | |
502 | || strchr (modes, 'a') | |
503 | || strchr (modes, '+') ? SCM_WRTNG : 0) | |
ee149d03 JB |
504 | | (strchr (modes, '0') ? SCM_BUF0 : 0) |
505 | | (strchr (modes, 'l') ? SCM_BUFLINE : 0)); | |
eadd48de GH |
506 | } |
507 | ||
508 | ||
509 | /* Return the mode flags from an open port. | |
510 | * Some modes such as "append" are only used when opening | |
511 | * a file and are not returned here. */ | |
512 | ||
513 | SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); | |
514 | ||
515 | SCM | |
a284e297 | 516 | scm_port_mode (SCM port) |
eadd48de GH |
517 | { |
518 | char modes[3]; | |
519 | modes[0] = '\0'; | |
78446828 MV |
520 | |
521 | port = SCM_COERCE_OUTPORT (port); | |
eadd48de GH |
522 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); |
523 | if (SCM_CAR (port) & SCM_RDNG) { | |
524 | if (SCM_CAR (port) & SCM_WRTNG) | |
525 | strcpy (modes, "r+"); | |
526 | else | |
527 | strcpy (modes, "r"); | |
528 | } | |
529 | else if (SCM_CAR (port) & SCM_WRTNG) | |
530 | strcpy (modes, "w"); | |
531 | if (SCM_CAR (port) & SCM_BUF0) | |
532 | strcat (modes, "0"); | |
533 | return scm_makfromstr (modes, strlen (modes), 0); | |
534 | } | |
535 | ||
536 | ||
d68fee48 JB |
537 | \f |
538 | /* Closing ports. */ | |
539 | ||
0f2d19dd JB |
540 | /* scm_close_port |
541 | * Call the close operation on a port object. | |
eadd48de | 542 | * see also scm_close. |
0f2d19dd JB |
543 | */ |
544 | SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); | |
1cc91f1b | 545 | |
0f2d19dd | 546 | SCM |
a284e297 | 547 | scm_close_port (SCM port) |
0f2d19dd JB |
548 | { |
549 | scm_sizet i; | |
eadd48de GH |
550 | int rv; |
551 | ||
78446828 MV |
552 | port = SCM_COERCE_OUTPORT (port); |
553 | ||
341eaef0 | 554 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, |
3c1750f3 | 555 | s_close_port); |
0f2d19dd | 556 | if (SCM_CLOSEDP (port)) |
eadd48de | 557 | return SCM_BOOL_F; |
0f2d19dd | 558 | i = SCM_PTOBNUM (port); |
affc96b5 GH |
559 | if (scm_ptobs[i].close) |
560 | rv = (scm_ptobs[i].close) (port); | |
eadd48de GH |
561 | else |
562 | rv = 0; | |
0f2d19dd | 563 | scm_remove_from_port_table (port); |
898a256f | 564 | SCM_SETAND_CAR (port, ~SCM_OPN); |
eadd48de | 565 | return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T; |
0f2d19dd JB |
566 | } |
567 | ||
568 | SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); | |
1cc91f1b | 569 | |
0f2d19dd | 570 | SCM |
a284e297 | 571 | scm_close_all_ports_except (SCM ports) |
0f2d19dd JB |
572 | { |
573 | int i = 0; | |
574 | SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); | |
0f2d19dd JB |
575 | while (i < scm_port_table_size) |
576 | { | |
577 | SCM thisport = scm_port_table[i]->port; | |
578 | int found = 0; | |
579 | SCM ports_ptr = ports; | |
580 | ||
581 | while (SCM_NNULLP (ports_ptr)) | |
582 | { | |
78446828 | 583 | SCM port = SCM_COERCE_OUTPORT (SCM_CAR (ports_ptr)); |
0f2d19dd JB |
584 | if (i == 0) |
585 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); | |
586 | if (port == thisport) | |
587 | found = 1; | |
588 | ports_ptr = SCM_CDR (ports_ptr); | |
589 | } | |
590 | if (found) | |
591 | i++; | |
592 | else | |
593 | /* i is not to be incremented here. */ | |
594 | scm_close_port (thisport); | |
595 | } | |
0f2d19dd JB |
596 | return SCM_UNSPECIFIED; |
597 | } | |
598 | ||
d68fee48 JB |
599 | |
600 | \f | |
601 | /* Utter miscellany. Gosh, we should clean this up some time. */ | |
602 | ||
0f2d19dd | 603 | SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); |
1cc91f1b | 604 | |
0f2d19dd | 605 | SCM |
a284e297 | 606 | scm_input_port_p (SCM x) |
0f2d19dd JB |
607 | { |
608 | if (SCM_IMP (x)) | |
4a94d8ca | 609 | return SCM_BOOL_F; |
0f2d19dd JB |
610 | return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; |
611 | } | |
612 | ||
613 | SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); | |
1cc91f1b | 614 | |
0f2d19dd | 615 | SCM |
a284e297 | 616 | scm_output_port_p (SCM x) |
0f2d19dd JB |
617 | { |
618 | if (SCM_IMP (x)) | |
4a94d8ca MD |
619 | return SCM_BOOL_F; |
620 | if (SCM_PORT_WITH_PS_P (x)) | |
621 | x = SCM_PORT_WITH_PS_PORT (x); | |
0f2d19dd JB |
622 | return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; |
623 | } | |
624 | ||
60d0643d GH |
625 | SCM_PROC(s_port_closed_p, "port-closed?", 1, 0, 0, scm_port_closed_p); |
626 | SCM | |
627 | scm_port_closed_p (SCM port) | |
628 | { | |
629 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, | |
630 | s_port_closed_p); | |
631 | return SCM_OPPORTP (port) ? SCM_BOOL_F : SCM_BOOL_T; | |
632 | } | |
0f2d19dd JB |
633 | |
634 | SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); | |
1cc91f1b | 635 | |
0f2d19dd | 636 | SCM |
a284e297 | 637 | scm_eof_object_p (SCM x) |
0f2d19dd | 638 | { |
0c32d76c | 639 | return SCM_EOF_OBJECT_P (x) ? SCM_BOOL_T : SCM_BOOL_F; |
0f2d19dd JB |
640 | } |
641 | ||
642 | SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); | |
1cc91f1b | 643 | |
0f2d19dd | 644 | SCM |
a284e297 | 645 | scm_force_output (SCM port) |
0f2d19dd JB |
646 | { |
647 | if (SCM_UNBNDP (port)) | |
3e877d15 | 648 | port = scm_cur_outp; |
0f2d19dd | 649 | else |
78446828 MV |
650 | { |
651 | port = SCM_COERCE_OUTPORT (port); | |
3e877d15 JB |
652 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, |
653 | s_force_output); | |
78446828 | 654 | } |
affc96b5 | 655 | scm_flush (port); |
ee149d03 | 656 | return SCM_UNSPECIFIED; |
0f2d19dd JB |
657 | } |
658 | ||
9c29ac66 | 659 | SCM_PROC (s_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_flush_all_ports); |
89ea5b7c | 660 | SCM |
a284e297 | 661 | scm_flush_all_ports () |
89ea5b7c GH |
662 | { |
663 | int i; | |
664 | ||
665 | for (i = 0; i < scm_port_table_size; i++) | |
666 | { | |
ee149d03 | 667 | if (SCM_OPOUTPORTP (scm_port_table[i]->port)) |
affc96b5 | 668 | scm_flush (scm_port_table[i]->port); |
89ea5b7c GH |
669 | } |
670 | return SCM_UNSPECIFIED; | |
671 | } | |
0f2d19dd JB |
672 | |
673 | SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); | |
1cc91f1b | 674 | |
0f2d19dd | 675 | SCM |
a284e297 | 676 | scm_read_char (SCM port) |
0f2d19dd JB |
677 | { |
678 | int c; | |
679 | if (SCM_UNBNDP (port)) | |
334341aa | 680 | port = scm_cur_inp; |
4cc81ec6 | 681 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); |
b7f3516f | 682 | c = scm_getc (port); |
0f2d19dd JB |
683 | if (EOF == c) |
684 | return SCM_EOF_VAL; | |
685 | return SCM_MAKICHR (c); | |
686 | } | |
687 | ||
5c070ca7 | 688 | /* this should only be called when the read buffer is empty. it |
affc96b5 | 689 | tries to refill the read buffer. it returns the first char from |
5c070ca7 | 690 | the port, which is either EOF or *(pt->read_pos). */ |
6c951427 | 691 | int |
affc96b5 | 692 | scm_fill_input (SCM port) |
6c951427 | 693 | { |
283a1a0e GH |
694 | scm_port *pt = SCM_PTAB_ENTRY (port); |
695 | ||
6c951427 GH |
696 | if (pt->read_buf == pt->putback_buf) |
697 | { | |
698 | /* finished reading put-back chars. */ | |
699 | pt->read_buf = pt->saved_read_buf; | |
700 | pt->read_pos = pt->saved_read_pos; | |
701 | pt->read_end = pt->saved_read_end; | |
702 | pt->read_buf_size = pt->saved_read_buf_size; | |
703 | if (pt->read_pos < pt->read_end) | |
5c070ca7 | 704 | return *(pt->read_pos); |
6c951427 | 705 | } |
affc96b5 | 706 | return scm_ptobs[SCM_PTOBNUM (port)].fill_input (port); |
6c951427 GH |
707 | } |
708 | ||
ee149d03 | 709 | int |
a284e297 | 710 | scm_getc (SCM port) |
0f2d19dd JB |
711 | { |
712 | int c; | |
840ae05d | 713 | scm_port *pt = SCM_PTAB_ENTRY (port); |
ee149d03 | 714 | |
840ae05d JB |
715 | if (pt->rw_active == SCM_PORT_WRITE) |
716 | { | |
affc96b5 GH |
717 | /* may be marginally faster than calling scm_flush. */ |
718 | scm_ptobs[SCM_PTOBNUM (port)].flush (port); | |
840ae05d | 719 | } |
6c951427 | 720 | |
5c070ca7 GH |
721 | if (pt->rw_random) |
722 | pt->rw_active = SCM_PORT_READ; | |
723 | ||
724 | if (pt->read_pos >= pt->read_end) | |
ee149d03 | 725 | { |
affc96b5 | 726 | if (scm_fill_input (port) == EOF) |
5c070ca7 | 727 | return EOF; |
ee149d03 JB |
728 | } |
729 | ||
5c070ca7 | 730 | c = *(pt->read_pos++); |
840ae05d | 731 | |
ee149d03 JB |
732 | if (c == '\n') |
733 | { | |
734 | SCM_INCLINE (port); | |
735 | } | |
736 | else if (c == '\t') | |
737 | { | |
738 | SCM_TABCOL (port); | |
739 | } | |
740 | else | |
741 | { | |
742 | SCM_INCCOL (port); | |
743 | } | |
744 | ||
745 | return c; | |
0f2d19dd JB |
746 | } |
747 | ||
ee149d03 | 748 | void |
a284e297 | 749 | scm_putc (char c, SCM port) |
ee149d03 | 750 | { |
265e6a4d | 751 | scm_lfwrite (&c, 1, port); |
ee149d03 | 752 | } |
3cb988bd | 753 | |
ee149d03 | 754 | void |
a284e297 | 755 | scm_puts (char *s, SCM port) |
3cb988bd | 756 | { |
265e6a4d | 757 | scm_lfwrite (s, strlen (s), port); |
ee149d03 | 758 | } |
3cb988bd | 759 | |
ee149d03 | 760 | void |
a284e297 | 761 | scm_lfwrite (char *ptr, scm_sizet size, SCM port) |
ee149d03 | 762 | { |
840ae05d | 763 | scm_port *pt = SCM_PTAB_ENTRY (port); |
f12733c9 | 764 | scm_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)]; |
3e2043c4 | 765 | |
840ae05d | 766 | if (pt->rw_active == SCM_PORT_READ) |
affc96b5 | 767 | scm_end_input (port); |
283a1a0e | 768 | |
31703ab8 | 769 | ptob->write (port, ptr, size); |
840ae05d JB |
770 | |
771 | if (pt->rw_random) | |
772 | pt->rw_active = SCM_PORT_WRITE; | |
ee149d03 | 773 | } |
3cb988bd | 774 | |
3cb988bd | 775 | |
ee149d03 | 776 | void |
a284e297 | 777 | scm_flush (SCM port) |
ee149d03 JB |
778 | { |
779 | scm_sizet i = SCM_PTOBNUM (port); | |
affc96b5 | 780 | (scm_ptobs[i].flush) (port); |
ee149d03 JB |
781 | } |
782 | ||
283a1a0e | 783 | void |
a284e297 | 784 | scm_end_input (SCM port) |
283a1a0e GH |
785 | { |
786 | int offset; | |
787 | scm_port *pt = SCM_PTAB_ENTRY (port); | |
788 | ||
789 | if (pt->read_buf == pt->putback_buf) | |
790 | { | |
791 | offset = pt->read_end - pt->read_pos; | |
792 | pt->read_buf = pt->saved_read_buf; | |
793 | pt->read_pos = pt->saved_read_pos; | |
794 | pt->read_end = pt->saved_read_end; | |
795 | pt->read_buf_size = pt->saved_read_buf_size; | |
796 | } | |
797 | else | |
798 | offset = 0; | |
799 | ||
affc96b5 | 800 | scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset); |
283a1a0e GH |
801 | } |
802 | ||
ee149d03 JB |
803 | \f |
804 | ||
805 | ||
806 | void | |
a284e297 | 807 | scm_ungetc (int c, SCM port) |
ee149d03 | 808 | { |
840ae05d JB |
809 | scm_port *pt = SCM_PTAB_ENTRY (port); |
810 | ||
6c951427 GH |
811 | if (pt->read_buf == pt->putback_buf) |
812 | /* already using the put-back buffer. */ | |
813 | { | |
814 | /* enlarge putback_buf if necessary. */ | |
815 | if (pt->read_end == pt->read_buf + pt->read_buf_size | |
816 | && pt->read_buf == pt->read_pos) | |
817 | { | |
818 | int new_size = pt->read_buf_size * 2; | |
819 | unsigned char *tmp = | |
820 | (unsigned char *) realloc (pt->putback_buf, new_size); | |
821 | ||
822 | if (tmp == NULL) | |
823 | scm_memory_error ("scm_ungetc"); | |
824 | pt->read_pos = pt->read_buf = pt->putback_buf = tmp; | |
825 | pt->read_end = pt->read_buf + pt->read_buf_size; | |
826 | pt->read_buf_size = pt->putback_buf_size = new_size; | |
827 | } | |
828 | ||
829 | /* shift any existing bytes to buffer + 1. */ | |
830 | if (pt->read_pos == pt->read_end) | |
831 | pt->read_end = pt->read_buf + 1; | |
832 | else if (pt->read_pos != pt->read_buf + 1) | |
833 | { | |
834 | int count = pt->read_end - pt->read_pos; | |
835 | ||
836 | memmove (pt->read_buf + 1, pt->read_pos, count); | |
837 | pt->read_end = pt->read_buf + 1 + count; | |
838 | } | |
839 | ||
840 | pt->read_pos = pt->read_buf; | |
841 | } | |
842 | else | |
843 | /* switch to the put-back buffer. */ | |
844 | { | |
845 | if (pt->putback_buf == NULL) | |
846 | { | |
6e2e75db | 847 | pt->putback_buf = (char *) malloc (SCM_INITIAL_PUTBACK_BUF_SIZE); |
6c951427 GH |
848 | if (pt->putback_buf == NULL) |
849 | scm_memory_error ("scm_ungetc"); | |
850 | pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE; | |
851 | } | |
852 | ||
853 | pt->saved_read_buf = pt->read_buf; | |
854 | pt->saved_read_pos = pt->read_pos; | |
855 | pt->saved_read_end = pt->read_end; | |
856 | pt->saved_read_buf_size = pt->read_buf_size; | |
857 | ||
858 | pt->read_pos = pt->read_buf = pt->putback_buf; | |
859 | pt->read_end = pt->read_buf + 1; | |
860 | pt->read_buf_size = pt->putback_buf_size; | |
861 | } | |
862 | ||
863 | *pt->read_buf = c; | |
ee149d03 | 864 | |
840ae05d JB |
865 | if (pt->rw_random) |
866 | pt->rw_active = SCM_PORT_READ; | |
867 | ||
ee149d03 JB |
868 | if (c == '\n') |
869 | { | |
870 | /* What should col be in this case? | |
871 | * We'll leave it at -1. | |
872 | */ | |
873 | SCM_LINUM (port) -= 1; | |
874 | } | |
875 | else | |
876 | SCM_COL(port) -= 1; | |
877 | } | |
878 | ||
879 | ||
880 | void | |
a284e297 | 881 | scm_ungets (char *s, int n, SCM port) |
ee149d03 JB |
882 | { |
883 | /* This is simple minded and inefficient, but unreading strings is | |
884 | * probably not a common operation, and remember that line and | |
885 | * column numbers have to be handled... | |
886 | * | |
887 | * Please feel free to write an optimized version! | |
888 | */ | |
889 | while (n--) | |
890 | scm_ungetc (s[n], port); | |
891 | } | |
892 | ||
893 | ||
894 | SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); | |
895 | ||
896 | SCM | |
a284e297 | 897 | scm_peek_char (SCM port) |
ee149d03 JB |
898 | { |
899 | int c; | |
900 | if (SCM_UNBNDP (port)) | |
901 | port = scm_cur_inp; | |
902 | else | |
903 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); | |
904 | c = scm_getc (port); | |
905 | if (EOF == c) | |
906 | return SCM_EOF_VAL; | |
907 | scm_ungetc (c, port); | |
908 | return SCM_MAKICHR (c); | |
3cb988bd TP |
909 | } |
910 | ||
0f2d19dd | 911 | SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); |
1cc91f1b | 912 | |
0f2d19dd | 913 | SCM |
a284e297 | 914 | scm_unread_char (SCM cobj, SCM port) |
0f2d19dd JB |
915 | { |
916 | int c; | |
917 | ||
918 | SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); | |
919 | ||
920 | if (SCM_UNBNDP (port)) | |
921 | port = scm_cur_inp; | |
922 | else | |
923 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); | |
924 | ||
925 | ||
926 | c = SCM_ICHR (cobj); | |
927 | ||
b7f3516f | 928 | scm_ungetc (c, port); |
0f2d19dd JB |
929 | return cobj; |
930 | } | |
931 | ||
ee1e7e13 MD |
932 | SCM_PROC (s_unread_string, "unread-string", 2, 0, 0, scm_unread_string); |
933 | ||
934 | SCM | |
a284e297 | 935 | scm_unread_string (SCM str, SCM port) |
ee1e7e13 | 936 | { |
d1c90db5 | 937 | SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), |
ee1e7e13 MD |
938 | str, SCM_ARG1, s_unread_string); |
939 | ||
940 | if (SCM_UNBNDP (port)) | |
941 | port = scm_cur_inp; | |
942 | else | |
943 | SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), | |
944 | port, SCM_ARG2, s_unread_string); | |
945 | ||
d1c90db5 | 946 | scm_ungets (SCM_ROUCHARS (str), SCM_LENGTH (str), port); |
ee1e7e13 MD |
947 | |
948 | return str; | |
949 | } | |
950 | ||
c94577b4 | 951 | SCM_PROC (s_seek, "seek", 3, 0, 0, scm_seek); |
840ae05d | 952 | SCM |
c94577b4 | 953 | scm_seek (SCM object, SCM offset, SCM whence) |
840ae05d JB |
954 | { |
955 | off_t off; | |
956 | off_t rv; | |
957 | int how; | |
958 | ||
959 | object = SCM_COERCE_OUTPORT (object); | |
960 | ||
c94577b4 GH |
961 | off = scm_num2long (offset, (char *)SCM_ARG2, s_seek); |
962 | SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_seek); | |
840ae05d JB |
963 | how = SCM_INUM (whence); |
964 | if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END) | |
c94577b4 | 965 | scm_out_of_range (s_seek, whence); |
840ae05d JB |
966 | if (SCM_NIMP (object) && SCM_OPPORTP (object)) |
967 | { | |
f12733c9 | 968 | scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); |
840ae05d JB |
969 | |
970 | if (!ptob->seek) | |
c94577b4 | 971 | scm_misc_error (s_seek, "port is not seekable", |
840ae05d JB |
972 | scm_cons (object, SCM_EOL)); |
973 | else | |
7dcb364d | 974 | rv = ptob->seek (object, off, how); |
840ae05d JB |
975 | } |
976 | else /* file descriptor?. */ | |
977 | { | |
c94577b4 | 978 | SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_seek); |
840ae05d JB |
979 | rv = lseek (SCM_INUM (object), off, how); |
980 | if (rv == -1) | |
c94577b4 | 981 | scm_syserror (s_seek); |
840ae05d JB |
982 | } |
983 | return scm_long2num (rv); | |
984 | } | |
985 | ||
69bc9ff3 | 986 | SCM_PROC (s_truncate_file, "truncate-file", 1, 1, 0, scm_truncate_file); |
840ae05d JB |
987 | |
988 | SCM | |
69bc9ff3 | 989 | scm_truncate_file (SCM object, SCM length) |
840ae05d | 990 | { |
69bc9ff3 GH |
991 | int rv; |
992 | off_t c_length; | |
993 | ||
994 | /* object can be a port, fdes or filename. */ | |
840ae05d | 995 | |
840ae05d JB |
996 | if (SCM_UNBNDP (length)) |
997 | { | |
69bc9ff3 GH |
998 | /* must supply length if object is a filename. */ |
999 | if (SCM_NIMP (object) && SCM_ROSTRINGP (object)) | |
1000 | scm_wrong_num_args (scm_makfrom0str (s_truncate_file)); | |
1001 | ||
c94577b4 | 1002 | length = scm_seek (object, SCM_INUM0, SCM_MAKINUM (SEEK_CUR)); |
840ae05d | 1003 | } |
69bc9ff3 GH |
1004 | c_length = scm_num2long (length, (char *)SCM_ARG2, s_truncate_file); |
1005 | if (c_length < 0) | |
1006 | scm_misc_error (s_truncate_file, "negative offset", SCM_EOL); | |
3fe6190f | 1007 | |
69bc9ff3 GH |
1008 | object = SCM_COERCE_OUTPORT (object); |
1009 | if (SCM_INUMP (object)) | |
1010 | { | |
1011 | SCM_SYSCALL (rv = ftruncate (SCM_INUM (object), c_length)); | |
1012 | } | |
1013 | else if (SCM_NIMP (object) && SCM_OPOUTPORTP (object)) | |
1014 | { | |
1015 | scm_port *pt = SCM_PTAB_ENTRY (object); | |
f12733c9 | 1016 | scm_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object); |
69bc9ff3 | 1017 | |
affc96b5 | 1018 | if (!ptob->truncate) |
69bc9ff3 GH |
1019 | scm_misc_error (s_truncate_file, "port is not truncatable", SCM_EOL); |
1020 | if (pt->rw_active == SCM_PORT_READ) | |
affc96b5 | 1021 | scm_end_input (object); |
69bc9ff3 | 1022 | else if (pt->rw_active == SCM_PORT_WRITE) |
affc96b5 | 1023 | ptob->flush (object); |
69bc9ff3 | 1024 | |
affc96b5 | 1025 | ptob->truncate (object, c_length); |
69bc9ff3 GH |
1026 | rv = 0; |
1027 | } | |
1028 | else | |
1029 | { | |
1030 | SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object), | |
1031 | object, SCM_ARG1, s_truncate_file); | |
1032 | SCM_COERCE_SUBSTR (object); | |
1033 | SCM_SYSCALL (rv = truncate (SCM_ROCHARS (object), c_length)); | |
1034 | } | |
1035 | if (rv == -1) | |
1036 | scm_syserror (s_truncate_file); | |
840ae05d JB |
1037 | return SCM_UNSPECIFIED; |
1038 | } | |
1039 | ||
360fc44c | 1040 | SCM_PROC (s_port_line, "port-line", 1, 0, 0, scm_port_line); |
1cc91f1b | 1041 | |
0f2d19dd | 1042 | SCM |
a284e297 | 1043 | scm_port_line (SCM port) |
0f2d19dd | 1044 | { |
78446828 | 1045 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1046 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1047 | port, | |
1048 | SCM_ARG1, | |
1049 | s_port_line); | |
1050 | return SCM_MAKINUM (SCM_LINUM (port)); | |
0f2d19dd JB |
1051 | } |
1052 | ||
360fc44c | 1053 | SCM_PROC (s_set_port_line_x, "set-port-line!", 2, 0, 0, scm_set_port_line_x); |
d043d8c2 MD |
1054 | |
1055 | SCM | |
a284e297 | 1056 | scm_set_port_line_x (SCM port, SCM line) |
d043d8c2 | 1057 | { |
360fc44c MD |
1058 | port = SCM_COERCE_OUTPORT (port); |
1059 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1060 | port, | |
1061 | SCM_ARG1, | |
1062 | s_set_port_line_x); | |
1063 | SCM_ASSERT (SCM_INUMP (line), line, SCM_ARG2, s_set_port_line_x); | |
d043d8c2 MD |
1064 | return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); |
1065 | } | |
1066 | ||
360fc44c | 1067 | SCM_PROC (s_port_column, "port-column", 1, 0, 0, scm_port_column); |
1cc91f1b | 1068 | |
0f2d19dd | 1069 | SCM |
a284e297 | 1070 | scm_port_column (SCM port) |
0f2d19dd | 1071 | { |
78446828 | 1072 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1073 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1074 | port, | |
1075 | SCM_ARG1, | |
1076 | s_port_column); | |
1077 | return SCM_MAKINUM (SCM_COL (port)); | |
0f2d19dd JB |
1078 | } |
1079 | ||
360fc44c | 1080 | SCM_PROC (s_set_port_column_x, "set-port-column!", 2, 0, 0, scm_set_port_column_x); |
d043d8c2 MD |
1081 | |
1082 | SCM | |
a284e297 | 1083 | scm_set_port_column_x (SCM port, SCM column) |
d043d8c2 | 1084 | { |
360fc44c MD |
1085 | port = SCM_COERCE_OUTPORT (port); |
1086 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1087 | port, | |
1088 | SCM_ARG1, | |
1089 | s_set_port_column_x); | |
1090 | SCM_ASSERT (SCM_INUMP (column), column, SCM_ARG2, s_set_port_column_x); | |
d043d8c2 MD |
1091 | return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); |
1092 | } | |
1093 | ||
360fc44c | 1094 | SCM_PROC (s_port_filename, "port-filename", 1, 0, 0, scm_port_filename); |
1cc91f1b | 1095 | |
0f2d19dd | 1096 | SCM |
a284e297 | 1097 | scm_port_filename (SCM port) |
0f2d19dd | 1098 | { |
78446828 | 1099 | port = SCM_COERCE_OUTPORT (port); |
360fc44c MD |
1100 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), |
1101 | port, | |
1102 | SCM_ARG1, | |
1103 | s_port_filename); | |
1104 | return SCM_PTAB_ENTRY (port)->file_name; | |
0f2d19dd JB |
1105 | } |
1106 | ||
360fc44c | 1107 | SCM_PROC (s_set_port_filename_x, "set-port-filename!", 2, 0, 0, scm_set_port_filename_x); |
1cc91f1b | 1108 | |
d14af9f2 | 1109 | SCM |
a284e297 | 1110 | scm_set_port_filename_x (SCM port, SCM filename) |
d14af9f2 | 1111 | { |
360fc44c MD |
1112 | port = SCM_COERCE_OUTPORT (port); |
1113 | SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), | |
1114 | port, | |
1115 | SCM_ARG1, | |
1116 | s_set_port_filename_x); | |
1117 | /* We allow the user to set the filename to whatever he likes. */ | |
d14af9f2 MD |
1118 | return SCM_PTAB_ENTRY (port)->file_name = filename; |
1119 | } | |
1120 | ||
0f2d19dd JB |
1121 | #ifndef ttyname |
1122 | extern char * ttyname(); | |
1123 | #endif | |
1124 | ||
f12733c9 MD |
1125 | void |
1126 | scm_print_port_mode (SCM exp, SCM port) | |
1127 | { | |
1128 | scm_puts (SCM_CLOSEDP (exp) | |
1129 | ? "closed: " | |
1130 | : (SCM_RDNG & SCM_CAR (exp) | |
1131 | ? (SCM_WRTNG & SCM_CAR (exp) | |
1132 | ? "input-output: " | |
1133 | : "input: ") | |
1134 | : (SCM_WRTNG & SCM_CAR (exp) | |
1135 | ? "output: " | |
1136 | : "bogus: ")), | |
1137 | port); | |
1138 | } | |
1cc91f1b | 1139 | |
f12733c9 MD |
1140 | int |
1141 | scm_port_print (SCM exp, SCM port, scm_print_state *pstate) | |
0f2d19dd | 1142 | { |
f12733c9 MD |
1143 | char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp)); |
1144 | if (!type) | |
1145 | type = "port"; | |
b7f3516f | 1146 | scm_puts ("#<", port); |
f12733c9 | 1147 | scm_print_port_mode (exp, port); |
b7f3516f TT |
1148 | scm_puts (type, port); |
1149 | scm_putc (' ', port); | |
f12733c9 | 1150 | scm_intprint (SCM_CDR (exp), 16, port); |
b7f3516f | 1151 | scm_putc ('>', port); |
f12733c9 | 1152 | return 1; |
0f2d19dd JB |
1153 | } |
1154 | ||
f12733c9 MD |
1155 | extern void scm_make_fptob (); |
1156 | extern void scm_make_stptob (); | |
1157 | extern void scm_make_sfptob (); | |
1cc91f1b | 1158 | |
0f2d19dd JB |
1159 | void |
1160 | scm_ports_prehistory () | |
0f2d19dd JB |
1161 | { |
1162 | scm_numptob = 0; | |
f12733c9 | 1163 | scm_ptobs = (scm_ptob_descriptor *) malloc (sizeof (scm_ptob_descriptor)); |
0f2d19dd JB |
1164 | |
1165 | /* WARNING: These scm_newptob calls must be done in this order. | |
1166 | * They must agree with the port declarations in tags.h. | |
1167 | */ | |
f12733c9 MD |
1168 | /* scm_tc16_fport = */ scm_make_fptob (); |
1169 | /* scm_tc16_pipe was here */ scm_make_fptob (); /* dummy. */ | |
1170 | /* scm_tc16_strport = */ scm_make_stptob (); | |
1171 | /* scm_tc16_sfport = */ scm_make_sfptob (); | |
0f2d19dd | 1172 | } |
0f2d19dd JB |
1173 | |
1174 | \f | |
ee149d03 | 1175 | |
d68fee48 | 1176 | /* Void ports. */ |
0f2d19dd | 1177 | |
f12733c9 | 1178 | long scm_tc16_void_port = 0; |
0f2d19dd | 1179 | |
ee149d03 | 1180 | static void |
0f88a8f3 | 1181 | flush_void_port (SCM port) |
0f2d19dd | 1182 | { |
3cb988bd | 1183 | } |
1cc91f1b | 1184 | |
283a1a0e | 1185 | static void |
affc96b5 | 1186 | end_input_void_port (SCM port, int offset) |
283a1a0e GH |
1187 | { |
1188 | } | |
1189 | ||
31703ab8 GH |
1190 | static void |
1191 | write_void_port (SCM port, void *data, size_t size) | |
1192 | { | |
1193 | } | |
1194 | ||
0f2d19dd | 1195 | SCM |
a284e297 | 1196 | scm_void_port (char *mode_str) |
0f2d19dd JB |
1197 | { |
1198 | int mode_bits; | |
1199 | SCM answer; | |
840ae05d | 1200 | scm_port * pt; |
0f2d19dd JB |
1201 | |
1202 | SCM_NEWCELL (answer); | |
1203 | SCM_DEFER_INTS; | |
1204 | mode_bits = scm_mode_bits (mode_str); | |
1205 | pt = scm_add_to_port_table (answer); | |
0f2d19dd | 1206 | SCM_SETPTAB_ENTRY (answer, pt); |
ee149d03 JB |
1207 | SCM_SETSTREAM (answer, 0); |
1208 | SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); | |
0f2d19dd JB |
1209 | SCM_ALLOW_INTS; |
1210 | return answer; | |
1211 | } | |
1212 | ||
1213 | ||
1214 | SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); | |
1cc91f1b | 1215 | |
0f2d19dd | 1216 | SCM |
a284e297 | 1217 | scm_sys_make_void_port (SCM mode) |
0f2d19dd | 1218 | { |
89958ad0 | 1219 | SCM_ASSERT (SCM_NIMP (mode) && SCM_ROSTRINGP (mode), mode, |
0f2d19dd JB |
1220 | SCM_ARG1, s_sys_make_void_port); |
1221 | ||
89958ad0 | 1222 | SCM_COERCE_SUBSTR (mode); |
0f2d19dd JB |
1223 | return scm_void_port (SCM_ROCHARS (mode)); |
1224 | } | |
1225 | ||
0f2d19dd | 1226 | \f |
89545eba | 1227 | /* Initialization. */ |
1cc91f1b | 1228 | |
0f2d19dd JB |
1229 | void |
1230 | scm_init_ports () | |
0f2d19dd | 1231 | { |
840ae05d JB |
1232 | /* lseek() symbols. */ |
1233 | scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); | |
1234 | scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); | |
1235 | scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); | |
1236 | ||
affc96b5 | 1237 | scm_tc16_void_port = scm_make_port_type ("void", 0, write_void_port); |
0f2d19dd JB |
1238 | #include "ports.x" |
1239 | } |