libguile/strports.c

   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
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "unif.h"
  46 #include "eval.h"
  47 #include "read.h"
  48
  49 #include "strports.h"
  50
  51 #ifdef HAVE_STRING_H
  52 #include <string.h>
  53 #endif
  54
  55 \f
  56
  57 /* {Ports - string ports}
  58  *
  59  */
  60
  61
  62 static int prinstpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
  63
  64 static int
  65 prinstpt (exp, port, pstate)
  66      SCM exp;
  67      SCM port;
  68      scm_print_state *pstate;
  69 {
  70   scm_prinport (exp, port, "string");
  71   return !0;
  72 }
  73
  74
  75 static int stputc SCM_P ((int c, SCM p));
  76
  77 static int
  78 stputc (c, p)
  79      int c;
  80      SCM p;
  81 {
  82   scm_sizet ind = SCM_INUM (SCM_CAR (p));
  83   SCM_DEFER_INTS;
  84   if (ind >= SCM_LENGTH (SCM_CDR (p)))
  85     scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1)));
  86   SCM_ALLOW_INTS;
  87   SCM_CHARS (SCM_CDR (p))[ind] = c;
  88   SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
  89   return c;
  90 }
  91
  92
  93 static scm_sizet stwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p));
  94
  95 static scm_sizet
  96 stwrite (str, siz, num, p)
  97      char *str;
  98      scm_sizet siz;
  99      scm_sizet num;
 100      SCM p;
 101 {
 102   scm_sizet ind = SCM_INUM (SCM_CAR (p));
 103   scm_sizet len = siz * num;
 104   char *dst;
 105   SCM_DEFER_INTS;
 106   if (ind + len >= SCM_LENGTH (SCM_CDR (p)))
 107     scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1)));
 108   SCM_ALLOW_INTS;
 109   dst = &(SCM_CHARS (SCM_CDR (p))[ind]);
 110   while (len--)
 111     dst[len] = str[len];
 112   SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num));
 113   return num;
 114 }
 115
 116
 117 static int stputs SCM_P ((char *s, SCM p));
 118
 119 static int
 120 stputs (s, p)
 121      char *s;
 122      SCM p;
 123 {
 124   stwrite (s, 1, strlen (s), p);
 125   return 0;
 126 }
 127
 128
 129 static int stgetc SCM_P ((SCM p));
 130
 131 static int
 132 stgetc (p)
 133      SCM p;
 134 {
 135   scm_sizet ind = SCM_INUM (SCM_CAR (p));
 136   if (ind >= SCM_ROLENGTH (SCM_CDR (p)))
 137     return EOF;
 138   SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
 139   return SCM_ROUCHARS (SCM_CDR (p))[ind];
 140 }
 141
 142
 143 SCM
 144 scm_mkstrport (pos, str, modes, caller)
 145      SCM pos;
 146      SCM str;
 147      long modes;
 148      char * caller;
 149 {
 150   SCM z;
 151   SCM stream;
 152   struct scm_port_table * pt;
 153
 154   SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller);
 155   SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller);
 156   stream = scm_cons(pos, str);
 157   SCM_NEWCELL (z);
 158   SCM_DEFER_INTS;
 159   pt = scm_add_to_port_table (z);
 160   SCM_SETCAR (z, scm_tc16_strport | modes);
 161   SCM_SETPTAB_ENTRY (z, pt);
 162   SCM_SETSTREAM (z, stream);
 163   SCM_ALLOW_INTS;
 164   return z;
 165 }
 166
 167 SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string);
 168
 169 SCM
 170 scm_call_with_output_string (proc)
 171      SCM proc;
 172 {
 173   SCM p;
 174   p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED),
 175                         SCM_OPN | SCM_WRTNG,
 176                         s_call_with_output_string);
 177   scm_apply (proc, p, scm_listofnull);
 178   {
 179     SCM answer;
 180     SCM_DEFER_INTS;
 181     answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))),
 182                              SCM_INUM (SCM_CAR (SCM_STREAM (p))),
 183                              0);
 184     SCM_ALLOW_INTS;
 185     return answer;
 186   }
 187 }
 188
 189
 190
 191 /* Return a Scheme string obtained by printing a given object.
 192  */
 193
 194
 195 SCM
 196 scm_strprint_obj (obj)
 197      SCM obj;
 198 {
 199   SCM str;
 200   SCM port;
 201
 202   str = scm_makstr (64, 0);
 203   port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj");
 204   scm_prin1 (obj, port, 1);
 205   {
 206     SCM answer;
 207     SCM_DEFER_INTS;
 208     answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))),
 209                              SCM_INUM (SCM_CAR (SCM_STREAM (port))),
 210                              0);
 211     SCM_ALLOW_INTS;
 212     return answer;
 213   }
 214 }
 215
 216
 217
 218
 219 SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string);
 220
 221 SCM
 222 scm_call_with_input_string (str, proc)
 223      SCM str;
 224      SCM proc;
 225 {
 226   SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string);
 227   return scm_apply (proc, p, scm_listofnull);
 228 }
 229
 230
 231
 232 /* Given a null-terminated string EXPR containing a Scheme expression
 233    read it, and return it as an SCM value. */
 234 SCM
 235 scm_read_0str (expr)
 236      char *expr;
 237 {
 238   SCM port = scm_mkstrport (SCM_MAKINUM (0),
 239                             scm_makfrom0str (expr),
 240                             SCM_OPN | SCM_RDNG,
 241                             "scm_eval_0str");
 242   SCM form;
 243
 244   /* Read expressions from that port; ignore the values.  */
 245   form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F);
 246
 247   scm_close_port (port);
 248   return form;
 249 }
 250
 251 /* Given a null-terminated string EXPR containing Scheme program text,
 252    evaluate it, and return the result of the last expression evaluated.  */
 253 SCM
 254 scm_eval_0str (expr)
 255      char *expr;
 256 {
 257   SCM port = scm_mkstrport (SCM_MAKINUM (0),
 258                             scm_makfrom0str (expr),
 259                             SCM_OPN | SCM_RDNG,
 260                             "scm_eval_0str");
 261   SCM form;
 262   SCM ans;
 263
 264   /* Read expressions from that port; ignore the values.  */
 265   while ((form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F)) != SCM_EOF_VAL)
 266     ans = scm_eval_x (form);
 267
 268   scm_close_port (port);
 269   return ans;
 270 }
 271
 272
 273 static int noop0 SCM_P ((SCM stream));
 274
 275 static int
 276 noop0 (stream)
 277      SCM stream;
 278 {
 279   return 0;
 280 }
 281
 282
 283 scm_ptobfuns scm_stptob =
 284 {
 285   scm_markstream,
 286   noop0,
 287   prinstpt,
 288   0,
 289   stputc,
 290   stputs,
 291   stwrite,
 292   noop0,
 293   stgetc,
 294   0
 295 };
 296
 297
 298
 299 void
 300 scm_init_strports ()
 301 {
 302 #include "strports.x"
 303 }
 304