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 #define DEFFROM(t,f1,f2) SCM f1(t x) { return f2 (x); }
  27 #define DEFTO(t,f1,f2)   t f1(SCM x, unsigned long pos, const char *s_caller) \
  28                            { return f2 (x); }
  29
  30 DEFFROM (short, scm_short2num, scm_from_short);
  31 DEFFROM (unsigned short, scm_ushort2num, scm_from_ushort);
  32 DEFFROM (int, scm_int2num, scm_from_int);
  33 DEFFROM (unsigned int, scm_uint2num, scm_from_uint);
  34 DEFFROM (long, scm_long2num, scm_from_long);
  35 DEFFROM (unsigned long, scm_ulong2num, scm_from_ulong);
  36 DEFFROM (size_t, scm_size2num, scm_from_size_t);
  37 DEFFROM (ptrdiff_t, scm_ptrdiff2num, scm_from_ssize_t);
  38
  39 DEFTO (short, scm_num2short, scm_to_short);
  40 DEFTO (unsigned short, scm_num2ushort, scm_to_ushort);
  41 DEFTO (int, scm_num2int, scm_to_int);
  42 DEFTO (unsigned int, scm_num2uint, scm_to_uint);
  43 DEFTO (long, scm_num2long, scm_to_long);
  44 DEFTO (unsigned long, scm_num2ulong, scm_to_ulong);
  45 DEFTO (size_t, scm_num2size, scm_to_size_t);
  46 DEFTO (ptrdiff_t, scm_num2ptrdiff, scm_to_ssize_t);
  47
  48 #if SCM_SIZEOF_LONG_LONG != 0
  49 DEFFROM (long long, scm_long_long2num, scm_from_long_long);
  50 DEFFROM (unsigned long long, scm_ulong_long2num, scm_from_ulong_long);
  51 DEFTO   (long long, scm_num2long_long, scm_to_long_long);
  52 DEFTO   (unsigned long long, scm_num2ulong_long, scm_to_ulong_long);
  53 #endif
  54
  55 SCM
  56 scm_make_real (double x)
  57 {
  58   return scm_from_double (x);
  59 }
  60
  61 double
  62 scm_num2dbl (SCM a, const char *why)
  63 {
  64   return scm_to_double (a);
  65 }
  66
  67 SCM
  68 scm_float2num (float n)
  69 {
  70   return scm_from_double ((double) n);
  71 }
  72
  73 SCM
  74 scm_double2num (double n)
  75 {
  76   return scm_from_double (n);
  77 }
  78
  79 SCM
  80 scm_make_complex (double x, double y)
  81 {
  82   return scm_c_make_rectangular (x, y);
  83 }
  84
  85 SCM
  86 scm_mem2symbol (const char *mem, size_t len)
  87 {
  88   return scm_from_locale_symboln (mem, len);
  89 }
  90
  91 SCM
  92 scm_mem2uninterned_symbol (const char *mem, size_t len)
  93 {
  94   return scm_make_symbol (scm_from_locale_stringn (mem, len));
  95 }
  96
  97 SCM
  98 scm_str2symbol (const char *str)
  99 {
 100   return scm_from_locale_symbol (str);
 101 }
 102
 103
 104 /* This function must only be applied to memory obtained via malloc,
 105    since the GC is going to apply `free' to it when the string is
 106    dropped.
 107
 108    Also, s[len] must be `\0', since we promise that strings are
 109    null-terminated.  Perhaps we could handle non-null-terminated
 110    strings by claiming they're shared substrings of a string we just
 111    made up.  */
 112 SCM
 113 scm_take_str (char *s, size_t len)
 114 {
 115   SCM answer = scm_from_locale_stringn (s, len);
 116   free (s);
 117   return answer;
 118 }
 119
 120 /* `s' must be a malloc'd string.  See scm_take_str.  */
 121 SCM
 122 scm_take0str (char *s)
 123 {
 124   return scm_take_locale_string (s);
 125 }
 126
 127 SCM
 128 scm_mem2string (const char *src, size_t len)
 129 {
 130   return scm_from_locale_stringn (src, len);
 131 }
 132
 133 SCM
 134 scm_str2string (const char *src)
 135 {
 136   return scm_from_locale_string (src);
 137 }
 138
 139 SCM
 140 scm_makfrom0str (const char *src)
 141 {
 142   if (!src) return SCM_BOOL_F;
 143   return scm_from_locale_string (src);
 144 }
 145
 146 SCM
 147 scm_makfrom0str_opt (const char *src)
 148 {
 149   return scm_makfrom0str (src);
 150 }
 151
 152
 153 SCM
 154 scm_allocate_string (size_t len)
 155 {
 156   return scm_i_make_string (len, NULL);
 157 }
 158
 159 SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
 160             (SCM symbol),
 161             "Make a keyword object from a @var{symbol} that starts with a dash.")
 162 #define FUNC_NAME s_scm_make_keyword_from_dash_symbol
 163 {
 164   SCM dash_string, non_dash_symbol;
 165
 166   SCM_ASSERT (scm_is_symbol (symbol)
 167               && ('-' == scm_i_symbol_chars(symbol)[0]),
 168               symbol, SCM_ARG1, FUNC_NAME);
 169
 170   dash_string = scm_symbol_to_string (symbol);
 171   non_dash_symbol =
 172     scm_string_to_symbol (scm_c_substring (dash_string,
 173                                            1,
 174                                            scm_c_string_length (dash_string)));
 175
 176   return scm_symbol_to_keyword (non_dash_symbol);
 177 }
 178 #undef FUNC_NAME
 179
 180 SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
 181             (SCM keyword),
 182             "Return the dash symbol for @var{keyword}.\n"
 183             "This is the inverse of @code{make-keyword-from-dash-symbol}.")
 184 #define FUNC_NAME s_scm_keyword_dash_symbol
 185 {
 186   SCM symbol = scm_keyword_to_symbol (keyword);
 187   SCM parts = scm_list_2 (scm_from_locale_string ("-"),
 188                           scm_symbol_to_string (symbol));
 189   return scm_string_to_symbol (scm_string_append (parts));
 190 }
 191 #undef FUNC_NAME
 192
 193 SCM
 194 scm_c_make_keyword (const char *s)
 195 {
 196   return scm_from_locale_keyword (s);
 197 }
 198
 199
 200 void
 201 scm_i_init_discouraged (void)
 202 {
 203 #include "libguile/discouraged.x"
 204 }
 205
 206 #endif