core: Display me debuggor CPS+CC.
[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 char_eof = {CHAR, .name="*eof*", .value=-1};
22 scm char_nul = {CHAR, .name="nul", .value=0};
23 scm char_alarm = {CHAR, .name="alarm", .value=8};
24 scm char_backspace = {CHAR, .name="backspace", .value=8};
25 scm char_tab = {CHAR, .name="tab", .value=9};
26 scm char_newline = {CHAR, .name="newline", .value=10};
27 scm char_vtab = {CHAR, .name="vtab", .value=11};
28 scm char_page = {CHAR, .name="page", .value=12};
29 scm char_return = {CHAR, .name="return", .value=13};
30 scm char_space = {CHAR, .name="space", .value=32};
31
32 SCM display_helper (FILE*, SCM , bool, char const*, bool);
33
34 SCM
35 display (SCM x) ///((arity . n))
36 {
37   SCM e = car (x);
38   SCM p = cdr (x);
39   int fd = 1;
40   if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = HITS (car (p));
41   FILE *f = fd == 1 ? stdout : stderr;
42   return display_helper (f, e, false, "", false);
43 }
44
45 SCM
46 newline (SCM p) ///((arity . n))
47 {
48   int fd = 1;
49   if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
50   FILE *f = fd == 1 ? stdout : stderr;
51   fputs ("\n", f);
52   return cell_unspecified;
53 }
54
55 SCM
56 display_ (FILE* f, SCM x)
57 {
58   return display_helper (f, x, false, "", false);
59 }
60
61 // SCM
62 // xassq (SCM x, SCM lst)
63 // {
64 //   while (a != cell_nil && eq_p (x, CDAR (a)) == cell_f) a = CDR (a);
65 //   return a != cell_nil ? car (a) : cell_f;
66 // }
67
68 SCM
69 display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
70 {
71   SCM r;
72   fprintf (f, "%s", sep);
73   switch (TYPE (x))
74     {
75     case CHAR:
76       {
77         char const *name = 0;
78         if (VALUE (x) == char_nul.value) name = char_nul.name;
79         else if (VALUE (x) == char_alarm.value) name = char_alarm.name;
80         else if (VALUE (x) == char_backspace.value) name = char_backspace.name;
81         else if (VALUE (x) == char_tab.value) name = char_tab.name;
82         else if (VALUE (x) == char_newline.value) name = char_newline.name;
83         else if (VALUE (x) == char_vtab.value) name = char_vtab.name;
84         else if (VALUE (x) == char_page.value) name = char_page.name;
85         else if (VALUE (x) == char_return.value) name = char_return.name;
86         else if (VALUE (x) == char_space.value) name = char_space.name;
87         if (name) fprintf (f, "#\\%s", name);
88         else fprintf (f, "#\\%c", VALUE (x));
89         break;
90       }
91     case CLOSURE:
92       {
93         fprintf (f, "#<procedure ");
94         SCM name = xassq (x, r0);
95         if (TYPE (name) == PAIR) name = car (name);
96         display_ (f, name);
97         fprintf (f, " ");
98         display_ (f, (cadr (CLOSURE (x))));
99         fprintf (f, ">");
100         return cell_unspecified;
101       }
102     case CONTINUATION:
103       {
104         fprintf (f, "#<continuation %d>", CAR (x));
105         return cell_unspecified;
106       }
107     case MACRO:
108       fprintf (f, "(*macro* ");
109       display_helper (f, g_cells[x].macro, cont, sep, quote);
110       fprintf (f, ")");
111       break;
112     case NUMBER: fprintf (f, "%d", VALUE (x)); break;
113     case PAIR:
114       {
115         if (car (x) == cell_circular) {
116           fprintf (f, "(*circ* . #-1#)");
117           return cell_unspecified;
118         }
119         if (car (x) == cell_closure) {
120           fprintf (f, "(*closure* . #-1#)");
121           return cell_unspecified;
122         }
123         if (car (x) == cell_symbol_quote && TYPE (cdr (x)) != PAIR) {
124           fprintf (f, "'");
125           x = cdr (x);
126           if (TYPE (x) == PAIR)
127             x = car (x);
128           return display_helper (f, x, cont, "", true);
129         }
130         if (!cont) fprintf (f, "(");
131         if (x && x!= cell_nil) display_ (f, car (x));
132         if (cdr (x) && TYPE (cdr (x)) == PAIR)
133           display_helper (f, cdr (x), true, " ", false);
134         else if (cdr (x) && cdr (x) != cell_nil) {
135           fprintf (f, " . ");
136           display_ (f, cdr (x));
137         }
138         if (!cont) fprintf (f, ")");
139         break;
140       }
141     case VECTOR:
142       {
143         fprintf (f, "#(");
144         for (int i = 0; i < LENGTH (x); i++) {
145           if (TYPE (VECTOR (x)+i) == VECTOR
146               || (TYPE (VECTOR (x)+i) == REF
147                   && TYPE (REF (VECTOR (x)+i)) == VECTOR))
148             fprintf (f, "%s#(...)", i ? " " : "");
149           else
150             display_helper (f,VECTOR (x)+i, false, i ? " " : "", false);
151         }
152         fprintf (f, ")");
153         break;
154       }
155     case REF: display_helper (f, g_cells[x].ref, cont, "", true); break;
156     case FUNCTION:
157       {
158         fprintf (f, "#<procedure ");
159         display_ (f, STRING (x));
160         fprintf (f, " ");       //
161         switch (FUNCTION (x).arity)
162           {
163           case -1: fprintf (f, "(. x)"); break;
164           case 0: fprintf (f, "()"); break;
165           case 1: fprintf (f, "(x)"); break;
166           case 2: fprintf (f, "(x y)"); break;
167           case 3: fprintf (f, "(x y z)"); break;
168           }
169         fprintf (f, ">");
170         break;
171       }
172     case BROKEN_HEART: fprintf (f, "<3"); break;
173     case KEYWORD:
174       fprintf (f, "#:");
175     default:
176       if (STRING (x))
177         {
178           SCM p = STRING (x);
179           assert (p);
180           while (p != cell_nil) {
181             assert (TYPE (car (p)) == CHAR);
182             fputc (VALUE (car (p)), f);
183             p = cdr (p);
184           }
185         }
186       else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x));
187     }
188   return cell_unspecified;
189 }