src/lib.c

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