lib.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of Mes.
   6  *
   7  * Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * Mes is distributed in the hope that it will be useful, but
  13  * WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 SCM
  22 xassq (SCM x, SCM a) ///for speed in core only
  23 {
  24   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
  25   return a != cell_nil ? CAR (a) : cell_f;
  26 }
  27
  28 SCM
  29 length (SCM x)
  30 {
  31   int n = 0;
  32   while (x != cell_nil)
  33     {
  34       n++;
  35       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
  36       x = cdr (x);
  37     }
  38   return MAKE_NUMBER (n);
  39 }
  40
  41 SCM
  42 list (SCM x) ///((arity . n))
  43 {
  44   return x;
  45 }
  46
  47 SCM
  48 exit_ (SCM x) ///((name . "exit"))
  49 {
  50   assert (TYPE (x) == TNUMBER);
  51   exit (VALUE (x));
  52 }
  53
  54 SCM
  55 append (SCM x) ///((arity . n))
  56 {
  57   if (x == cell_nil) return cell_nil;
  58   if (cdr (x) == cell_nil) return car (x);
  59   return append2 (car (x), append (cdr (x)));
  60 }
  61
  62 //MINI_MES
  63 // char const*
  64 // string_to_cstring (SCM s)
  65 // {
  66 //   static char buf[1024];
  67 //   char *p = buf;
  68 //   s = STRING (s);
  69 //   while (s != cell_nil)
  70 //     {
  71 //       *p++ = VALUE (car (s));
  72 //       s = cdr (s);
  73 //     }
  74 //   *p = 0;
  75 //   return buf;
  76 // }
  77
  78 SCM
  79 error (SCM key, SCM x)
  80 {
  81   SCM throw;
  82   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
  83     return apply (throw, cons (key, cons (x, cell_nil)), r0);
  84   assert (!"error");
  85 }
  86
  87 SCM
  88 assert_defined (SCM x, SCM e)
  89 {
  90   if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
  91   return e;
  92 }
  93
  94 SCM
  95 check_formals (SCM f, SCM formals, SCM args)
  96 {
  97   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
  98   int alen = VALUE (length (args));
  99   if (alen != flen && alen != -1 && flen != -1)
 100     {
 101       char buf[1024];
 102       sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
 103       SCM e = MAKE_STRING (cstring_to_list (buf));
 104       return error (cell_symbol_wrong_number_of_args, cons (e, f));
 105     }
 106   return cell_unspecified;
 107 }
 108
 109 SCM
 110 check_apply (SCM f, SCM e)
 111 {
 112   char const* type = 0;
 113   if (f == cell_f || f == cell_t) type = "bool";
 114   if (f == cell_nil) type = "nil";
 115   if (f == cell_unspecified) type = "*unspecified*";
 116   if (f == cell_undefined) type = "*undefined*";
 117   if (TYPE (f) == TCHAR) type = "char";
 118   if (TYPE (f) == TNUMBER) type = "number";
 119   if (TYPE (f) == TSTRING) type = "string";
 120
 121   if (type)
 122     {
 123       char buf[1024];
 124       sprintf (buf, "cannot apply: %s:", type);
 125       fprintf (stderr, " [");
 126       stderr_ (e);
 127       fprintf (stderr, "]\n");
 128       SCM e = MAKE_STRING (cstring_to_list (buf));
 129       return error (cell_symbol_wrong_type_arg, cons (e, f));
 130     }
 131   return cell_unspecified;
 132 }
 133
 134 char const*
 135 itoa (int x)
 136 {
 137   static char buf[10];
 138   char *p = buf+9;
 139   *p-- = 0;
 140
 141   int sign = x < 0;
 142   if (sign)
 143     x = -x;
 144
 145   do
 146     {
 147       *p-- = '0' + (x % 10);
 148       x = x / 10;
 149     } while (x);
 150
 151   if (sign)
 152     *p-- = '-';
 153
 154   return p+1;
 155 }
 156
 157 FILE *g_stdin;
 158 int
 159 dump ()
 160 {
 161   fputs ("program r2=", stderr);
 162   stderr_ (r2);
 163   fputs ("\n", stderr);
 164
 165   r1 = g_symbols;
 166   gc_push_frame ();
 167   gc ();
 168   gc_peek_frame ();
 169   char *p = (char*)g_cells;
 170   fputc ('M', stdout);
 171   fputc ('E', stdout);
 172   fputc ('S', stdout);
 173   fputc (g_stack >> 8, stdout);
 174   fputc (g_stack % 256, stdout);
 175   if (getenv ("MES_HACK"))
 176     {
 177       TYPE (9) = 0x2d2d2d2d;
 178       CAR (9) = 0x2d2d2d2d;
 179       CDR (9) = 0x3e3e3e3e;
 180
 181       TYPE (10) = TPAIR;
 182       CAR (10) = 11;
 183       CDR (10) = 12;
 184
 185       TYPE (11) = TCHAR;
 186       CAR (11) = 0x58585858;
 187       CDR (11) = 65;
 188
 189       TYPE (12) = TPAIR;
 190       CAR (12) = 13;
 191       CDR (12) = 1;
 192
 193       TYPE (13) = TCHAR;
 194       CAR (11) = 0x58585858;
 195       CDR (13) = 66;
 196
 197       TYPE (14) = 0x3c3c3c3c;
 198       CAR (14) = 0x2d2d2d2d;
 199       CDR (14) = 0x2d2d2d2d;
 200
 201       g_free = 15;
 202     }
 203   for (int i=0; i<g_free * sizeof(struct scm); i++)
 204     fputc (*p++, stdout);
 205   return 0;
 206 }
 207
 208 SCM
 209 load_env (SCM a) ///((internal))
 210 {
 211   r0 = a;
 212   if (getenv ("MES_MINI"))
 213     g_stdin = fopen ("mini-0.mes", "r");
 214   else
 215     {
 216       g_stdin = fopen ("module/mes/read-0.mes", "r");
 217       g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r");
 218     }
 219   if (!g_function) r0 = mes_builtins (r0);
 220   r2 = read_input_file_env (r0);
 221   g_stdin = stdin;
 222   return r2;
 223 }
 224
 225 SCM
 226 bload_env (SCM a) ///((internal))
 227 {
 228 #if MES_MINI
 229   g_stdin = fopen ("mini-0.mo", "r");
 230 #else
 231   g_stdin = fopen ("module/mes/read-0.mo", "r");
 232   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
 233 #endif
 234
 235   char *p = (char*)g_cells;
 236   assert (getchar () == 'M');
 237   assert (getchar () == 'E');
 238   assert (getchar () == 'S');
 239   g_stack = getchar () << 8;
 240   g_stack += getchar ();
 241   int c = getchar ();
 242   while (c != EOF)
 243     {
 244       *p++ = c;
 245       c = getchar ();
 246     }
 247   g_free = (p-(char*)g_cells) / sizeof (struct scm);
 248   gc_peek_frame ();
 249   g_symbols = r1;
 250   g_stdin = stdin;
 251   r0 = mes_builtins (r0);
 252   return r2;
 253 }