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