test: Enable vector read test.
[mes.git] / gc.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
22 gc_up_arena () ///((internal))
23 {
24   ARENA_SIZE *= 2;
25   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(struct scm));
26   if (!p) error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list (strerror (errno))), MAKE_NUMBER (g_free)));
27   g_cells = (struct scm*)p;
28   g_cells++;
29   gc_init_news ();
30 }
31
32 SCM
33 gc_flip () ///((internal))
34 {
35   struct scm *cells = g_cells;
36   g_cells = g_news;
37   g_news = cells;
38   if (g_debug) fprintf (stderr, " => jam[%d]\n", g_free);
39   return g_stack;
40 }
41
42 SCM
43 gc_copy (SCM old) ///((internal))
44 {
45   if (TYPE (old) == TBROKEN_HEART) return g_cells[old].car;
46   SCM new = g_free++;
47   g_news[new] = g_cells[old];
48   if (NTYPE (new) == TVECTOR)
49     {
50       g_news[new].vector = g_free;
51       for (int i=0; i<LENGTH (old); i++)
52         g_news[g_free++] = g_cells[VECTOR (old)+i];
53     }
54   g_cells[old].type = TBROKEN_HEART;
55   g_cells[old].car = new;
56   return new;
57 }
58
59 SCM
60 gc_relocate_car (SCM new, SCM car) ///((internal))
61 {
62   g_news[new].car = car;
63   return cell_unspecified;
64 }
65
66 SCM
67 gc_relocate_cdr (SCM new, SCM cdr) ///((internal))
68 {
69   g_news[new].cdr = cdr;
70   return cell_unspecified;
71 }
72
73 SCM
74 gc_loop (SCM scan) ///((internal))
75 {
76   while (scan < g_free)
77     {
78       if (NTYPE (scan) == TCLOSURE
79           || NTYPE (scan) == TCONTINUATION
80           || NTYPE (scan) == TFUNCTION
81           || NTYPE (scan) == TKEYWORD
82           || NTYPE (scan) == TMACRO
83           || NTYPE (scan) == TPAIR
84           || NTYPE (scan) == TREF
85           || scan == 1 // null
86           || NTYPE (scan) == TSPECIAL
87           || NTYPE (scan) == TSTRING
88           || NTYPE (scan) == TSYMBOL)
89         {
90           SCM car = gc_copy (g_news[scan].car);
91           gc_relocate_car (scan, car);
92         }
93       if ((NTYPE (scan) == TCLOSURE
94            || NTYPE (scan) == TCONTINUATION
95            || NTYPE (scan) == TMACRO
96            || NTYPE (scan) == TPAIR
97            || NTYPE (scan) == TVALUES)
98           && g_news[scan].cdr) // allow for 0 terminated list of symbols
99         {
100           SCM cdr = gc_copy (g_news[scan].cdr);
101           gc_relocate_cdr (scan, cdr);
102         }
103       scan++;
104     }
105   return gc_flip ();
106 }
107
108 SCM
109 gc ()
110 {
111   if (g_debug) fprintf (stderr, "***gc[%d]...", g_free);
112   g_free = 1;
113   if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena ();
114   for (int i=g_free; i<g_symbol_max; i++)
115     gc_copy (i);
116   make_tmps (g_news);
117   g_symbols = gc_copy (g_symbols);
118   SCM new = gc_copy (g_stack);
119   if (g_debug) fprintf (stderr, "new=%d\n", new, g_stack);
120   g_stack = new;
121   return gc_loop (1);
122 }