git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_port.c

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