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, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  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
  63 prinstpt (SCM exp, SCM port, scm_print_state *pstate)
  64 {
  65   scm_prinport (exp, port, "string");
  66   return !0;
  67 }
  68
  69
  70 static int
  71 stputc (int c, SCM port)
  72 {
  73   SCM p = SCM_STREAM (port);
  74   scm_sizet ind = SCM_INUM (SCM_CAR (p));
  75   SCM_DEFER_INTS;
  76   if (ind >= SCM_LENGTH (SCM_CDR (p)))
  77     scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1)));
  78   SCM_ALLOW_INTS;
  79   SCM_CHARS (SCM_CDR (p))[ind] = c;
  80   SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
  81   return c;
  82 }
  83
  84
  85 static scm_sizet
  86 stwrite (char *str,
  87          scm_sizet siz,
  88          scm_sizet num,
  89          SCM port)
  90 {
  91   SCM p = SCM_STREAM (port);
  92
  93   scm_sizet ind = SCM_INUM (SCM_CAR (p));
  94   scm_sizet len = siz * num;
  95   char *dst;
  96   SCM_DEFER_INTS;
  97   if (ind + len >= SCM_LENGTH (SCM_CDR (p)))
  98     scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1)));
  99   SCM_ALLOW_INTS;
 100   dst = &(SCM_CHARS (SCM_CDR (p))[ind]);
 101   while (len--)
 102     dst[len] = str[len];
 103   SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num));
 104   return num;
 105 }
 106
 107
 108 static int
 109 stputs (char *s, SCM port)
 110 {
 111   stwrite (s, 1, strlen (s), port);
 112   return 0;
 113 }
 114
 115
 116 static int
 117 stgetc (SCM port)
 118 {
 119   SCM p = SCM_STREAM (port);
 120
 121   scm_sizet ind = SCM_INUM (SCM_CAR (p));
 122   if (ind >= SCM_ROLENGTH (SCM_CDR (p)))
 123     return EOF;
 124   SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
 125   return SCM_ROUCHARS (SCM_CDR (p))[ind];
 126 }
 127
 128
 129 SCM
 130 scm_mkstrport (pos, str, modes, caller)
 131      SCM pos;
 132      SCM str;
 133      long modes;
 134      char * caller;
 135 {
 136   SCM z;
 137   SCM stream;
 138   struct scm_port_table * pt;
 139
 140   SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller);
 141   SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller);
 142   stream = scm_cons(pos, str);
 143   SCM_NEWCELL (z);
 144   SCM_DEFER_INTS;
 145   pt = scm_add_to_port_table (z);
 146   SCM_SETCAR (z, scm_tc16_strport | modes);
 147   SCM_SETPTAB_ENTRY (z, pt);
 148   SCM_SETSTREAM (z, stream);
 149   SCM_ALLOW_INTS;
 150   return z;
 151 }
 152
 153 SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string);
 154
 155 SCM
 156 scm_call_with_output_string (proc)
 157      SCM proc;
 158 {
 159   SCM p;
 160   p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED),
 161                         SCM_OPN | SCM_WRTNG,
 162                         s_call_with_output_string);
 163   scm_apply (proc, p, scm_listofnull);
 164   {
 165     SCM answer;
 166     SCM_DEFER_INTS;
 167     answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))),
 168                              SCM_INUM (SCM_CAR (SCM_STREAM (p))),
 169                              0);
 170     SCM_ALLOW_INTS;
 171     return answer;
 172   }
 173 }
 174
 175
 176
 177 /* Return a Scheme string obtained by printing a given object.
 178  */
 179
 180
 181 SCM
 182 scm_strprint_obj (obj)
 183      SCM obj;
 184 {
 185   SCM str;
 186   SCM port;
 187
 188   str = scm_makstr (64, 0);
 189   port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj");
 190   scm_prin1 (obj, port, 1);
 191   {
 192     SCM answer;
 193     SCM_DEFER_INTS;
 194     answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))),
 195                              SCM_INUM (SCM_CAR (SCM_STREAM (port))),
 196                              0);
 197     SCM_ALLOW_INTS;
 198     return answer;
 199   }
 200 }
 201
 202
 203
 204
 205 SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string);
 206
 207 SCM
 208 scm_call_with_input_string (str, proc)
 209      SCM str;
 210      SCM proc;
 211 {
 212   SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string);
 213   return scm_apply (proc, p, scm_listofnull);
 214 }
 215
 216
 217
 218 /* Given a null-terminated string EXPR containing a Scheme expression
 219    read it, and return it as an SCM value. */
 220 SCM
 221 scm_read_0str (expr)
 222      char *expr;
 223 {
 224   SCM port = scm_mkstrport (SCM_MAKINUM (0),
 225                             scm_makfrom0str (expr),
 226                             SCM_OPN | SCM_RDNG,
 227                             "scm_eval_0str");
 228   SCM form;
 229
 230   /* Read expressions from that port; ignore the values.  */
 231   form = scm_read (port);
 232
 233   scm_close_port (port);
 234   return form;
 235 }
 236
 237 /* Given a null-terminated string EXPR containing Scheme program text,
 238    evaluate it, and return the result of the last expression evaluated.  */
 239 SCM
 240 scm_eval_0str (expr)
 241      char *expr;
 242 {
 243   return scm_eval_string (scm_makfrom0str (expr));
 244 }
 245
 246
 247 SCM_PROC (s_eval_string, "eval-string", 1, 0, 0, scm_eval_string);
 248
 249 SCM
 250 scm_eval_string (string)
 251      SCM string;
 252 {
 253   SCM port = scm_mkstrport (SCM_MAKINUM (0), string, SCM_OPN | SCM_RDNG,
 254                             "scm_eval_0str");
 255   SCM form;
 256   SCM ans = SCM_UNSPECIFIED;
 257
 258   /* Read expressions from that port; ignore the values.  */
 259   while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
 260     ans = scm_eval_x (form);
 261
 262   /* Don't close the port here; if we re-enter this function via a
 263      continuation, then the next time we enter it, we'll get an error.
 264      It's a string port anyway, so there's no advantage to closing it
 265      early.  */
 266
 267   return ans;
 268 }
 269
 270
 271
 272 static int noop0 SCM_P ((SCM stream));
 273
 274 static int
 275 noop0 (stream)
 276      SCM stream;
 277 {
 278   return 0;
 279 }
 280
 281
 282 scm_ptobfuns scm_stptob =
 283 {
 284   scm_markstream,
 285   noop0,
 286   prinstpt,
 287   0,
 288   stputc,
 289   stputs,
 290   stwrite,
 291   noop0,
 292   stgetc,
 293   scm_generic_fgets,
 294   0
 295 };
 296
 297
 298
 299 void
 300 scm_init_strports ()
 301 {
 302 #include "strports.x"
 303 }
 304