← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/cfun.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/cfun.d
 
1
/*
 
2
    cfun.c -- Compiled functions.
 
3
*/
 
4
/*
 
5
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 
6
    Copyright (c) 1990, Giuseppe Attardi.
 
7
    Copyright (c) 2001, Juan Jose Garcia Ripoll.
 
8
 
 
9
    ECL is free software; you can redistribute it and/or
 
10
    modify it under the terms of the GNU Library General Public
 
11
    License as published by the Free Software Foundation; either
 
12
    version 2 of the License, or (at your option) any later version.
 
13
 
 
14
    See file '../Copyright' for full details.
 
15
*/
 
16
 
 
17
#include <ecl/ecl.h>
 
18
#include <string.h>     /* for memmove() */
 
19
 
 
20
cl_object
 
21
cl_make_cfun(void *c_function, cl_object name, cl_object cblock, int narg)
 
22
{
 
23
        cl_object cf;
 
24
 
 
25
        cf = cl_alloc_object(t_cfun);
 
26
        cf->cfun.entry = c_function;
 
27
        cf->cfun.name = name;
 
28
        cf->cfun.block = cblock;
 
29
        cf->cfun.narg = narg;
 
30
        if (narg < 0 || narg >= C_ARGUMENTS_LIMIT)
 
31
            FEprogram_error("cl_make_cfun: function requires too many arguments.",0);
 
32
        return(cf);
 
33
}
 
34
 
 
35
cl_object
 
36
cl_make_cfun_va(void *c_function, cl_object name, cl_object cblock)
 
37
{
 
38
        cl_object cf;
 
39
 
 
40
        cf = cl_alloc_object(t_cfun);
 
41
        cf->cfun.entry = c_function;
 
42
        cf->cfun.name = name;
 
43
        cf->cfun.block = cblock;
 
44
        cf->cfun.narg = -1;
 
45
        return(cf);
 
46
}
 
47
 
 
48
cl_object
 
49
cl_make_cclosure_va(void *c_function, cl_object env, cl_object block)
 
50
{
 
51
        cl_object cc;
 
52
 
 
53
        cc = cl_alloc_object(t_cclosure);
 
54
        cc->cclosure.entry = c_function;
 
55
        cc->cclosure.env = env;
 
56
        cc->cclosure.block = block;
 
57
        return(cc);
 
58
}
 
59
 
 
60
void
 
61
cl_def_c_function(cl_object sym, void *c_function, int narg)
 
62
{
 
63
        si_fset(2, sym,
 
64
                cl_make_cfun(c_function, sym, symbol_value(@'si::*cblock*'), narg));
 
65
}
 
66
 
 
67
void
 
68
cl_def_c_macro(cl_object sym, void *c_function, int narg)
 
69
{
 
70
        si_fset(3, sym,
 
71
                (narg >= 0)?
 
72
                cl_make_cfun(c_function, sym, symbol_value(@'si::*cblock*'), 2):
 
73
                cl_make_cfun_va(c_function, sym, symbol_value(@'si::*cblock*')),
 
74
                Ct);
 
75
}
 
76
 
 
77
void
 
78
cl_def_c_function_va(cl_object sym, void *c_function)
 
79
{
 
80
        si_fset(2, sym,
 
81
                cl_make_cfun_va(c_function, sym, symbol_value(@'si::*cblock*')));
 
82
}
 
83
 
 
84
cl_object
 
85
si_compiled_function_name(cl_object fun)
 
86
{
 
87
        cl_object output;
 
88
 
 
89
        switch(type_of(fun)) {
 
90
        case t_bytecodes:
 
91
                output = fun->bytecodes.name; break;
 
92
        case t_cfun:
 
93
                output = fun->cfun.name; break;
 
94
        case t_cclosure:
 
95
                output = Cnil; break;
 
96
        default:
 
97
                FEinvalid_function(fun);
 
98
        }
 
99
        @(return output)
 
100
}
 
101
 
 
102
cl_object
 
103
cl_function_lambda_expression(cl_object fun)
 
104
{
 
105
        cl_object output, name = Cnil, lex = Cnil;
 
106
 
 
107
        switch(type_of(fun)) {
 
108
        case t_bytecodes:
 
109
                lex = fun->bytecodes.lex;
 
110
                name = fun->bytecodes.name;
 
111
                output = fun->bytecodes.definition;
 
112
                if (!CONSP(output))
 
113
                    output = Cnil;
 
114
                else if (name == Cnil)
 
115
                    output = cl_cons(@'lambda', output);
 
116
                else
 
117
                    output = @list*(3, @'ext::lambda-block', name, output);
 
118
                break;
 
119
        case t_cfun:
 
120
                name = fun->cfun.name;
 
121
                lex = Cnil;
 
122
                output = Cnil;
 
123
                break;
 
124
        case t_cclosure:
 
125
                name = Cnil;
 
126
                lex = Ct;
 
127
                output = Cnil;
 
128
                break;
 
129
#ifdef CLOS
 
130
        case t_instance:
 
131
                if (fun->instance.isgf) {
 
132
                        name = Cnil;
 
133
                        lex = Cnil;
 
134
                        output = Cnil;
 
135
                        break;
 
136
                }
 
137
#endif
 
138
        default:
 
139
                FEinvalid_function(fun);
 
140
        }
 
141
        @(return output lex name)
 
142
}
 
143
 
 
144
cl_object
 
145
si_compiled_function_block(cl_object fun)
 
146
{
 
147
       cl_object output;
 
148
 
 
149
       switch(type_of(fun)) {
 
150
        case t_cfun:
 
151
                output = fun->cfun.block; break;
 
152
        case t_cclosure:
 
153
                output = fun->cclosure.block; break;
 
154
        default:
 
155
                FEerror("~S is not a compiled-function.", 1, fun);
 
156
        }
 
157
        @(return output)
 
158
}