build: Resurrect --with-cheating.
[mes.git] / src / module.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of GNU Mes.
6  *
7  * GNU 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  * GNU 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
19  */
20
21 #include "mes/lib.h"
22 #include "mes/mes.h"
23
24 #include <assert.h>
25
26 SCM
27 make_module_type ()             ///(internal))
28 {
29   SCM record_type = cell_symbol_record_type;    // FIXME
30   SCM fields = cell_nil;
31   fields = cons (cstring_to_symbol ("globals"), fields);
32   fields = cons (cstring_to_symbol ("locals"), fields);
33   fields = cons (cstring_to_symbol ("name"), fields);
34   fields = cons (fields, cell_nil);
35   fields = cons (cell_symbol_module, fields);
36   return make_struct (record_type, fields, cell_unspecified);
37 }
38
39 SCM
40 make_initial_module (SCM a)     ///((internal))
41 {
42   SCM module_type = make_module_type ();
43   a = acons (cell_symbol_module, module_type, a);
44
45   SCM hashq_type = make_hashq_type ();
46   a = acons (cell_symbol_hashq_table, hashq_type, a);
47
48   SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
49   SCM globals = make_hash_table_ (0);
50   SCM locals = cell_nil;
51
52   SCM values = cell_nil;
53   values = cons (globals, values);
54   values = cons (locals, values);
55   values = cons (name, values);
56   values = cons (cell_symbol_module, values);
57   SCM module = make_struct (module_type, values, cstring_to_symbol ("module-printer"));
58   r0 = cell_nil;
59   r0 = cons (CADR (a), r0);
60   r0 = cons (CAR (a), r0);
61   m0 = module;
62   while (TYPE (a) == TPAIR)
63     {
64       module_define_x (module, CAAR (a), CDAR (a));
65       a = CDR (a);
66     }
67
68   return module;
69 }
70
71 SCM
72 module_printer (SCM module)
73 {
74   //module = m0;
75   fdputs ("#<", __stdout);
76   display_ (struct_ref_ (module, 2));
77   fdputc (' ', __stdout);
78   fdputs ("name: ", __stdout);
79   display_ (struct_ref_ (module, 3));
80   fdputc (' ', __stdout);
81   fdputs ("locals: ", __stdout);
82   display_ (struct_ref_ (module, 4));
83   fdputc (' ', __stdout);
84   SCM table = struct_ref_ (module, 5);
85   fdputs ("globals:\n  ", __stdout);
86   display_ (table);
87   fdputc ('>', __stdout);
88 }
89
90 SCM
91 module_variable (SCM module, SCM name)
92 {
93   //SCM locals = struct_ref_ (module, 3);
94   SCM locals = module;
95   SCM x = assq (name, locals);
96   if (x == cell_f)
97     {
98       module = m0;
99       SCM globals = struct_ref_ (module, 5);
100       x = hashq_get_handle (globals, name, cell_f);
101     }
102   return x;
103 }
104
105 SCM
106 module_ref (SCM module, SCM name)
107 {
108   SCM x = module_variable (module, name);
109   if (x == cell_f)
110     return cell_undefined;
111   return CDR (x);
112 }
113
114 SCM
115 module_define_x (SCM module, SCM name, SCM value)
116 {
117   module = m0;
118   SCM globals = struct_ref_ (module, 5);
119   return hashq_set_x (globals, name, value);
120 }