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