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