src/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 #if !__MESC__
  22 #define fputs fdputs
  23 #endif
  24
  25 int g_depth;
  26 SCM fdisplay_ (SCM, int);
  27
  28 SCM display_helper (SCM x, int cont, char* sep, int fd);
  29
  30 SCM
  31 display_helper (SCM x, int cont, char* sep, int fd)
  32 {
  33   fputs (sep, fd);
  34   if (g_depth == 0) return cell_unspecified;
  35   g_depth = g_depth - 1;
  36
  37   switch (TYPE (x))
  38     {
  39     case TCHAR:
  40       {
  41         fputs ("#\\", fd);
  42         fputc (VALUE (x), fd);
  43         break;
  44       }
  45     case TFUNCTION:
  46       {
  47         fputs ("#<procedure ", fd);
  48         char const *p = "?";
  49         if (FUNCTION (x).name != 0)
  50           p = FUNCTION (x).name;
  51         fputs (p, fd);
  52         fputs ("[", fd);
  53         fputs (itoa (CDR (x)), fd);
  54         fputs (",", fd);
  55         fputs (itoa (x), fd);
  56         fputs ("]>", fd);
  57         break;
  58       }
  59     case TMACRO:
  60       {
  61         fputs ("#<macro ", fd);
  62         display_helper (cdr (x), cont, "", fd);
  63         fputs (">", fd);
  64         break;
  65       }
  66     case TNUMBER:
  67       {
  68         fputs (itoa (VALUE (x)), fd);
  69         break;
  70       }
  71     case TPAIR:
  72       {
  73         if (!cont) fputs ("(", fd);
  74         if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
  75         if (CDR (x) && TYPE (CDR (x)) == TPAIR)
  76           display_helper (CDR (x), 1, " ", fd);
  77         else if (CDR (x) && CDR (x) != cell_nil)
  78           {
  79             if (TYPE (CDR (x)) != TPAIR)
  80               fputs (" . ", fd);
  81             fdisplay_ (CDR (x), fd);
  82           }
  83         if (!cont) fputs (")", fd);
  84         break;
  85       }
  86     case TSPECIAL:
  87     case TSTRING:
  88     case TSYMBOL:
  89       {
  90         SCM t = CAR (x);
  91         while (t && t != cell_nil)
  92           {
  93             fputc (VALUE (CAR (t)), fd);
  94             t = CDR (t);
  95           }
  96         break;
  97       }
  98     default:
  99       {
 100         fputs ("<", fd);
 101         fputs (itoa (TYPE (x)), fd);
 102         fputs (":", fd);
 103         fputs (itoa (x), fd);
 104         fputs (">", fd);
 105         break;
 106       }
 107     }
 108   return 0;
 109 }
 110
 111 SCM
 112 display_ (SCM x)
 113 {
 114   g_depth = 5;
 115   return display_helper (x, 0, "", STDOUT);
 116 }
 117
 118 SCM
 119 display_error_ (SCM x)
 120 {
 121   g_depth = 5;
 122   return display_helper (x, 0, "", STDERR);
 123 }
 124
 125 SCM
 126 fdisplay_ (SCM x, int fd) ///((internal))
 127 {
 128   g_depth = 5;
 129   return display_helper (x, 0, "", fd);
 130 }
 131
 132 SCM
 133 exit_ (SCM x) ///((name . "exit"))
 134 {
 135   assert (TYPE (x) == TNUMBER);
 136   exit (VALUE (x));
 137 }
 138
 139 SCM
 140 xassq (SCM x, SCM a) ///for speed in core only
 141 {
 142   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
 143   return a != cell_nil ? CAR (a) : cell_f;
 144 }