lib.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016,2017 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 int g_depth;
  22 #if _POSIX_SOURCE
  23
  24 char const*
  25 itoa (int x)
  26 {
  27   static char buf[10];
  28   char *p = buf+9;
  29   *p-- = 0;
  30
  31   int sign = x < 0;
  32   if (sign)
  33     x = -x;
  34
  35   do
  36     {
  37       *p-- = '0' + (x % 10);
  38       x = x / 10;
  39     } while (x);
  40
  41   if (sign)
  42     *p-- = '-';
  43
  44   return p+1;
  45 }
  46
  47 // from mlib.c
  48 #define fputs fdputs
  49 int
  50 fdputs (char const* s, int fd)
  51 {
  52   int i = strlen (s);
  53   write (fd, s, i);
  54   return 0;
  55 }
  56
  57 #ifdef putc
  58 #undef putc
  59 #endif
  60 #define putc(x) fdputc(x, STDOUT)
  61 #define fputc fdputc
  62 int
  63 fdputc (int c, int fd)
  64 {
  65   write (fd, (char*)&c, 1);
  66   return 0;
  67 }
  68 #endif
  69
  70 SCM fdisplay_ (SCM, int);
  71
  72 SCM
  73 display_helper (SCM x, int cont, char* sep, int fd)
  74 {
  75   fputs (sep, fd);
  76   if (g_depth == 0) return cell_unspecified;
  77   g_depth = g_depth - 1;
  78
  79   switch (TYPE (x))
  80     {
  81     case TCHAR:
  82       {
  83         fputs ("#\\", fd);
  84         fputc (VALUE (x), fd);
  85         break;
  86       }
  87     case TFUNCTION:
  88       {
  89         fputs ("#<procedure ", fd);
  90         char const *p = "?";
  91         if (FUNCTION (x).name != 0)
  92           p = FUNCTION (x).name;
  93         fputs (p, fd);
  94         fputs ("[", fd);
  95         fputs (itoa (CDR (x)), fd);
  96         fputs (",", fd);
  97         fputs (itoa (x), fd);
  98         fputs ("]>", fd);
  99         break;
 100       }
 101     case TMACRO:
 102       {
 103         fputs ("#<macro ", fd);
 104         display_helper (cdr (x), cont, "", fd);
 105         fputs (">", fd);
 106         break;
 107       }
 108     case TNUMBER:
 109       {
 110         fputs (itoa (VALUE (x)), fd);
 111         break;
 112       }
 113     case TPAIR:
 114       {
 115         if (!cont) fputs ("(", fd);
 116         if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
 117         if (CDR (x) && TYPE (CDR (x)) == TPAIR)
 118           display_helper (CDR (x), 1, " ", fd);
 119         else if (CDR (x) && CDR (x) != cell_nil)
 120           {
 121             if (TYPE (CDR (x)) != TPAIR)
 122               fputs (" . ", fd);
 123             fdisplay_ (CDR (x), fd);
 124           }
 125         if (!cont) fputs (")", fd);
 126         break;
 127       }
 128     case TSPECIAL:
 129     case TSTRING:
 130     case TSYMBOL:
 131       {
 132         SCM t = CAR (x);
 133         while (t && t != cell_nil)
 134           {
 135             fputc (VALUE (CAR (t)), fd);
 136             t = CDR (t);
 137           }
 138         break;
 139       }
 140     default:
 141       {
 142         fputs ("<", fd);
 143         fputs (itoa (TYPE (x)), fd);
 144         fputs (":", fd);
 145         fputs (itoa (x), fd);
 146         fputs (">", fd);
 147         break;
 148       }
 149     }
 150   return 0;
 151 }
 152
 153 SCM
 154 display_ (SCM x)
 155 {
 156   g_depth = 5;
 157   return display_helper (x, 0, "", STDOUT);
 158 }
 159
 160 SCM
 161 display_error_ (SCM x)
 162 {
 163   g_depth = 5;
 164   return display_helper (x, 0, "", STDERR);
 165 }
 166
 167 SCM
 168 fdisplay_ (SCM x, int fd) ///((internal))
 169 {
 170   g_depth = 5;
 171   return display_helper (x, 0, "", fd);
 172 }
 173
 174 SCM
 175 exit_ (SCM x) ///((name . "exit"))
 176 {
 177   assert (TYPE (x) == TNUMBER);
 178   exit (VALUE (x));
 179 }
 180
 181 SCM
 182 xassq (SCM x, SCM a) ///for speed in core only
 183 {
 184   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
 185   return a != cell_nil ? CAR (a) : cell_f;
 186 }
 187
 188 #if _POSIX_SOURCE
 189 #undef fdputs
 190 #undef fdputc
 191 #endif