1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
/*
* Copyright © 2018 Keith Packard <keithp@keithp.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation, either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* General Public License for more details.
*/
#include "ao_scheme.h"
#ifdef AO_SCHEME_FEATURE_PORT
static void port_mark(void *addr)
{
(void) addr;
}
static int port_size(void *addr)
{
(void) addr;
return sizeof(struct ao_scheme_port);
}
static void port_move(void *addr)
{
struct ao_scheme_port *port = addr;
(void) ao_scheme_poly_move(&port->next, 0);
}
const struct ao_scheme_type ao_scheme_port_type = {
.mark = port_mark,
.size = port_size,
.move = port_move,
.name = "port",
};
void
ao_scheme_port_write(FILE *out, ao_poly v, bool write)
{
(void) write;
ao_scheme_fprintf(out, "#port<%d>", fileno(ao_scheme_poly_port(v)->file));
}
ao_poly ao_scheme_stdin, ao_scheme_stdout, ao_scheme_stderr;
ao_poly ao_scheme_open_ports;
void
ao_scheme_port_check_references(void)
{
struct ao_scheme_port *p;
for (p = ao_scheme_poly_port(ao_scheme_open_ports); p; p = ao_scheme_poly_port(p->next)) {
if (!ao_scheme_marked(p))
ao_scheme_port_close(p);
}
}
struct ao_scheme_port *
ao_scheme_port_alloc(FILE *file, bool stayopen)
{
struct ao_scheme_port *p;
p = ao_scheme_alloc(sizeof (struct ao_scheme_port));
if (!p)
return NULL;
p->type = AO_SCHEME_PORT;
p->stayopen = stayopen;
p->file = file;
p->next = ao_scheme_open_ports;
ao_scheme_open_ports = ao_scheme_port_poly(p);
return p;
}
void
ao_scheme_port_close(struct ao_scheme_port *port)
{
ao_poly *prev;
struct ao_scheme_port *ref;
if (port->file && !port->stayopen) {
fclose(port->file);
port->file = NULL;
for (prev = &ao_scheme_open_ports; (ref = ao_scheme_poly_port(*prev)); prev = &ref->next)
if (ref == port) {
*prev = port->next;
break;
}
}
}
ao_poly
ao_scheme_do_portp(struct ao_scheme_cons *cons)
{
return ao_scheme_do_typep(_ao_scheme_atom_port3f, AO_SCHEME_PORT, cons);
}
ao_poly
ao_scheme_do_port_openp(struct ao_scheme_cons *cons)
{
struct ao_scheme_port *port;
if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons,
AO_SCHEME_PORT, &port,
AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
return port->file ? _ao_scheme_bool_true : _ao_scheme_bool_false;
}
static ao_poly
ao_scheme_do_open_file(ao_poly proc, struct ao_scheme_cons *cons, const char *mode)
{
FILE *file;
struct ao_scheme_string *name;
if (!ao_scheme_parse_args(proc, cons,
AO_SCHEME_STRING, &name,
AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
file = fopen(name->val, mode);
if (!file)
return ao_scheme_error(AO_SCHEME_FILEERROR,
"%v: no such file \"%v\"",
proc, name);
return ao_scheme_port_poly(ao_scheme_port_alloc(file, false));
}
ao_poly
ao_scheme_do_open_input_file(struct ao_scheme_cons *cons)
{
return ao_scheme_do_open_file(_ao_scheme_atom_open2dinput2dfile, cons, "r");
}
ao_poly
ao_scheme_do_open_output_file(struct ao_scheme_cons *cons)
{
return ao_scheme_do_open_file(_ao_scheme_atom_open2doutput2dfile, cons, "w");
}
ao_poly
ao_scheme_do_close_port(struct ao_scheme_cons *cons)
{
struct ao_scheme_port *port;
if (!ao_scheme_parse_args(_ao_scheme_atom_port2dopen3f, cons,
AO_SCHEME_PORT, &port,
AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
ao_scheme_port_close(port);
return _ao_scheme_bool_true;
}
ao_poly
ao_scheme_do_current_input_port(struct ao_scheme_cons *cons)
{
if (!ao_scheme_parse_args(_ao_scheme_atom_current2dinput2dport, cons,
AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
if (!ao_scheme_stdin)
ao_scheme_stdin = ao_scheme_port_poly(ao_scheme_port_alloc(stdin, true));
return ao_scheme_stdin;
}
ao_poly
ao_scheme_do_current_output_port(struct ao_scheme_cons *cons)
{
if (!ao_scheme_parse_args(_ao_scheme_atom_current2doutput2dport, cons,
AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
if (!ao_scheme_stdout)
ao_scheme_stdout = ao_scheme_port_poly(ao_scheme_port_alloc(stdout, true));
return ao_scheme_stdout;
}
ao_poly
ao_scheme_do_current_error_port(struct ao_scheme_cons *cons)
{
if (!ao_scheme_parse_args(_ao_scheme_atom_current2derror2dport, cons,
AO_SCHEME_ARG_END))
return AO_SCHEME_NIL;
if (!ao_scheme_stderr)
ao_scheme_stderr = ao_scheme_port_poly(ao_scheme_port_alloc(stderr, true));
return ao_scheme_stderr;
}
#endif /* AO_SCHEME_FEATURE_PORT */
|
