[armedbear-cvs] r13695 - trunk/abcl/src/org/armedbear/lisp
astalla at common-lisp.net
astalla at common-lisp.net
Tue Nov 8 23:24:06 UTC 2011
Author: astalla
Date: Tue Nov 8 15:24:05 2011
New Revision: 13695
Log:
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.
Modified:
trunk/abcl/src/org/armedbear/lisp/Autoload.java
trunk/abcl/src/org/armedbear/lisp/Binding.java
trunk/abcl/src/org/armedbear/lisp/Environment.java
trunk/abcl/src/org/armedbear/lisp/Lisp.java
trunk/abcl/src/org/armedbear/lisp/Primitives.java
trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java
trunk/abcl/src/org/armedbear/lisp/Symbol.java
trunk/abcl/src/org/armedbear/lisp/define-symbol-macro.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -578,6 +578,7 @@
autoload(PACKAGE_SYS, "%set-method-function", "StandardMethod", true);
autoload(PACKAGE_SYS, "%set-method-generic-function", "StandardMethod", true);
autoload(PACKAGE_SYS, "%set-method-specializers", "StandardMethod", true);
+ autoload(PACKAGE_SYS, "%set-symbol-macro", "Primitives");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-and", "SimpleBitVector");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc1", "SimpleBitVector");
autoload(PACKAGE_SYS, "%simple-bit-vector-bit-andc2", "SimpleBitVector");
@@ -661,7 +662,7 @@
autoload(PACKAGE_SYS, "make-single-float", "FloatFunctions", true);
autoload(PACKAGE_SYS, "make-slot-definition", "SlotDefinition", true);
autoload(PACKAGE_SYS, "make-structure-class", "StructureClass");
- autoload(PACKAGE_SYS, "make-symbol-macro", "SymbolMacro");
+ autoload(PACKAGE_SYS, "make-symbol-macro", "Primitives");
autoload(PACKAGE_SYS, "method-documentation", "StandardMethod", true);
autoload(PACKAGE_SYS, "method-lambda-list", "StandardMethod", true);
autoload(PACKAGE_SYS, "psxhash", "HashTableFunctions");
Modified: trunk/abcl/src/org/armedbear/lisp/Binding.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Binding.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/Binding.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -40,7 +40,7 @@
// Package accessibility.
final class Binding
{
- /** The symbol in case of a variable, block or
+ /** The symbol in case of a variable, block, symbol-macro or
* non-SETF function binding, the tag (symbol or
* integer) in case of a tag binding or the cons
* in case of a SETF function binding
@@ -65,6 +65,9 @@
*
* In case of a variable binding, it holds the value associated with the
* variable, unless specialp is true.
+ *
+ * In case of a symbol macro binding, holds the SymbolMacro instance
+ * holding the macro's expansion.
*/
LispObject value;
Modified: trunk/abcl/src/org/armedbear/lisp/Environment.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Environment.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/Environment.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -110,27 +110,30 @@
binding.value = value;
}
+ public LispObject lookup(LispObject symbol, Binding binding) {
+ while (binding != null) {
+ if (binding.symbol == symbol)
+ return binding.value;
+ binding = binding.next;
+ }
+ return null;
+ }
+
public LispObject lookup(LispObject symbol)
{
- Binding binding = vars;
- while (binding != null)
- {
- if (binding.symbol == symbol)
- return binding.value;
- binding = binding.next;
- }
- return null;
+ return lookup(symbol, vars);
}
- public Binding getBinding(LispObject symbol)
- {
- Binding binding = vars;
- while (binding != null)
- {
- if (binding.symbol == symbol)
- return binding;
- binding = binding.next;
- }
+ public Binding getBinding(LispObject symbol) {
+ return getBinding(symbol, vars);
+ }
+
+ public Binding getBinding(LispObject symbol, Binding binding) {
+ while (binding != null) {
+ if (binding.symbol == symbol)
+ return binding;
+ binding = binding.next;
+ }
return null;
}
Modified: trunk/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/Lisp.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -248,15 +248,13 @@
else if (form instanceof Symbol)
{
Symbol symbol = (Symbol) form;
- LispObject obj = null;
- if (symbol.isSpecialVariable())
- obj = thread.lookupSpecial(symbol);
- else
- obj = env.lookup(symbol);
- if (obj == null)
- obj = symbol.getSymbolValue();
- if (obj instanceof SymbolMacro)
+ LispObject obj = env.lookup(symbol);
+ if (obj == null) {
+ obj = symbol.getSymbolMacro();
+ }
+ if (obj instanceof SymbolMacro) {
return thread.setValues(((SymbolMacro)obj).getExpansion(), T);
+ }
}
// Not a macro.
return thread.setValues(form, NIL);
@@ -473,9 +471,13 @@
result = env.lookup(symbol);
if (result == null)
{
- result = symbol.getSymbolValue();
- if (result == null)
+ result = symbol.getSymbolMacro();
+ if (result == null) {
+ result = symbol.getSymbolValue();
+ }
+ if(result == null) {
return error(new UnboundVariable(obj));
+ }
}
if (result instanceof SymbolMacro)
return eval(((SymbolMacro)result).getExpansion(), env, thread);
@@ -1633,9 +1635,9 @@
public static final Stream checkStream(LispObject obj)
{
- if (obj instanceof Stream)
- return (Stream) obj;
- return (Stream) // Not reached.
+ if (obj instanceof Stream)
+ return (Stream) obj;
+ return (Stream) // Not reached.
type_error(obj, Symbol.STREAM);
}
@@ -2622,7 +2624,7 @@
static
{
// ### multiple-values-limit
- Symbol.MULTIPLE_VALUES_LIMIT.initializeConstant(Fixnum.constants[20]);
+ Symbol.MULTIPLE_VALUES_LIMIT.initializeConstant(Fixnum.constants[32]);
}
static
Modified: trunk/abcl/src/org/armedbear/lisp/Primitives.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/Primitives.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -676,9 +676,6 @@
public LispObject execute(LispObject arg) {
final LispObject value;
value = checkSymbol(arg).symbolValue();
- if (value instanceof SymbolMacro)
- return error(new LispError(arg.princToString() +
- " has no dynamic value."));
return value;
}
};
@@ -1951,6 +1948,20 @@
}
};
+ // ### %set-symbol-macro
+ private static final Primitive SET_SYMBOL_MACRO = new pf_set_symbol_macro();
+ private static final class pf_set_symbol_macro extends Primitive {
+ pf_set_symbol_macro() {
+ super("%set-symbol-macro", PACKAGE_SYS, false, "symbol symbol-macro");
+ }
+
+ @Override
+ public LispObject execute(LispObject sym, LispObject symbolMacro) {
+ checkSymbol(sym).setSymbolMacro((SymbolMacro) symbolMacro);
+ return symbolMacro;
+ }
+ };
+
// ### symbol-macro-p
private static final Primitive SYMBOL_MACRO_P = new pf_symbol_macro_p();
private static final class pf_symbol_macro_p extends Primitive {
Modified: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -204,7 +204,7 @@
symbol.princToString() +
" with SYMBOL-MACROLET."));
}
- bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread);
+ ext.bind(symbol, new SymbolMacro(obj.cadr()));
} else {
return error(new ProgramError(
"Malformed symbol-expansion pair in SYMBOL-MACROLET: " +
@@ -525,26 +525,11 @@
args = args.cdr();
if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) {
SpecialBinding binding = thread.getSpecialBinding(symbol);
+ value = eval(args.car(), env, thread);
if (binding != null) {
- if (binding.value instanceof SymbolMacro) {
- LispObject expansion =
- ((SymbolMacro)binding.value).getExpansion();
- LispObject form = list(Symbol.SETF, expansion, args.car());
- value = eval(form, env, thread);
- } else {
- value = eval(args.car(), env, thread);
- binding.value = value;
- }
+ binding.value = value;
} else {
- if (symbol.getSymbolValue() instanceof SymbolMacro) {
- LispObject expansion =
- ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
- LispObject form = list(Symbol.SETF, expansion, args.car());
- value = eval(form, env, thread);
- } else {
- value = eval(args.car(), env, thread);
- symbol.setSymbolValue(value);
- }
+ symbol.setSymbolValue(value);
}
} else {
// Not special.
@@ -560,9 +545,9 @@
binding.value = value;
}
} else {
- if (symbol.getSymbolValue() instanceof SymbolMacro) {
+ if (symbol.getSymbolMacro() != null) {
LispObject expansion =
- ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
+ symbol.getSymbolMacro().getExpansion();
LispObject form = list(Symbol.SETF, expansion, args.car());
value = eval(form, env, thread);
} else {
Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java Tue Nov 8 15:24:05 2011 (r13695)
@@ -299,6 +299,23 @@
this.value = value;
}
+ public SymbolMacro getSymbolMacro() {
+ LispObject symbolMacro = get(this, SYMBOL_MACRO, null);
+ if(symbolMacro instanceof SymbolMacro) {
+ return (SymbolMacro) symbolMacro;
+ } else if(symbolMacro != null) {
+ error(new TypeError("The object " + symbolMacro + " is not a symbol macro"));
+ }
+ return null;
+ }
+
+ public void setSymbolMacro(SymbolMacro symbolMacro) {
+ if(isSpecialVariable()) {
+ error(new ProgramError("Symbol " + princToString() + " names a special variable; can't install symbol macro."));
+ }
+ put(this, SYMBOL_MACRO, symbolMacro);
+ }
+
/** Returns the value associated with this symbol in the current
* thread context when it is treated as a special variable.
*
@@ -3036,6 +3053,8 @@
PACKAGE_SYS.addExternalSymbol("STD-SLOT-VALUE");
public static final Symbol SET_STD_SLOT_VALUE =
PACKAGE_SYS.addExternalSymbol("SET-STD-SLOT-VALUE");
+ public static final Symbol SYMBOL_MACRO =
+ PACKAGE_SYS.addExternalSymbol("SYMBOL-MACRO");
public static final Symbol SUBCLASSP =
PACKAGE_SYS.addExternalSymbol("SUBCLASSP");
public static final Symbol GETHASH1 =
Modified: trunk/abcl/src/org/armedbear/lisp/define-symbol-macro.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/define-symbol-macro.lisp Tue Nov 8 05:21:38 2011 (r13694)
+++ trunk/abcl/src/org/armedbear/lisp/define-symbol-macro.lisp Tue Nov 8 15:24:05 2011 (r13695)
@@ -32,11 +32,11 @@
(in-package "SYSTEM")
(defun %define-symbol-macro (symbol expansion)
- (setf (symbol-value symbol) (make-symbol-macro expansion))
+ (%set-symbol-macro symbol (make-symbol-macro expansion))
symbol)
(defmacro define-symbol-macro (symbol expansion)
- (when (special-variable-p symbol)
+ (when (special-variable-p symbol) ;;TODO astalla also check local declarations?
(error 'program-error "~S has already been defined as a global variable." symbol))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%define-symbol-macro ',symbol ',expansion)))
More information about the armedbear-cvs
mailing list