source: trunk/abcl/src/org/armedbear/lisp/Environment.java @ 12594

Last change on this file since 12594 was 12513, checked in by ehuelsmann, 15 years ago

Remove 'private' keyword to eliminate the Java requirement

for the compiler to generate synthetic accessors: functions that
don't appear in the source but do appear in the class file.

Patch by: Douglas Miles <dmiles _at_ users.sf.net>

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.5 KB
Line 
1/*
2 * Environment.java
3 *
4 * Copyright (C) 2002-2006 Peter Graves
5 * $Id: Environment.java 12513 2010-03-02 22:35:36Z ehuelsmann $
6 *
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
11 *
12 * This program is distributed in the hope that it will be useful,
13 * but 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 this program; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20 *
21 * As a special exception, the copyright holders of this library give you
22 * permission to link this library with independent modules to produce an
23 * executable, regardless of the license terms of these independent
24 * modules, and to copy and distribute the resulting executable under
25 * terms of your choice, provided that you also meet, for each linked
26 * independent module, the terms and conditions of the license of that
27 * module.  An independent module is a module which is not derived from
28 * or based on this library.  If you modify this library, you may extend
29 * this exception to your version of the library, but you are not
30 * obligated to do so.  If you do not wish to do so, delete this
31 * exception statement from your version.
32 */
33
34package org.armedbear.lisp;
35
36import static org.armedbear.lisp.Lisp.*;
37
38public final class Environment extends LispObject
39{
40  Binding vars;
41  FunctionBinding lastFunctionBinding;
42  private Binding blocks;
43  private Binding tags;
44  public boolean inactive; //default value: false == active
45
46  public Environment() {}
47
48  public Environment(Environment parent)
49  {
50    if (parent != null)
51      {
52        vars = parent.vars;
53        lastFunctionBinding = parent.lastFunctionBinding;
54        blocks = parent.blocks;
55        tags = parent.tags;
56      }
57  }
58
59  // Construct a new Environment extending parent with the specified symbol-
60  // value binding.
61  public Environment(Environment parent, Symbol symbol, LispObject value)
62  {
63    this(parent);
64    vars = new Binding(symbol, value, vars);
65  }
66
67  @Override
68  public LispObject typeOf()
69  {
70    return Symbol.ENVIRONMENT;
71  }
72
73  @Override
74  public LispObject classOf()
75  {
76    return BuiltInClass.ENVIRONMENT;
77  }
78
79  @Override
80  public LispObject typep(LispObject type)
81  {
82    if (type == Symbol.ENVIRONMENT)
83      return T;
84    if (type == BuiltInClass.ENVIRONMENT)
85      return T;
86    return super.typep(type);
87  }
88
89  public boolean isEmpty()
90  {
91    if (lastFunctionBinding != null)
92      return false;
93    if (vars != null)
94      {
95        for (Binding binding = vars; binding != null; binding = binding.next)
96          if (!binding.specialp)
97            return false;
98      }
99    return true;
100  }
101
102  public void bind(Symbol symbol, LispObject value)
103  {
104    vars = new Binding(symbol, value, vars);
105  }
106
107  public void rebind(Symbol symbol, LispObject value)
108  {
109    Binding binding = getBinding(symbol);
110    binding.value = value;
111  }
112
113  public LispObject lookup(LispObject symbol)
114  {
115    Binding binding = vars;
116    while (binding != null)
117      {
118        if (binding.symbol == symbol)
119          return binding.value;
120        binding = binding.next;
121      }
122    return null;
123  }
124
125  public Binding getBinding(LispObject symbol)
126  {
127    Binding binding = vars;
128    while (binding != null)
129      {
130        if (binding.symbol == symbol)
131          return binding;
132        binding = binding.next;
133      }
134    return null;
135  }
136
137  // Function bindings.
138  public void addFunctionBinding(LispObject name, LispObject value)
139  {
140    lastFunctionBinding =
141      new FunctionBinding(name, value, lastFunctionBinding);
142  }
143
144  public LispObject lookupFunction(LispObject name)
145
146  {
147    FunctionBinding binding = lastFunctionBinding;
148    if (name instanceof Symbol)
149      {
150        while (binding != null)
151          {
152            if (binding.name == name)
153              return binding.value;
154            binding = binding.next;
155          }
156        // Not found in environment.
157        return name.getSymbolFunction();
158      }
159    if (name instanceof Cons)
160      {
161        while (binding != null)
162          {
163            if (binding.name.equal(name))
164              return binding.value;
165            binding = binding.next;
166          }
167      }
168    return null;
169  }
170
171  public void addBlock(LispObject symbol, LispObject block)
172  {
173    blocks = new Binding(symbol, this, block, blocks);
174  }
175
176  public LispObject lookupBlock(LispObject symbol)
177  {
178    Binding binding = blocks;
179    while (binding != null)
180      {
181        if (binding.symbol == symbol)
182          return binding.value;
183        binding = binding.next;
184      }
185    return null;
186  }
187
188  public Binding getBlockBinding(LispObject block)
189  {
190    Binding binding = blocks;
191    while (binding != null)
192      {
193        if (binding.symbol == block)
194          return binding;
195        binding = binding.next;
196      }
197    return null;
198  }
199
200  public void addTagBinding(LispObject tag, LispObject code)
201  {
202    tags = new Binding(tag, this, code, tags);
203  }
204
205  public Binding getTagBinding(LispObject tag)
206  {
207    Binding binding = tags;
208    while (binding != null)
209      {
210        if (binding.symbol.eql(tag))
211          return binding;
212        binding = binding.next;
213      }
214    return null;
215  }
216
217  // Returns body with declarations removed.
218  public LispObject processDeclarations(LispObject body)
219
220  {
221    LispObject bodyAndDecls = parseBody(body, false);
222    LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
223    for (; specials != NIL; specials = specials.cdr())
224      declareSpecial(checkSymbol(specials.car()));
225
226    return bodyAndDecls.car();
227  }
228
229  public void declareSpecial(Symbol var)
230  {
231    vars = new Binding(var, null, vars);
232    vars.specialp = true;
233  }
234
235    /** Return true if a symbol is declared special.
236     *
237     * If there is no binding in the current (lexical) environment,
238     * the current dynamic environment (thread) is checked.
239     */
240  public boolean isDeclaredSpecial(Symbol var)
241  {
242    Binding binding = getBinding(var);
243    return (binding != null) ? binding.specialp :
244        (LispThread.currentThread().getSpecialBinding(var) != null);
245  }
246
247  @Override
248  public String writeToString()
249  {
250    return unreadableString(Symbol.ENVIRONMENT);
251  }
252
253  // ### make-environment
254  public static final Primitive MAKE_ENVIRONMENT =
255    new Primitive("make-environment", PACKAGE_SYS, true,
256                  "&optional parent-environment")
257    {
258      @Override
259      public LispObject execute()
260      {
261        return new Environment();
262      }
263      @Override
264      public LispObject execute(LispObject arg)
265      {
266        if (arg == NIL)
267          return new Environment();
268        return new Environment(checkEnvironment(arg));
269      }
270    };
271
272  // ### environment-add-macro-definition
273  public static final Primitive ENVIRONMENT_ADD_MACRO_DEFINITION =
274    new Primitive("environment-add-macro-definition", PACKAGE_SYS, true,
275                  "environment name expander")
276    {
277      @Override
278      public LispObject execute(LispObject first, LispObject second,
279                                LispObject third)
280
281      {
282        Environment env = checkEnvironment(first);
283        LispObject name = second;
284        LispObject expander = third;
285        env.addFunctionBinding(name, expander);
286        return env;
287      }
288    };
289
290  // ### environment-add-function-definition
291  public static final Primitive ENVIRONMENT_ADD_FUNCTION_DEFINITION =
292    new Primitive("environment-add-function-definition", PACKAGE_SYS, true,
293                  "environment name lambda-expression")
294    {
295      @Override
296      public LispObject execute(LispObject first, LispObject second,
297                                LispObject third)
298
299      {
300        checkEnvironment(first).addFunctionBinding(second, third);
301        return first;
302      }
303    };
304
305  // ### environment-add-symbol-binding
306  public static final Primitive ENVIRONMENT_ADD_SYMBOL_BINDING =
307    new Primitive("environment-add-symbol-binding", PACKAGE_SYS, true,
308                  "environment symbol value")
309    {
310      @Override
311      public LispObject execute(LispObject first, LispObject second,
312                                LispObject third)
313
314      {
315        checkEnvironment(first).bind(checkSymbol(second), third);
316        return first;
317      }
318    };
319
320  // ### empty-environment-p
321  private static final Primitive EMPTY_ENVIRONMENT_P =
322    new Primitive("empty-environment-p", PACKAGE_SYS, true, "environment")
323    {
324      @Override
325      public LispObject execute(LispObject arg)
326      {
327          return checkEnvironment(arg).isEmpty() ? T : NIL;
328      }
329    };
330
331  // ### environment-variables
332  private static final Primitive ENVIRONMENT_VARS =
333    new Primitive("environment-variables", PACKAGE_SYS, true, "environment")
334    {
335      @Override
336      public LispObject execute(LispObject arg)
337      {
338            Environment env = checkEnvironment(arg);
339            LispObject result = NIL;
340            for (Binding binding = env.vars; binding != null; binding = binding.next)
341              if (!binding.specialp)
342                result = result.push(new Cons(binding.symbol, binding.value));
343            return result.nreverse();
344      }
345    };
346
347  // ### environment-all-variables
348  private static final Primitive ENVIRONMENT_ALL_VARS =
349    new Primitive("environment-all-variables", PACKAGE_SYS, true, "environment")
350    {
351      @Override
352      public LispObject execute(LispObject arg)
353      {
354            Environment env = checkEnvironment(arg);
355            LispObject result = NIL;
356            for (Binding binding = env.vars;
357                 binding != null; binding = binding.next)
358              if (binding.specialp)
359                result = result.push(binding.symbol);
360              else
361                result = result.push(new Cons(binding.symbol, binding.value));
362            return result.nreverse();
363      }
364    };
365
366  // ### environment-all-functions
367  private static final Primitive ENVIRONMENT_ALL_FUNS =
368    new Primitive("environment-all-functions", PACKAGE_SYS, true, "environment")
369    {
370      @Override
371      public LispObject execute(LispObject arg)
372      {
373            Environment env = checkEnvironment(arg);
374            LispObject result = NIL;
375            for (FunctionBinding binding = env.lastFunctionBinding;
376                 binding != null; binding = binding.next)
377            result = result.push(new Cons(binding.name, binding.value));
378            return result.nreverse();
379      }
380    };
381}
Note: See TracBrowser for help on using the repository browser.