← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/lispmach.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/lispmach.c
 
1
/* lispmach.c -- Interpreter for compiled Lisp forms
 
2
 
 
3
   $Id: lispmach.c,v 1.108 2000/09/03 12:36:04 john Exp $
 
4
 
 
5
   Copyright (C) 1993, 1994, 2000 John Harper <john@dcs.warwick.ac.uk>
 
6
 
 
7
   This file is part of Jade.
 
8
 
 
9
   Jade is free software; you can redistribute it and/or modify it
 
10
   under the terms of the GNU General Public License as published by
 
11
   the Free Software Foundation; either version 2, or (at your option)
 
12
   any later version.
 
13
 
 
14
   Jade is distributed in the hope that it will be useful, but
 
15
   WITHOUT ANY WARRANTY; without even the implied warranty of
 
16
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
17
   GNU General Public License for more details.
 
18
 
 
19
   You should have received a copy of the GNU General Public License
 
20
   along with Jade; see the file COPYING.  If not, write to
 
21
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
 
22
 
 
23
#define _GNU_SOURCE
 
24
 
 
25
/* Define this to check if the compiler gets things right */
 
26
#undef TRUST_NO_ONE
 
27
 
 
28
/* Define this to bytecode use histograms */
 
29
#undef BYTECODE_PROFILE
 
30
 
 
31
/* Define this to cache top-of-stack in a register (not usually worth it) */
 
32
#undef CACHE_TOS
 
33
 
 
34
/* AIX requires this to be the first thing in the file.  */
 
35
#include <config.h>
 
36
#ifdef __GNUC__
 
37
# define alloca __builtin_alloca
 
38
#else
 
39
# if HAVE_ALLOCA_H
 
40
#  include <alloca.h>
 
41
# else
 
42
#  ifdef _AIX
 
43
 #pragma alloca
 
44
#  else
 
45
#   ifndef alloca /* predefined by HP cc +Olibcalls */
 
46
char *alloca ();
 
47
#   endif
 
48
#  endif
 
49
# endif
 
50
#endif
 
51
 
 
52
#include "repint.h"
 
53
#include <assert.h>
 
54
 
 
55
DEFSYM(bytecode_error, "bytecode-error");
 
56
 
 
57
 
 
58
/* pull in the generic interpreter */
 
59
 
 
60
#ifdef BYTECODE_PROFILE
 
61
static int bytecode_profile[256];
 
62
#endif
 
63
 
 
64
#ifdef TRUST_NO_ONE
 
65
# define ASSERT(x) assert(x)
 
66
#else
 
67
# define ASSERT(x)
 
68
#endif
 
69
 
 
70
#define BC_APPLY_SELF 0
 
71
 
 
72
#include "lispmach.h"
 
73
 
 
74
 
 
75
/* interface */
 
76
 
 
77
repv
 
78
rep_apply_bytecode (repv subr, int nargs, repv *args)
 
79
{
 
80
    assert (rep_COMPILEDP (subr));
 
81
    return inline_apply_bytecode (subr, nargs, args);
 
82
}
 
83
 
 
84
DEFUN("run-byte-code", Frun_byte_code, Srun_byte_code,
 
85
      (repv code, repv consts, repv stkreq), rep_Subr3)
 
86
{
 
87
    int v_stkreq, b_stkreq, s_stkreq;
 
88
 
 
89
    if (rep_STRUCTUREP (code))
 
90
    {
 
91
        /* install ourselves in this structure */
 
92
        rep_STRUCTURE (code)->apply_bytecode = 0;
 
93
        return Qt;
 
94
    }
 
95
 
 
96
    rep_DECLARE1(code, rep_STRINGP);
 
97
    rep_DECLARE2(consts, rep_VECTORP);
 
98
    rep_DECLARE3(stkreq, rep_INTP);
 
99
 
 
100
    v_stkreq = rep_INT (stkreq) & 0x3ff;
 
101
    b_stkreq = (rep_INT (stkreq) >> 10) & 0x3ff;
 
102
    s_stkreq = rep_INT (stkreq) >> 20;
 
103
 
 
104
    return vm (code, consts, 0, 0, v_stkreq, b_stkreq, s_stkreq);
 
105
}
 
106
 
 
107
DEFUN("validate-byte-code", Fvalidate_byte_code, Svalidate_byte_code, (repv bc_major, repv bc_minor), rep_Subr2) /*
 
108
::doc:rep.vm.interpreter#validate-byte-code::
 
109
validate-byte-code BC-MAJOR BC-MINOR
 
110
 
 
111
Check that byte codes from instruction set BC-MAJOR.BC-MINOR, may be
 
112
executed. If not, an error will be signalled.
 
113
::end:: */
 
114
{
 
115
    if(!rep_INTP(bc_major) || !rep_INTP(bc_minor)
 
116
       || rep_INT(bc_major) != BYTECODE_MAJOR_VERSION
 
117
       || rep_INT(bc_minor) > BYTECODE_MINOR_VERSION)
 
118
    {
 
119
        DEFSTRING (err, "File needs recompiling for current virtual machine");
 
120
        return Fsignal (Qbytecode_error,
 
121
                        rep_LIST_2 (rep_VAL (&err),
 
122
                                    Fsymbol_value (Qload_filename, Qt)));
 
123
    }
 
124
    else
 
125
        return Qt;
 
126
}
 
127
 
 
128
DEFUN("make-byte-code-subr", Fmake_byte_code_subr, Smake_byte_code_subr, (repv args), rep_SubrN) /*
 
129
::doc:rep.vm.interpreter#make-byte-code-subr::
 
130
make-byte-code-subr CODE CONSTANTS STACK [DOC] [INTERACTIVE]
 
131
 
 
132
Return an object that can be used as the function value of a symbol.
 
133
::end:: */
 
134
{
 
135
    int len = rep_list_length(args);
 
136
    repv obj[5], vec;
 
137
    int used;
 
138
 
 
139
    if(len < rep_COMPILED_MIN_SLOTS)
 
140
        return rep_signal_missing_arg(len + 1);
 
141
    
 
142
    if(!rep_STRINGP(rep_CAR(args)))
 
143
        return rep_signal_arg_error(rep_CAR(args), 2);
 
144
    obj[0] = rep_CAR(args); args = rep_CDR(args);
 
145
    if(!rep_VECTORP(rep_CAR(args)))
 
146
        return rep_signal_arg_error(rep_CAR(args), 3);
 
147
    obj[1] = rep_CAR(args); args = rep_CDR(args);
 
148
    if(!rep_INTP(rep_CAR(args)))
 
149
        return rep_signal_arg_error(rep_CAR(args), 4);
 
150
    obj[2] = rep_CAR(args); args = rep_CDR(args);
 
151
    used = 3;
 
152
 
 
153
    if(rep_CONSP(args))
 
154
    {
 
155
        obj[used++] = rep_CAR(args); args = rep_CDR(args);
 
156
        if(rep_CONSP(args))
 
157
        {
 
158
            obj[used++] = rep_CAR(args); args = rep_CDR(args);
 
159
            if(rep_NILP(obj[used - 1]))
 
160
                used--;
 
161
        }
 
162
        if(used == 4 && rep_NILP(obj[used - 1]))
 
163
            used--;
 
164
    }
 
165
 
 
166
    vec = Fmake_vector(rep_MAKE_INT(used), Qnil);
 
167
    if(vec != rep_NULL)
 
168
    {
 
169
        int i;
 
170
        rep_COMPILED(vec)->car = ((rep_COMPILED(vec)->car
 
171
                                   & ~rep_CELL8_TYPE_MASK) | rep_Compiled);
 
172
        for(i = 0; i < used; i++)
 
173
            rep_VECTI(vec, i) = obj[i];
 
174
    }
 
175
    return vec;
 
176
}
 
177
 
 
178
DEFUN("bytecodep", Fbytecodep, Sbytecodep, (repv arg), rep_Subr1) /*
 
179
::doc:rep.vm.interpreter#bytecodep::
 
180
bytecodep ARG
 
181
 
 
182
Returns t if ARG is a byte code subroutine (i.e. compiled Lisp code).
 
183
::end:: */
 
184
{
 
185
    return rep_COMPILEDP(arg) ? Qt : Qnil;
 
186
}
 
187
 
 
188
#ifdef BYTECODE_PROFILE
 
189
static void
 
190
print_bytecode_profile (void)
 
191
{
 
192
    int i;
 
193
    for (i = 0; i < 256; i++)
 
194
        printf ("%8d %8d\n", i, bytecode_profile[i]);
 
195
}
 
196
 
 
197
DEFUN ("bytecode-profile", Fbytecode_profile,
 
198
       Sbytecode_profile, (repv reset), rep_Subr1)
 
199
{
 
200
    if (reset != Qnil)
 
201
        memset (bytecode_profile, 0, sizeof (bytecode_profile));
 
202
    else
 
203
        print_bytecode_profile ();
 
204
    return Qnil;
 
205
}
 
206
#endif
 
207
 
 
208
void
 
209
rep_lispmach_init(void)
 
210
{
 
211
    repv tem = rep_push_structure ("rep.vm.interpreter");
 
212
    rep_ADD_SUBR(Srun_byte_code);
 
213
    rep_ADD_SUBR(Svalidate_byte_code);
 
214
    rep_ADD_SUBR(Smake_byte_code_subr);
 
215
    rep_ADD_SUBR(Sbytecodep);
 
216
#ifdef BYTECODE_PROFILE
 
217
    rep_ADD_SUBR(Sbytecode_profile);
 
218
    atexit (print_bytecode_profile);
 
219
#endif
 
220
    rep_INTERN(bytecode_error); rep_ERROR(bytecode_error);
 
221
    rep_pop_structure (tem);
 
222
}
 
223
 
 
224
void
 
225
rep_lispmach_kill(void)
 
226
{
 
227
}