← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to o/toplevel.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/toplevel.c
 
1
/*
 
2
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
3
 
 
4
This file is part of GNU Common Lisp, herein referred to as GCL
 
5
 
 
6
GCL is free software; you can redistribute it and/or modify it under
 
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
8
the Free Software Foundation; either version 2, or (at your option)
 
9
any later version.
 
10
 
 
11
GCL is distributed in the hope that it will be useful, but WITHOUT
 
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
13
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
14
License for more details.
 
15
 
 
16
You should have received a copy of the GNU Library General Public License 
 
17
along with GCL; see the file COPYING.  If not, write to the Free Software
 
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
 
 
20
*/
 
21
 
 
22
/*
 
23
 
 
24
        toplevel.c
 
25
 
 
26
        Top-Level Forms and Declarations
 
27
*/
 
28
 
 
29
#include "include.h"
 
30
 
 
31
object sLcompile, sLload, sLeval;
 
32
object sLprogn;
 
33
 
 
34
 
 
35
object sLwarn;
 
36
 
 
37
object sSAinhibit_macro_specialA;
 
38
 
 
39
object sLtypep;
 
40
 
 
41
Fdefun(args)
 
42
object args;
 
43
{
 
44
        object endp_temp;
 
45
 
 
46
        object name;
 
47
        object body, form;
 
48
 
 
49
        if (endp(args) || endp(MMcdr(args)))
 
50
                FEtoo_few_argumentsF(args);
 
51
        if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons)
 
52
                FEerror("~S is an illegal lambda-list.", 1, MMcadr(args));
 
53
        name = MMcar(args);
 
54
        if (type_of(name) != t_symbol)
 
55
                not_a_symbol(name);
 
56
        if (name->s.s_sfdef != NOT_SPECIAL) {
 
57
                if (name->s.s_mflag) {
 
58
                        if (symbol_value(sSAinhibit_macro_specialA) != Cnil)
 
59
                                name->s.s_sfdef = NOT_SPECIAL;
 
60
                } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil)
 
61
                 FEerror("~S, a special form, cannot be redefined.", 1, name);
 
62
        }
 
63
        if (name->s.s_hpack == lisp_package &&
 
64
            name->s.s_gfdef != OBJNULL && initflag) {
 
65
                vs_push(make_simple_string(
 
66
                        "~S is being redefined."));
 
67
                ifuncall2(sLwarn, vs_head, name);
 
68
                vs_pop;
 
69
        }
 
70
        vs_base = vs_top;
 
71
        if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) {
 
72
                vs_push(MMcons(sLlambda_block, args));
 
73
        } else {
 
74
                vs_push(MMcons(lex_env[2], args));
 
75
                vs_base[0] = MMcons(lex_env[1], vs_base[0]);
 
76
                vs_base[0] = MMcons(lex_env[0], vs_base[0]);
 
77
                vs_base[0] = MMcons(sLlambda_block_closure, vs_base[0]);
 
78
        }
 
79
        {object fname =  clear_compiler_properties(name,vs_base[0]);
 
80
         fname->s.s_gfdef = vs_base[0];
 
81
         fname->s.s_mflag = FALSE;}
 
82
        vs_base[0] = name;
 
83
        for (body = MMcddr(args);  !endp(body);  body = body->c.c_cdr) {
 
84
                form = macro_expand(body->c.c_car);
 
85
                if (type_of(form) == t_string) {
 
86
                        if (endp(body->c.c_cdr))
 
87
                                break;
 
88
                        vs_push(form);
 
89
                        name->s.s_plist =
 
90
                        putf(name->s.s_plist,
 
91
                             form,
 
92
                             sSfunction_documentation);
 
93
                        vs_pop;
 
94
                        break;
 
95
                }
 
96
                if (type_of(form) != t_cons || form->c.c_car != sLdeclare)
 
97
                        break;
 
98
        }
 
99
}
 
100
        
 
101
siLAmake_special()
 
102
{
 
103
        check_arg(1);
 
104
        check_type_symbol(&vs_base[0]);
 
105
        if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
 
106
                FEerror("~S is a constant.", 1, vs_base[0]);
 
107
        vs_base[0]->s.s_stype = (short)stp_special;
 
108
}
 
109
 
 
110
siLAmake_constant()
 
111
{
 
112
        check_arg(2);
 
113
        check_type_symbol(&vs_base[0]);
 
114
        if ((enum stype)vs_base[0]->s.s_stype == stp_special)
 
115
                FEerror(
 
116
                 "The argument ~S to DEFCONSTANT is a special variable.",
 
117
                 1, vs_base[0]);
 
118
        vs_base[0]->s.s_stype = (short)stp_constant;
 
119
        vs_base[0]->s.s_dbind = vs_base[1];
 
120
        vs_pop;
 
121
}
 
122
 
 
123
Feval_when(arg)
 
124
object arg;
 
125
{
 
126
        object endp_temp;
 
127
 
 
128
        object *base = vs_base;
 
129
        object ss;
 
130
        bool flag = FALSE;
 
131
 
 
132
        if(endp(arg))
 
133
                FEtoo_few_argumentsF(arg);
 
134
        for (ss = MMcar(arg);  !endp(ss);  ss = MMcdr(ss))
 
135
                if(MMcar(ss) == sLeval)
 
136
                        flag = TRUE;
 
137
                else if(MMcar(ss) != sLload && MMcar(ss) != sLcompile)
 
138
                 FEinvalid_form("~S is an undefined situation for EVAL-WHEN.",
 
139
                                MMcar(ss));
 
140
        if(flag) {
 
141
                vs_push(make_cons(sLprogn, MMcdr(arg)));
 
142
                eval(vs_head);
 
143
        } else {
 
144
                vs_base = base;
 
145
                vs_top = base+1;
 
146
                vs_base[0] = Cnil;
 
147
        }
 
148
}
 
149
 
 
150
Fdeclare(arg)
 
151
object arg;
 
152
{
 
153
        FEerror("DECLARE appeared in an invalid position.", 0);
 
154
}
 
155
 
 
156
Flocally(body)
 
157
object body;
 
158
{
 
159
        object *oldlex = lex_env;
 
160
        object x, ds, vs, v;
 
161
 
 
162
        lex_copy();
 
163
        body = find_special(body, NULL, NULL);
 
164
        vs_push(body);
 
165
        Fprogn(body);
 
166
        lex_env = oldlex;
 
167
}
 
168
 
 
169
Fthe(args)
 
170
object args;
 
171
{
 
172
        object endp_temp;
 
173
 
 
174
        object *vs;
 
175
 
 
176
        if(endp(args) || endp(MMcdr(args)))
 
177
                FEtoo_few_argumentsF(args);
 
178
        if(!endp(MMcddr(args)))
 
179
                FEtoo_many_argumentsF(args);
 
180
        eval(MMcadr(args));
 
181
        args = MMcar(args);
 
182
        if (type_of(args) == t_cons && MMcar(args) == sLvalues) {
 
183
                vs = vs_base;
 
184
                for (args=MMcdr(args); !endp(args); args=MMcdr(args), vs++){
 
185
                        if (vs >= vs_top)
 
186
                                FEerror("Too many return values.", 0);
 
187
                        if (ifuncall2(sLtypep, *vs, MMcar(args)) == Cnil)
 
188
                                FEwrong_type_argument(MMcar(args), *vs);
 
189
                }
 
190
                if (vs < vs_top)
 
191
                        FEerror("Too few return values.", 0);
 
192
        } else {
 
193
                if (ifuncall2(sLtypep, vs_base[0], args) == Cnil)
 
194
                        FEwrong_type_argument(args, vs_base[0]);
 
195
        }
 
196
}
 
197
 
 
198
DEF_ORDINARY("COMPILE",sLcompile,LISP,"");
 
199
DEF_ORDINARY("DECLARE",sLdeclare,LISP,"");
 
200
DEF_ORDINARY("EVAL",sLeval,LISP,"");
 
201
DEF_ORDINARY("EVAL",sLeval,LISP,"");
 
202
DEF_ORDINARY("FUNCTION-DOCUMENTATION",sSfunction_documentation,SI,"");
 
203
DEF_ORDINARY("LOAD",sLload,LISP,"");
 
204
DEF_ORDINARY("PROGN",sLprogn,LISP,"");
 
205
DEF_ORDINARY("TYPEP",sLtypep,LISP,"");
 
206
DEF_ORDINARY("VALUES",sLvalues,LISP,"");
 
207
DEF_ORDINARY("VARIABLE-DOCUMENTATION",sSvariable_documentation,SI,"");
 
208
DEF_ORDINARY("WARN",sLwarn,LISP,"");
 
209
 
 
210
init_toplevel()
 
211
{
 
212
        make_special_form("DEFUN",Fdefun);
 
213
        make_si_function("*MAKE-SPECIAL", siLAmake_special);
 
214
        make_si_function("*MAKE-CONSTANT", siLAmake_constant);
 
215
        make_special_form("EVAL-WHEN", Feval_when);
 
216
        make_special_form("THE", Fthe);
 
217
        make_special_form("DECLARE",Fdeclare);
 
218
        make_special_form("LOCALLY",Flocally);
 
219
 
 
220
 
 
221
}