src/lib.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017,2018 Jan (janneke) 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 int g_depth;
  22 SCM fdisplay_ (SCM, int, int);
  23
  24 SCM
  25 display_helper (SCM x, int cont, char* sep, int fd, int write_p)
  26 {
  27   fdputs (sep, fd);
  28   if (g_depth == 0)
  29     return cell_unspecified;
  30   g_depth = g_depth - 1;
  31
  32   switch (TYPE (x))
  33     {
  34     case TCHAR:
  35       {
  36         if (!write_p)
  37           fdputc (VALUE (x), fd);
  38         else
  39           {
  40             fdputs ("#\\", fd);
  41             switch (VALUE (x))
  42               {
  43               case '\0': fdputs ("nul", fd); break;
  44               case '\a': fdputs ("alarm", fd); break;
  45               case '\b': fdputs ("backspace", fd); break;
  46               case '\t': fdputs ("tab", fd); break;
  47               case '\n': fdputs ("newline", fd); break;
  48               case '\v': fdputs ("vtab", fd); break;
  49               case '\f': fdputs ("page", fd); break;
  50                 //Nyacc bug
  51                 // case '\r': fdputs ("return", fd); break;
  52               case 13: fdputs ("return", fd); break;
  53               case ' ': fdputs ("space", fd); break;
  54               default: fdputc (VALUE (x), fd);
  55               }
  56           }
  57         break;
  58       }
  59     case TCLOSURE:
  60       {
  61         fdputs ("#<closure ", fd);
  62         display_helper (CDR (x), cont, "", fd, 0);
  63         fdputs (">", fd);
  64         break;
  65       }
  66     case TFUNCTION:
  67       {
  68         fdputs ("#<procedure ", fd);
  69         char const *p = "?";
  70         if (FUNCTION (x).name != 0)
  71           p = FUNCTION (x).name;
  72         fdputs (p, fd);
  73         fdputs ("[", fd);
  74         fdputs (itoa (CDR (x)), fd);
  75         fdputs (",", fd);
  76         fdputs (itoa (x), fd);
  77         fdputs ("]>", fd);
  78         break;
  79       }
  80     case TMACRO:
  81       {
  82         fdputs ("#<macro ", fd);
  83         display_helper (CDR (x), cont, "", fd, 0);
  84         fdputs (">", fd);
  85         break;
  86       }
  87     case TVARIABLE:
  88       {
  89         fdputs ("#<variable ", fd);
  90         display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
  91         fdputs (">", fd);
  92         break;
  93       }
  94     case TNUMBER:
  95       {
  96         fdputs (itoa (VALUE (x)), fd);
  97         break;
  98       }
  99     case TPAIR:
 100       {
 101         if (!cont)
 102           fdputs ("(", fd);
 103         if (CAR (x) == cell_circular
 104             && CADR (x) != cell_closure)
 105           {
 106             fdputs ("(*circ* . ", fd);
 107             int i = 0;
 108             x = CDR (x);
 109             while (x != cell_nil && i++ < 10)
 110               {
 111                 fdisplay_ (CAAR (x), fd, write_p); fdputs (" ", fd);
 112                 x = CDR (x);
 113               }
 114             fdputs (" ...)", fd);
 115           }
 116         else
 117           {
 118             if (x && x != cell_nil)
 119               fdisplay_ (CAR (x), fd, write_p);
 120             if (CDR (x) && TYPE (CDR (x)) == TPAIR)
 121               display_helper (CDR (x), 1, " ", fd, write_p);
 122             else if (CDR (x) && CDR (x) != cell_nil)
 123               {
 124                 if (TYPE (CDR (x)) != TPAIR)
 125                   fdputs (" . ", fd);
 126                 fdisplay_ (CDR (x), fd, write_p);
 127               }
 128           }
 129         if (!cont)
 130           fdputs (")", fd);
 131         break;
 132       }
 133     case TKEYWORD:
 134     case TPORT:
 135     case TSPECIAL:
 136     case TSTRING:
 137     case TSYMBOL:
 138       {
 139         if (TYPE (x) == TPORT)
 140           {
 141             fdputs ("#<port ", fd);
 142             fdputs (itoa (PORT (x)), fd);
 143             fdputs (" " ,fd);
 144           }
 145         if (TYPE (x) == TKEYWORD)
 146           fdputs ("#:", fd);
 147         if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
 148           fdputc ('"', fd);
 149         SCM t = CAR (x);
 150         while (t && t != cell_nil)
 151           {
 152             switch (write_p ? VALUE (CAR (t)) : -1)
 153               {
 154               case '\0': fdputs ("\\0", fd); break;
 155               case '\a': fdputs ("\\a", fd); break;
 156               case '\b': fdputs ("\\b", fd); break;
 157               case '\t': fdputs ("\\t", fd); break;
 158               case '\v': fdputs ("\\v", fd); break;
 159               case '\n': fdputs ("\\n", fd); break;
 160               case '\f': fdputs ("\\f", fd); break;
 161 #if 1 //__MESC__
 162       //Nyacc bug
 163               case 13: fdputs ("\\r", fd); break;
 164               case 27: fdputs ("\\e", fd); break;
 165 #else
 166                 //case '\r': fdputs ("\\r", fd); break;
 167                 //Nyacc crash
 168                 //case '\e': fdputs ("\\e", fd); break;
 169 #endif
 170               case '\\': fdputs ("\\\\", fd); break;
 171               case '"': fdputs ("\\\"", fd); break;
 172               default:
 173                 fdputc (VALUE (CAR (t)), fd);
 174               }
 175             t = CDR (t);
 176           }
 177         if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
 178           fdputc ('"', fd);
 179         if (TYPE (x) == TPORT)
 180           fdputs (">", fd);
 181         break;
 182       }
 183     case TVECTOR:
 184       {
 185         fdputs ("#(", fd);
 186         SCM t = CAR (x);
 187         for (int i = 0; i < LENGTH (x); i++)
 188           {
 189             if (i)
 190               fdputc (' ', fd);
 191             fdisplay_ (VECTOR (x) + i, fd, write_p);
 192           }
 193         fdputc (')', fd);
 194         break;
 195       }
 196     default:
 197       {
 198         fdputs ("<", fd);
 199         fdputs (itoa (TYPE (x)), fd);
 200         fdputs (":", fd);
 201         fdputs (itoa (x), fd);
 202         fdputs (">", fd);
 203         break;
 204       }
 205     }
 206   return 0;
 207 }
 208
 209 SCM
 210 display_ (SCM x)
 211 {
 212   g_depth = 5;
 213   return display_helper (x, 0, "", g_stdout, 0);
 214 }
 215
 216 SCM
 217 display_error_ (SCM x)
 218 {
 219   g_depth = 5;
 220   return display_helper (x, 0, "", STDERR, 0);
 221 }
 222
 223 SCM
 224 display_port_ (SCM x, SCM p)
 225 {
 226   assert (TYPE (p) == TNUMBER);
 227   return fdisplay_ (x, VALUE (p), 0);
 228 }
 229
 230 SCM
 231 write_ (SCM x)
 232 {
 233   g_depth = 5;
 234   return display_helper (x, 0, "", g_stdout, 1);
 235 }
 236
 237 SCM
 238 write_error_ (SCM x)
 239 {
 240   g_depth = 5;
 241   return display_helper (x, 0, "", STDERR, 1);
 242 }
 243
 244 SCM
 245 write_port_ (SCM x, SCM p)
 246 {
 247   assert (TYPE (p) == TNUMBER);
 248   return fdisplay_ (x, VALUE (p), 1);
 249 }
 250
 251 SCM
 252 fdisplay_ (SCM x, int fd, int write_p) ///((internal))
 253 {
 254   g_depth = 5;
 255   return display_helper (x, 0, "", fd, write_p);
 256 }
 257
 258 SCM
 259 exit_ (SCM x) ///((name . "exit"))
 260 {
 261   assert (TYPE (x) == TNUMBER);
 262   exit (VALUE (x));
 263 }
 264
 265 SCM
 266 xassq (SCM x, SCM a) ///for speed in core only
 267 {
 268   while (a != cell_nil && x != CDAR (a))
 269     a = CDR (a);
 270   return a != cell_nil ? CAR (a) : cell_f;
 271 }
 272
 273 SCM
 274 memq (SCM x, SCM a)
 275 {
 276   switch (TYPE (x))
 277     {
 278     case TCHAR:
 279     case TNUMBER:
 280       {
 281         SCM v = VALUE (x);
 282         while (a != cell_nil && v != VALUE (CAR (a)))
 283           a = CDR (a);
 284         break;
 285       }
 286     case TKEYWORD:
 287       {
 288         SCM v = STRING (x);
 289         while (a != cell_nil && v != STRING (CAR (a)))
 290           a = CDR (a);
 291         break;
 292       }
 293       // case TSYMBOL:
 294       // case TSPECIAL:
 295     default:
 296       while (a != cell_nil && x != CAR (a))
 297         a = CDR (a);
 298     }
 299   return a != cell_nil ? a : cell_f;
 300 }
 301
 302 SCM
 303 equal2_p (SCM a, SCM b)
 304 {
 305  equal2:
 306   if (a == b)
 307     return cell_t;
 308   if (TYPE (a) == TPAIR && TYPE (b) == TPAIR)
 309     {
 310       if (equal2_p (CAR (a), CAR (b)) == cell_t)
 311         {
 312           a = CDR (a);
 313           b = CDR (b);
 314           goto equal2;
 315         }
 316       return cell_f;
 317     }
 318   if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
 319     {
 320       a = STRING (a);
 321       b = STRING (b);
 322       goto equal2;
 323     }
 324   if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
 325     {
 326       if (LENGTH (a) != LENGTH (b))
 327         return cell_f;
 328       for (int i=0; i < LENGTH (a); i++)
 329         {
 330           SCM ai = VECTOR (a) + i;
 331           SCM bi = VECTOR (b) + i;
 332           if (TYPE (ai) == TREF)
 333             ai = REF (ai);
 334           if (TYPE (bi) == TREF)
 335             bi = REF (bi);
 336           if (equal2_p (ai, bi) == cell_f)
 337             return cell_f;
 338         }
 339       return cell_t;
 340     }
 341   return eq_p (a, b);
 342 }
 343
 344 SCM
 345 last_pair (SCM x)
 346 {
 347   while (x != cell_nil && CDR (x) != cell_nil)
 348     x = CDR (x);
 349   return x;
 350 }