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