libguile/discouraged.c

   1 /* This file contains definitions for discouraged features.  When you
   2    discourage something, move it here when that is feasible.
   3 */
   4
   5 /* Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
   6  *
   7  * This library is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU Lesser General Public
   9  * License as published by the Free Software Foundation; either
  10  * version 2.1 of the License, or (at your option) any later version.
  11  *
  12  * This library is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15  * Lesser General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU Lesser General Public
  18  * License along with this library; if not, write to the Free Software
  19  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20  */
  21
  22 #include "libguile.h"
  23
  24 #if (SCM_ENABLE_DISCOURAGED == 1)
  25
  26 SCM
  27 scm_short2num (short x)
  28 {
  29   return scm_from_short (x);
  30 }
  31
  32 SCM
  33 scm_ushort2num (unsigned short x)
  34 {
  35   return scm_from_ushort (x);
  36 }
  37
  38 SCM
  39 scm_int2num (int x)
  40 {
  41   return scm_from_int (x);
  42 }
  43
  44 SCM
  45 scm_uint2num (unsigned int x)
  46 {
  47   return scm_from_uint (x);
  48 }
  49
  50 SCM
  51 scm_long2num (long x)
  52 {
  53   return scm_from_long (x);
  54 }
  55
  56 SCM
  57 scm_ulong2num (unsigned long x)
  58 {
  59   return scm_from_ulong (x);
  60 }
  61
  62 SCM
  63 scm_size2num (size_t x)
  64 {
  65   return scm_from_size_t (x);
  66 }
  67
  68 SCM
  69 scm_ptrdiff2num (ptrdiff_t x)
  70 {
  71   return scm_from_ssize_t (x);
  72 }
  73
  74 short
  75 scm_num2short (SCM x, unsigned long pos, const char *s_caller)
  76 {
  77   return scm_to_short (x);
  78 }
  79
  80 unsigned short
  81 scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
  82 {
  83   return scm_to_ushort (x);
  84 }
  85
  86 int
  87 scm_num2int (SCM x, unsigned long pos, const char *s_caller)
  88 {
  89   return scm_to_int (x);
  90 }
  91
  92 unsigned int
  93 scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
  94 {
  95   return scm_to_uint (x);
  96 }
  97
  98 long
  99 scm_num2long (SCM x, unsigned long pos, const char *s_caller)
 100 {
 101   return scm_to_long (x);
 102 }
 103
 104 unsigned long
 105 scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
 106 {
 107   return scm_to_ulong (x);
 108 }
 109
 110 size_t
 111 scm_num2size (SCM x, unsigned long pos, const char *s_caller)
 112 {
 113   return scm_to_size_t (x);
 114 }
 115
 116 ptrdiff_t
 117 scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
 118 {
 119   return scm_to_ssize_t (x);
 120 }
 121
 122 #if SCM_SIZEOF_LONG_LONG != 0
 123
 124 SCM
 125 scm_long_long2num (long long x)
 126 {
 127   return scm_from_long_long (x);
 128 }
 129
 130 SCM
 131 scm_ulong_long2num (unsigned long long x)
 132 {
 133   return scm_from_ulong_long (x);
 134 }
 135
 136 long long
 137 scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
 138 {
 139   return scm_to_long_long (x);
 140 }
 141
 142 unsigned long long
 143 scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
 144 {
 145   return scm_to_ulong_long (x);
 146 }
 147
 148 #endif
 149
 150 SCM
 151 scm_make_real (double x)
 152 {
 153   return scm_from_double (x);
 154 }
 155
 156 double
 157 scm_num2dbl (SCM a, const char *why)
 158 {
 159   return scm_to_double (a);
 160 }
 161
 162 SCM
 163 scm_float2num (float n)
 164 {
 165   return scm_from_double ((double) n);
 166 }
 167
 168 SCM
 169 scm_double2num (double n)
 170 {
 171   return scm_from_double (n);
 172 }
 173
 174 SCM
 175 scm_make_complex (double x, double y)
 176 {
 177   return scm_c_make_rectangular (x, y);
 178 }
 179
 180 SCM
 181 scm_mem2symbol (const char *mem, size_t len)
 182 {
 183   return scm_from_locale_symboln (mem, len);
 184 }
 185
 186 SCM
 187 scm_mem2uninterned_symbol (const char *mem, size_t len)
 188 {
 189   return scm_make_symbol (scm_from_locale_stringn (mem, len));
 190 }
 191
 192 SCM
 193 scm_str2symbol (const char *str)
 194 {
 195   return scm_from_locale_symbol (str);
 196 }
 197
 198
 199 /* This function must only be applied to memory obtained via malloc,
 200    since the GC is going to apply `free' to it when the string is
 201    dropped.
 202
 203    Also, s[len] must be `\0', since we promise that strings are
 204    null-terminated.  Perhaps we could handle non-null-terminated
 205    strings by claiming they're shared substrings of a string we just
 206    made up.  */
 207 SCM
 208 scm_take_str (char *s, size_t len)
 209 {
 210   SCM answer = scm_from_locale_stringn (s, len);
 211   free (s);
 212   return answer;
 213 }
 214
 215 /* `s' must be a malloc'd string.  See scm_take_str.  */
 216 SCM
 217 scm_take0str (char *s)
 218 {
 219   return scm_take_locale_string (s);
 220 }
 221
 222 SCM
 223 scm_mem2string (const char *src, size_t len)
 224 {
 225   return scm_from_locale_stringn (src, len);
 226 }
 227
 228 SCM
 229 scm_str2string (const char *src)
 230 {
 231   return scm_from_locale_string (src);
 232 }
 233
 234 SCM
 235 scm_makfrom0str (const char *src)
 236 {
 237   if (!src) return SCM_BOOL_F;
 238   return scm_from_locale_string (src);
 239 }
 240
 241 SCM
 242 scm_makfrom0str_opt (const char *src)
 243 {
 244   return scm_makfrom0str (src);
 245 }
 246
 247
 248 SCM
 249 scm_allocate_string (size_t len)
 250 {
 251   return scm_i_make_string (len, NULL);
 252 }
 253
 254 SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
 255             (SCM symbol),
 256             "Make a keyword object from a @var{symbol} that starts with a dash.")
 257 #define FUNC_NAME s_scm_make_keyword_from_dash_symbol
 258 {
 259   SCM dash_string, non_dash_symbol;
 260
 261   SCM_ASSERT (scm_is_symbol (symbol)
 262               && ('-' == scm_i_symbol_chars(symbol)[0]),
 263               symbol, SCM_ARG1, FUNC_NAME);
 264
 265   dash_string = scm_symbol_to_string (symbol);
 266   non_dash_symbol =
 267     scm_string_to_symbol (scm_c_substring (dash_string,
 268                                            1,
 269                                            scm_c_string_length (dash_string)));
 270
 271   return scm_symbol_to_keyword (non_dash_symbol);
 272 }
 273 #undef FUNC_NAME
 274
 275 SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
 276             (SCM keyword),
 277             "Return the dash symbol for @var{keyword}.\n"
 278             "This is the inverse of @code{make-keyword-from-dash-symbol}.")
 279 #define FUNC_NAME s_scm_keyword_dash_symbol
 280 {
 281   SCM symbol = scm_keyword_to_symbol (keyword);
 282   SCM parts = scm_list_2 (scm_from_locale_string ("-"),
 283                           scm_symbol_to_string (symbol));
 284   return scm_string_to_symbol (scm_string_append (parts));
 285 }
 286 #undef FUNC_NAME
 287
 288 SCM
 289 scm_c_make_keyword (const char *s)
 290 {
 291   return scm_from_locale_keyword (s);
 292 }
 293
 294
 295 void
 296 scm_i_init_discouraged (void)
 297 {
 298 #include "libguile/discouraged.x"
 299 }
 300
 301 #endif