← Back to branch summary

~ubuntu-branches/ubuntu/trusty/librep/trusty

« back to all changes in this revision

Viewing changes to src/macros.c

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2001-11-13 15:06:22 UTC
  • Revision ID: james.westby@ubuntu.com-20011113150622-vgmgmk6srj3kldr3
Tags: upstream-0.15.2
Import upstream version 0.15.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/macros.c
 
1
/* macros.c -- macroexpand etc
 
2
   Copyright (C) 1993, 1994, 2000 John Harper <john@dcs.warwick.ac.uk>
 
3
   $Id: macros.c,v 1.11 2001/08/08 06:15:32 jsh Exp $
 
4
 
 
5
   This file is part of librep.
 
6
 
 
7
   librep 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 2, or (at your option)
 
10
   any later version.
 
11
 
 
12
   librep 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 librep; see the file COPYING.  If not, write to
 
19
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
 
20
 
 
21
/* Commentary:
 
22
 
 
23
   The idea is to memoize macro expansions, but only until the next
 
24
   garbage collection. This introduces very little memory overhead, two
 
25
   cons cells per expansion (the expansion is around anyway until gc)
 
26
 
 
27
   Whether it would be useful to keep expansions around for longer is
 
28
   something that needs to be looked at later..
 
29
 
 
30
   It's actually pretty good on its own. E.g. doing (compile-compiler)
 
31
   with all interpreted code gives a miss ratio of about .023  */
 
32
 
 
33
#define _GNU_SOURCE
 
34
 
 
35
#include "repint.h"
 
36
#include <string.h>
 
37
#ifdef NEED_MEMORY_H
 
38
# include <memory.h>
 
39
#endif
 
40
 
 
41
#define HIST_SIZE 256
 
42
#define HIST_HASH_FN(x) (((x) >> 4) % HIST_SIZE)
 
43
 
 
44
/* Each entry is a chain of cons cells. But note that the last cell's
 
45
   cdr is dotted to ((repv)0) not Qnil */
 
46
static repv history[HIST_SIZE];
 
47
 
 
48
static int macro_hits, macro_misses;
 
49
 
 
50
DEFSYM(macro_environment, "macro-environment");
 
51
 
 
52
static inline repv
 
53
symbol_value_in_structure (repv structure, repv sym)
 
54
{
 
55
    repv old = rep_structure, value;
 
56
    rep_structure = structure;
 
57
    value = Fsymbol_value (sym, Qt);
 
58
    rep_structure = old;
 
59
    return value;
 
60
}
 
61
 
 
62
DEFUN("macroexpand-1", Fmacroexpand_1, Smacroexpand_1,
 
63
      (repv form, repv env), rep_Subr2) /*
 
64
::doc:rep.lang.interpreter#macroexpand-1::
 
65
macroexpand-1 FORM [ENVIRONMENT]
 
66
 
 
67
If FORM is a macro call, expand it once and return the resulting form.
 
68
 
 
69
If ENVIRONMENT is specified it is a function to call to do the actual
 
70
expansion. Any macro expanders recursively calling macroexpand should
 
71
pass the value of the `macro-environment' variable to this parameter.
 
72
::end:: */
 
73
{
 
74
    rep_GC_root gc_bindings;
 
75
    repv car, bindings;
 
76
 
 
77
    if (!rep_CONSP (form))
 
78
        return form;
 
79
 
 
80
    if (env != Qnil && Ffunctionp (env) != Qnil)
 
81
        return rep_call_lisp1 (env, form);
 
82
 
 
83
again:
 
84
    car = rep_CAR(form);
 
85
    if(rep_SYMBOLP(car))
 
86
    {
 
87
        if (rep_STRUCTUREP (env))
 
88
            /* deref the symbol in the module that it appeared in.. */
 
89
            car = symbol_value_in_structure (env, car);
 
90
        else
 
91
            car = Fsymbol_value (car, Qt);
 
92
        if (!rep_CONSP(car) || rep_CAR(car) != Qmacro)
 
93
            return form;
 
94
        car = rep_CDR(car);
 
95
    }
 
96
    else if (rep_CONSP(car) && rep_CAR(car) == Qmacro)
 
97
        car = rep_CDR(car);
 
98
 
 
99
    if (Ffunctionp(car) == Qnil)
 
100
        return form;
 
101
 
 
102
    if (rep_FUNARGP (car))
 
103
    {
 
104
        repv fun = rep_FUNARG (car)->fun;
 
105
        if (rep_CONSP (fun) && rep_CAR (fun) == Qautoload)
 
106
        {
 
107
            /* an autoload. handle this locally. */
 
108
            struct rep_Call lc;
 
109
            rep_GC_root gc_form, gc_env;
 
110
            lc.fun = Qnil;
 
111
            lc.args = Qnil;
 
112
 
 
113
            rep_PUSH_CALL (lc);
 
114
            rep_USE_FUNARG (car);
 
115
            rep_PUSHGC (gc_form, form);
 
116
            rep_PUSHGC (gc_env, env);
 
117
            car = rep_load_autoload (car);
 
118
            rep_POPGC; rep_POPGC;
 
119
            rep_POP_CALL (lc);
 
120
 
 
121
            if (car != rep_NULL)
 
122
                goto again;
 
123
            else
 
124
                return rep_NULL;
 
125
        }
 
126
    }
 
127
 
 
128
    bindings = rep_bind_symbol (Qnil, Qmacro_environment, rep_structure);
 
129
    rep_PUSHGC(gc_bindings, bindings);
 
130
    form = rep_funcall (car, rep_CDR(form), rep_FALSE);
 
131
    rep_POPGC;
 
132
    rep_unbind_symbols (bindings);
 
133
    return form;
 
134
}
 
135
 
 
136
DEFUN("macroexpand", Fmacroexpand, Smacroexpand,
 
137
      (repv form, repv env), rep_Subr2) /*
 
138
::doc:rep.lang.interpreter#macroexpand::
 
139
macroexpand FORM [ENVIRONMENT]
 
140
 
 
141
If FORM is a macro call, expand it until it isn't.
 
142
 
 
143
If ENVIRONMENT is specified it is a function to call to do the actual
 
144
expansion. Any macro expanders recursively calling macroexpand should
 
145
pass the value of the `macro-environment' variable to this parameter.
 
146
::end:: */
 
147
{
 
148
    repv input = form, pred, ptr;
 
149
    rep_GC_root gc_input, gc_pred;
 
150
 
 
151
    if (!rep_CONSP (form))
 
152
        return form;
 
153
 
 
154
    /* Search the history */
 
155
    ptr = history[HIST_HASH_FN(form)];
 
156
    while (ptr != 0)
 
157
    {
 
158
        if (rep_CAAR (ptr) == form)
 
159
        {
 
160
            macro_hits++;
 
161
            return rep_CDAR (ptr);
 
162
        }
 
163
        ptr = rep_CDR (ptr);
 
164
    }
 
165
    macro_misses++;
 
166
 
 
167
    rep_PUSHGC(gc_input, input);
 
168
    rep_PUSHGC(gc_pred, pred);
 
169
    pred = form;
 
170
    while (1)
 
171
    {
 
172
        form = Fmacroexpand_1 (pred, env);
 
173
        if (form == rep_NULL || form == pred)
 
174
            break;
 
175
        pred = form;
 
176
    }
 
177
    rep_POPGC; rep_POPGC;
 
178
 
 
179
    if (form != rep_NULL)
 
180
    {
 
181
        /* Cache for future use */
 
182
        u_int hash = HIST_HASH_FN(input);
 
183
        history[hash] = Fcons (Fcons (input, form), history[hash]);
 
184
    }
 
185
 
 
186
    return form;
 
187
}
 
188
 
 
189
void
 
190
rep_macros_before_gc (void)
 
191
{
 
192
    /* XXX Perhaps be more discerning? (We would need to arrange some
 
193
       XXX marking then though..) */
 
194
    rep_macros_clear_history ();
 
195
}
 
196
 
 
197
void
 
198
rep_macros_clear_history (void)
 
199
{
 
200
    memset (history, 0, sizeof (history));
 
201
}
 
202
 
 
203
void
 
204
rep_macros_init (void)
 
205
{
 
206
    repv tem = rep_push_structure ("rep.lang.interpreter");
 
207
    rep_ADD_SUBR(Smacroexpand);
 
208
    rep_ADD_SUBR(Smacroexpand_1);
 
209
    rep_INTERN_SPECIAL(macro_environment);
 
210
    Fset (Qmacro_environment, Qnil);
 
211
    rep_macros_clear_history ();
 
212
    rep_pop_structure (tem);
 
213
}