← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to o/toplevel.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

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, sKcompile_toplevel, sLload_toplevel, sKexecute;
 
32
object sLprogn;
 
33
 
 
34
 
 
35
object sLwarn;
 
36
 
 
37
object sSAinhibit_macro_specialA;
 
38
 
 
39
object sLtypep;
 
40
 
 
41
static void
 
42
FFN(Fdefun)(object args)
 
43
{
 
44
 
 
45
        object name;
 
46
        object body, form;
 
47
 
 
48
        if (endp(args) || endp(MMcdr(args)))
 
49
                FEtoo_few_argumentsF(args);
 
50
        if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons)
 
51
                FEerror("~S is an illegal lambda-list.", 1, MMcadr(args));
 
52
        name = MMcar(args);
 
53
        if (type_of(name) != t_symbol) {
 
54
          if (setf_fn_form(name)) {
 
55
            vs_base = vs_top;
 
56
            vs_push(MMcons(sLlambda, MMcdr(args)));
 
57
            putprop(MMcadr(name),vs_base[0],sSsetf_function);
 
58
            vs_base[0]=name;
 
59
            return;
 
60
          } else
 
61
            not_a_symbol(name);
 
62
        }
 
63
        if (name->s.s_sfdef != NOT_SPECIAL) {
 
64
          if (name->s.s_mflag) {
 
65
            if (symbol_value(sSAinhibit_macro_specialA) != Cnil)
 
66
              name->s.s_sfdef = NOT_SPECIAL;
 
67
          } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil)
 
68
            FEerror("~S, a special form, cannot be redefined.", 1, name);
 
69
        }
 
70
        if (name->s.s_hpack == lisp_package &&
 
71
            name->s.s_gfdef != OBJNULL && initflag) {
 
72
          vs_push(make_simple_string(
 
73
                                     "~S is being redefined."));
 
74
          ifuncall2(sLwarn, vs_head, name);
 
75
          vs_popp;
 
76
        }
 
77
        vs_base = vs_top;
 
78
        if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) {
 
79
          vs_push(MMcons(sLlambda_block, args));
 
80
        } else {
 
81
          vs_push(MMcons(lex_env[2], args));
 
82
          vs_base[0] = MMcons(lex_env[1], vs_base[0]);
 
83
          vs_base[0] = MMcons(lex_env[0], vs_base[0]);
 
84
          vs_base[0] = MMcons(sLlambda_block_closure, vs_base[0]);
 
85
        }
 
86
        {object fname =  clear_compiler_properties(name,vs_base[0]);
 
87
        fname->s.s_gfdef = vs_base[0];
 
88
        fname->s.s_mflag = FALSE;}
 
89
        vs_base[0] = name;
 
90
        for (body = MMcddr(args);  !endp(body);  body = body->c.c_cdr) {
 
91
          form = macro_expand(body->c.c_car);
 
92
          if (type_of(form) == t_string) {
 
93
            if (endp(body->c.c_cdr))
 
94
              break;
 
95
            vs_push(form);
 
96
            name->s.s_plist =
 
97
              putf(name->s.s_plist,
 
98
                   form,
 
99
                   sSfunction_documentation);
 
100
            vs_popp;
 
101
            break;
 
102
          }
 
103
          if (type_of(form) != t_cons || form->c.c_car != sLdeclare)
 
104
            break;
 
105
        }
 
106
}
 
107
        
 
108
static void
 
109
FFN(siLAmake_special)(void)
 
110
{
 
111
        check_arg(1);
 
112
        check_type_symbol(&vs_base[0]);
 
113
        if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
 
114
                FEerror("~S is a constant.", 1, vs_base[0]);
 
115
        vs_base[0]->s.s_stype = (short)stp_special;
 
116
}
 
117
 
 
118
static void
 
119
FFN(siLAmake_constant)(void)
 
120
{
 
121
        check_arg(2);
 
122
        check_type_symbol(&vs_base[0]);
 
123
        if ((enum stype)vs_base[0]->s.s_stype == stp_special)
 
124
                FEerror(
 
125
                 "The argument ~S to DEFCONSTANT is a special variable.",
 
126
                 1, vs_base[0]);
 
127
        vs_base[0]->s.s_stype = (short)stp_constant;
 
128
        vs_base[0]->s.s_dbind = vs_base[1];
 
129
        vs_popp;
 
130
}
 
131
 
 
132
static void
 
133
FFN(Feval_when)(object arg)
 
134
{
 
135
 
 
136
        object *base = vs_base;
 
137
        object ss;
 
138
        bool flag = FALSE;
 
139
 
 
140
        if(endp(arg))
 
141
                FEtoo_few_argumentsF(arg);
 
142
        for (ss = MMcar(arg);  !endp(ss);  ss = MMcdr(ss))
 
143
            if ( (MMcar(ss) == sLeval) || (MMcar(ss) == sKexecute) )
 
144
                        flag = TRUE;
 
145
                else if ( MMcar(ss) != sLload && MMcar(ss) != sLcompile &&
 
146
                          MMcar(ss) != sLload_toplevel && MMcar(ss) != sKcompile_toplevel )
 
147
                 FEinvalid_form("~S is an undefined situation for EVAL-WHEN.",
 
148
                                MMcar(ss));
 
149
        if(flag) {
 
150
                vs_push(make_cons(sLprogn, MMcdr(arg)));
 
151
                eval(vs_head);
 
152
        } else {
 
153
                vs_base = base;
 
154
                vs_top = base+1;
 
155
                vs_base[0] = Cnil;
 
156
        }
 
157
}
 
158
 
 
159
static void
 
160
FFN(Fdeclare)(object arg)
 
161
{
 
162
        FEerror("DECLARE appeared in an invalid position.", 0);
 
163
}
 
164
 
 
165
static void
 
166
FFN(Flocally)(object body)
 
167
{
 
168
        object *oldlex = lex_env;
 
169
 
 
170
        lex_copy();
 
171
        body = find_special(body, NULL, NULL);
 
172
        vs_push(body);
 
173
        Fprogn(body);
 
174
        lex_env = oldlex;
 
175
}
 
176
 
 
177
static void
 
178
FFN(Fthe)(object args)
 
179
{
 
180
 
 
181
        object *vs;
 
182
 
 
183
        if(endp(args) || endp(MMcdr(args)))
 
184
                FEtoo_few_argumentsF(args);
 
185
        if(!endp(MMcddr(args)))
 
186
                FEtoo_many_argumentsF(args);
 
187
        eval(MMcadr(args));
 
188
        args = MMcar(args);
 
189
        if (type_of(args) == t_cons && MMcar(args) == sLvalues) {
 
190
          vs = vs_base;
 
191
          for (args=MMcdr(args); !endp(args) && vs<vs_top; args=MMcdr(args), vs++)
 
192
            /*                  { if (vs >= vs_top)
 
193
                                FEerror("Too many return values.", 0);*/
 
194
            if (ifuncall2(sLtypep, *vs, MMcar(args)) == Cnil)
 
195
              FEwrong_type_argument(MMcar(args), *vs);
 
196
          /*}
 
197
                if (vs < vs_top)
 
198
                        FEerror("Too few return values.", 0);*/
 
199
          for (args=MMcdr(args); !endp(args); args=MMcdr(args))
 
200
            if (ifuncall2(sLtypep, Cnil, MMcar(args)) == Cnil)
 
201
              FEwrong_type_argument(MMcar(args), Cnil);
 
202
          
 
203
        } else {
 
204
                if (ifuncall2(sLtypep, vs_base[0], args) == Cnil)
 
205
                        FEwrong_type_argument(args, vs_base[0]);
 
206
        }
 
207
}
 
208
 
 
209
DEF_ORDINARY("COMPILE",sLcompile,LISP,"");
 
210
DEF_ORDINARY("COMPILE-TOPLEVEL",sKcompile_toplevel,KEYWORD,"");
 
211
DEF_ORDINARY("DECLARE",sLdeclare,LISP,"");
 
212
DEF_ORDINARY("EVAL",sLeval,LISP,"");
 
213
DEF_ORDINARY("EXECUTE",sKexecute,KEYWORD,"");
 
214
DEF_ORDINARY("FUNCTION-DOCUMENTATION",sSfunction_documentation,SI,"");
 
215
DEF_ORDINARY("LOAD",sLload,LISP,"");
 
216
DEF_ORDINARY("LOAD-TOPLEVEL",sLload_toplevel,KEYWORD,"");
 
217
DEF_ORDINARY("PROGN",sLprogn,LISP,"");
 
218
DEF_ORDINARY("TYPEP",sLtypep,LISP,"");
 
219
DEF_ORDINARY("VALUES",sLvalues,LISP,"");
 
220
DEF_ORDINARY("VARIABLE-DOCUMENTATION",sSvariable_documentation,SI,"");
 
221
DEF_ORDINARY("SETF-FUNCTION",sSsetf_function,SI,"");
 
222
DEF_ORDINARY("WARN",sLwarn,LISP,"");
 
223
 
 
224
void
 
225
gcl_init_toplevel(void)
 
226
{
 
227
        make_special_form("DEFUN",Fdefun);
 
228
        make_si_function("*MAKE-SPECIAL", siLAmake_special);
 
229
        make_si_function("*MAKE-CONSTANT", siLAmake_constant);
 
230
        make_special_form("EVAL-WHEN", Feval_when);
 
231
        make_special_form("THE", Fthe);
 
232
        sLdeclare=make_special_form("DECLARE",Fdeclare);
 
233
        make_special_form("LOCALLY",Flocally);
 
234
 
 
235
 
 
236
}