Nicer closure and builtin procedure display.
[mes.git] / display.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016 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 SCM display_helper (FILE*, SCM , bool, char const*, bool);
22
23 SCM
24 display (SCM x) ///((arity . n))
25 {
26   SCM e = car (x);
27   SCM p = cdr (x);
28   int fd = 1;
29   if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = HITS (car (p));
30   FILE *f = fd == 1 ? stdout : stderr;
31   return display_helper (f, e, false, "", false);
32 }
33
34 SCM
35 newline (SCM p) ///((arity . n))
36 {
37   int fd = 1;
38   if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
39   FILE *f = fd == 1 ? stdout : stderr;
40   fputs ("\n", f);
41   return cell_unspecified;
42 }
43
44 SCM
45 display_ (FILE* f, SCM x)
46 {
47   return display_helper (f, x, false, "", false);
48 }
49
50 SCM
51 display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
52 {
53   SCM r;
54   fprintf (f, "%s", sep);
55   switch (TYPE (x))
56     {
57     case CHAR:
58       {
59         char const *name = 0;
60         if (VALUE (x) == char_nul.value) name = char_nul.name;
61         else if (VALUE (x) == char_alarm.value) name = char_alarm.name;
62         else if (VALUE (x) == char_backspace.value) name = char_backspace.name;
63         else if (VALUE (x) == char_tab.value) name = char_tab.name;
64         else if (VALUE (x) == char_newline.value) name = char_newline.name;
65         else if (VALUE (x) == char_vtab.value) name = char_vtab.name;
66         else if (VALUE (x) == char_page.value) name = char_page.name;
67         else if (VALUE (x) == char_return.value) name = char_return.name;
68         else if (VALUE (x) == char_space.value) name = char_space.name;
69         if (name) fprintf (f, "#\\%s", name);
70         else fprintf (f, "#\\%c", VALUE (x));
71         break;
72       }
73     case MACRO:
74       fprintf (f, "(*macro* ");
75       display_helper (f, g_cells[x].macro, cont, sep, quote);
76       fprintf (f, ")");
77       break;
78     case NUMBER: fprintf (f, "%d", VALUE (x)); break;
79     case PAIR:
80       {
81         if (car (x) == cell_closure) {
82           fprintf (f, "#<procedure #f ");
83           display_ (f, (caddr (x)));
84           fprintf (f, ">");
85           return cell_unspecified;
86         }
87         if (car (x) == cell_circular) {
88           fprintf (f, "(*circ* . #-1#)");
89           return cell_unspecified;
90         }
91         if (car (x) == cell_closure) {
92           fprintf (f, "(*closure* . #-1#)");
93           return cell_unspecified;
94         }
95         if (car (x) == cell_symbol_quote) {
96           fprintf (f, "'");
97           x = cdr (x);
98           if (TYPE (x) != FUNCTION)
99             x = car (x);
100           return display_helper (f, x, cont, "", true);
101         }
102         if (!cont) fprintf (f, "(");
103         display_ (f, car (x));
104         if (cdr (x) && TYPE (cdr (x)) == PAIR)
105           display_helper (f, cdr (x), true, " ", false);
106         else if (cdr (x) != cell_nil) {
107           fprintf (f, " . ");
108           display_ (f, cdr (x));
109         }
110         if (!cont) fprintf (f, ")");
111         break;
112       }
113     case VECTOR:
114       {
115         fprintf (f, "#(");
116         for (int i = 0; i < LENGTH (x); i++) {
117           if (TYPE (VECTOR (x)+i) == VECTOR
118               || (TYPE (VECTOR (x)+i) == REF
119                   && TYPE (REF (VECTOR (x)+i)) == VECTOR))
120             fprintf (f, "%s#(...)", i ? " " : "");
121           else
122             display_helper (f,VECTOR (x)+i, false, i ? " " : "", false);
123         }
124         fprintf (f, ")");
125         break;
126       }
127     case REF: display_helper (f, g_cells[x].ref, cont, "", true); break;
128     case FUNCTION:
129       {
130         fprintf (f, "#<procedure ");
131         SCM p = STRING (x);
132         if (p < 0 || p >= g_free.value || TYPE (p) != PAIR)
133           fprintf (f, "%s", NAME (x));
134         else
135           display_ (f, STRING (x));
136         fprintf (f, " ");
137         switch (FUNCTION (x).arity)
138           {
139           case -1: fprintf (f, "(. x)"); break;
140           case 0: fprintf (f, "()"); break;
141           case 1: fprintf (f, "(x)"); break;
142           case 2: fprintf (f, "(x y)"); break;
143           case 3: fprintf (f, "(x y z)"); break;
144           }
145         fprintf (f, ">");
146         break;
147       }
148     case BROKEN_HEART: fprintf (f, "<3"); break;
149     case KEYWORD:
150       fprintf (f, "#:");
151     default:
152       if (STRING (x))
153         {
154           SCM p = STRING (x);
155           assert (p);
156           while (p != cell_nil) {
157             assert (TYPE (car (p)) == CHAR);
158             fputc (VALUE (car (p)), f);
159             p = cdr (p);
160           }
161         }
162       else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x));
163     }
164   return cell_unspecified;
165 }