source: branches/streams/abcl/src/org/armedbear/lisp/Environment.java

Last change on this file was 13695, checked in by astalla, 13 years ago

Reimplementation of global symbol macros to avoid using the symbol's value slot.
Global symbol macros are stored on the symbols' property lists instead.
Tested with FSet which uses symbol macros quite heavily to implement and use
global lexical variables.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 10.7 KB
Line 
1/*
2 * Environment.java
3 *
4 * Copyright (C) 2002-2006 Peter Graves
5 * $Id: Environment.java 13695 2011-11-08 23:24:05Z astalla $
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, Binding binding) {
114        while (binding != null) {
115            if (binding.symbol == symbol)
116                return binding.value;
117            binding = binding.next;
118        }
119        return null;
120    }
121
122  public LispObject lookup(LispObject symbol)
123  {
124      return lookup(symbol, vars);
125  }
126
127  public Binding getBinding(LispObject symbol) {
128    return getBinding(symbol, vars);
129  }
130
131  public Binding getBinding(LispObject symbol, Binding binding) {
132    while (binding != null) {
133      if (binding.symbol == symbol)
134        return binding;
135      binding = binding.next;
136    }
137    return null;
138  }
139
140  // Function bindings.
141  public void addFunctionBinding(LispObject name, LispObject value)
142  {
143    lastFunctionBinding =
144      new FunctionBinding(name, value, lastFunctionBinding);
145  }
146
147  public LispObject lookupFunction(LispObject name)
148
149  {
150    FunctionBinding binding = lastFunctionBinding;
151    if (name instanceof Symbol)
152      {
153        while (binding != null)
154          {
155            if (binding.name == name)
156              return binding.value;
157            binding = binding.next;
158          }
159        // Not found in environment.
160        return name.getSymbolFunction();
161      }
162    if (name instanceof Cons)
163      {
164        while (binding != null)
165          {
166            if (binding.name.equal(name))
167              return binding.value;
168            binding = binding.next;
169          }
170      }
171    return null;
172  }
173
174  public void addBlock(LispObject symbol, LispObject block)
175  {
176    blocks = new Binding(symbol, this, block, blocks);
177  }
178
179  public LispObject lookupBlock(LispObject symbol)
180  {
181    Binding binding = blocks;
182    while (binding != null)
183      {
184        if (binding.symbol == symbol)
185          return binding.value;
186        binding = binding.next;
187      }
188    return null;
189  }
190
191  public Binding getBlockBinding(LispObject block)
192  {
193    Binding binding = blocks;
194    while (binding != null)
195      {
196        if (binding.symbol == block)
197          return binding;
198        binding = binding.next;
199      }
200    return null;
201  }
202
203  public void addTagBinding(LispObject tag, LispObject code)
204  {
205    tags = new Binding(tag, this, code, tags);
206  }
207
208  public Binding getTagBinding(LispObject tag)
209  {
210    Binding binding = tags;
211    while (binding != null)
212      {
213        if (binding.symbol.eql(tag))
214          return binding;
215        binding = binding.next;
216      }
217    return null;
218  }
219
220  // Returns body with declarations removed.
221  public LispObject processDeclarations(LispObject body)
222
223  {
224    LispObject bodyAndDecls = parseBody(body, false);
225    LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
226    for (; specials != NIL; specials = specials.cdr())
227      declareSpecial(checkSymbol(specials.car()));
228
229    return bodyAndDecls.car();
230  }
231
232  public void declareSpecial(Symbol var)
233  {
234    vars = new Binding(var, null, vars);
235    vars.specialp = true;
236  }
237
238    /** Return true if a symbol is declared special.
239     *
240     * If there is no binding in the current (lexical) environment,
241     * the current dynamic environment (thread) is checked.
242     */
243  public boolean isDeclaredSpecial(Symbol var)
244  {
245    Binding binding = getBinding(var);
246    return (binding != null) ? binding.specialp :
247        (LispThread.currentThread().getSpecialBinding(var) != null);
248  }
249
250  @Override
251  public String printObject()
252  {
253    return unreadableString("ENVIRONMENT");
254  }
255
256  // ### make-environment
257  public static final Primitive MAKE_ENVIRONMENT =
258    new Primitive("make-environment", PACKAGE_SYS, true,
259                  "&optional parent-environment")
260    {
261      @Override
262      public LispObject execute()
263      {
264        return new Environment();
265      }
266      @Override
267      public LispObject execute(LispObject arg)
268      {
269        if (arg == NIL)
270          return new Environment();
271        return new Environment(checkEnvironment(arg));
272      }
273    };
274
275  // ### environment-add-macro-definition
276  public static final Primitive ENVIRONMENT_ADD_MACRO_DEFINITION =
277    new Primitive("environment-add-macro-definition", PACKAGE_SYS, true,
278                  "environment name expander")
279    {
280      @Override
281      public LispObject execute(LispObject first, LispObject second,
282                                LispObject third)
283
284      {
285        Environment env = checkEnvironment(first);
286        LispObject name = second;
287        LispObject expander = third;
288        env.addFunctionBinding(name, expander);
289        return env;
290      }
291    };
292
293  // ### environment-add-function-definition
294  public static final Primitive ENVIRONMENT_ADD_FUNCTION_DEFINITION =
295    new Primitive("environment-add-function-definition", PACKAGE_SYS, true,
296                  "environment name lambda-expression")
297    {
298      @Override
299      public LispObject execute(LispObject first, LispObject second,
300                                LispObject third)
301
302      {
303        checkEnvironment(first).addFunctionBinding(second, third);
304        return first;
305      }
306    };
307
308  // ### environment-add-symbol-binding
309  public static final Primitive ENVIRONMENT_ADD_SYMBOL_BINDING =
310    new Primitive("environment-add-symbol-binding", PACKAGE_SYS, true,
311                  "environment symbol value")
312    {
313      @Override
314      public LispObject execute(LispObject first, LispObject second,
315                                LispObject third)
316
317      {
318        checkEnvironment(first).bind(checkSymbol(second), third);
319        return first;
320      }
321    };
322
323  // ### empty-environment-p
324  private static final Primitive EMPTY_ENVIRONMENT_P =
325    new Primitive("empty-environment-p", PACKAGE_SYS, true, "environment")
326    {
327      @Override
328      public LispObject execute(LispObject arg)
329      {
330          return checkEnvironment(arg).isEmpty() ? T : NIL;
331      }
332    };
333
334  // ### environment-variables
335  private static final Primitive ENVIRONMENT_VARS =
336    new Primitive("environment-variables", PACKAGE_SYS, true, "environment")
337    {
338      @Override
339      public LispObject execute(LispObject arg)
340      {
341            Environment env = checkEnvironment(arg);
342            LispObject result = NIL;
343            for (Binding binding = env.vars; binding != null; binding = binding.next)
344              if (!binding.specialp)
345                result = result.push(new Cons(binding.symbol, binding.value));
346            return result.nreverse();
347      }
348    };
349
350  // ### environment-all-variables
351  private static final Primitive ENVIRONMENT_ALL_VARS =
352    new Primitive("environment-all-variables", PACKAGE_SYS, true, "environment")
353    {
354      @Override
355      public LispObject execute(LispObject arg)
356      {
357            Environment env = checkEnvironment(arg);
358            LispObject result = NIL;
359            for (Binding binding = env.vars;
360                 binding != null; binding = binding.next)
361              if (binding.specialp)
362                result = result.push(binding.symbol);
363              else
364                result = result.push(new Cons(binding.symbol, binding.value));
365            return result.nreverse();
366      }
367    };
368
369  // ### environment-all-functions
370  private static final Primitive ENVIRONMENT_ALL_FUNS =
371    new Primitive("environment-all-functions", PACKAGE_SYS, true, "environment")
372    {
373      @Override
374      public LispObject execute(LispObject arg)
375      {
376            Environment env = checkEnvironment(arg);
377            LispObject result = NIL;
378            for (FunctionBinding binding = env.lastFunctionBinding;
379                 binding != null; binding = binding.next)
380            result = result.push(new Cons(binding.name, binding.value));
381            return result.nreverse();
382      }
383    };
384}
Note: See TracBrowser for help on using the repository browser.