001: package kawa.lang;
002:
003: import java.util.*;
004: import gnu.mapping.*;
005: import gnu.expr.*;
006: import gnu.lists.*;
007: import gnu.kawa.reflect.Invoke;
008: import gnu.bytecode.ClassType;
009: import gnu.kawa.lispexpr.LispLanguage;
010: import gnu.kawa.functions.GetNamedPart;
011:
012: /**
013: * The Syntax transformer that re-writes the "quote" "quasiquote" primitive.
014: * In both cases recursively resolves SyntaxForm wrappers and resolves
015: * namespaces of symbols. In the case of quasiquote also handles unquoting.
016: * @author Per Bothner
017: */
018:
019: public class Quote extends Syntax {
020: public static final Quote plainQuote = new Quote("quote", false);
021: public static final Quote quasiQuote = new Quote("quasiquote", true);
022:
023: public Quote(String name, boolean isQuasi) {
024: super (name);
025: this .isQuasi = isQuasi;
026: }
027:
028: /** An initial value for 'depth' for plain (non-quasi) quote. */
029: protected static final int QUOTE_DEPTH = -1;
030:
031: /** True for quasiquote; false for plain quote. */
032: protected boolean isQuasi;
033:
034: protected Object expand(Object template, int depth, Translator tr) {
035: /* #ifdef use:java.util.IdentityHashMap */
036: IdentityHashMap seen = new IdentityHashMap();
037: /* #else */
038: // Object seen = null;
039: /* #endif */
040: return expand(template, depth, null, seen, tr);
041: }
042:
043: /** Quote an object (without namespace-expansion).
044: * Basically just recursively removes SyntaxForm wrappers. */
045: public static Object quote(Object obj, Translator tr) {
046: return plainQuote.expand(obj, QUOTE_DEPTH, tr);
047: }
048:
049: /** Quote an object (without namespace-expansion).
050: * Basically just recursively removes SyntaxForm wrappers. */
051: public static Object quote(Object obj) {
052: return plainQuote.expand(obj, QUOTE_DEPTH,
053: (Translator) Compilation.getCurrent());
054: }
055:
056: protected Expression coerceExpression(Object val, Translator tr) {
057: return val instanceof Expression ? (Expression) val : leaf(val,
058: tr);
059: }
060:
061: protected Expression leaf(Object val, Translator tr) {
062: return new QuoteExp(val);
063: }
064:
065: protected boolean expandColonForms() {
066: return true;
067: }
068:
069: Object expand_pair(Pair list, int depth, SyntaxForm syntax,
070: Object seen, Translator tr) {
071: Pair pair = list;
072: Object cdr;
073: Object rest;
074: for (;;) {
075: // This would be simpler as plain recursion, but we try to iterate
076: // over the given list, partly for speed, but more importantly
077: // to avoid stack overflow in the case of long lists.
078: rest = pair;
079: Pair p1, p2;
080: // We're currently examining pair, which is the n'th cdr of list.
081: // All previous elements (cars) are returned identically by expand.
082: // What makes things complicated is that to the extent that no changes
083: // are needed, we want to return the input list as-is.
084: if (expandColonForms()
085: && tr.matches(pair.car, syntax,
086: LispLanguage.lookup_sym)
087: && pair.cdr instanceof Pair
088: && (p1 = (Pair) pair.cdr) instanceof Pair
089: && (p2 = (Pair) p1.cdr) instanceof Pair
090: && p2.cdr == LList.Empty) {
091: Expression part1 = tr.rewrite_car(p1, false);
092: Expression part2 = tr.rewrite_car(p2, false);
093: Symbol sym = tr.namespaceResolve(part1, part2);
094: String combinedName;
095: if (sym != null)
096: ;
097: else if (part1 instanceof ReferenceExp
098: && part2 instanceof QuoteExp)
099: sym = tr.getGlobalEnvironment().getSymbol(
100: ((ReferenceExp) part1).getName()
101: + ':'
102: + ((QuoteExp) part2).getValue()
103: .toString());
104: else if ((combinedName = GetNamedPart.combineName(
105: part1, part2)) != null)
106: sym = tr.getGlobalEnvironment().getSymbol(
107: combinedName);
108: else {
109: Object save = tr.pushPositionOf(pair);
110: tr.error('e', "'" + p1.car
111: + "' is not a valid prefix");
112: tr.popPositionOf(save);
113: }
114: cdr = sym;
115: break;
116: } else if (depth < 0) {
117: } else if (tr.matches(pair.car, syntax,
118: LispLanguage.quasiquote_sym))
119: depth++;
120: else if (tr.matches(pair.car, syntax,
121: LispLanguage.unquote_sym)) {
122: depth--;
123: Pair pair_cdr;
124: if (!(pair.cdr instanceof Pair)
125: || (pair_cdr = (Pair) pair.cdr).cdr != LList.Empty)
126: return tr.syntaxError("invalid used of " + pair.car
127: + " in quasiquote template");
128: if (depth == 0) {
129: cdr = tr.rewrite_car(pair_cdr, syntax);
130: break;
131: }
132: } else if (tr.matches(pair.car, syntax,
133: LispLanguage.unquotesplicing_sym))
134: return tr.syntaxError("invalid used of " + pair.car
135: + " in quasiquote template");
136: if (depth == 1 && pair.car instanceof Pair) {
137: Object form = pair.car;
138: SyntaxForm subsyntax = syntax;
139: while (form instanceof SyntaxForm) {
140: subsyntax = (SyntaxForm) form;
141: form = subsyntax.form;
142: }
143: int splicing = -1;
144: if (form instanceof Pair) {
145: Object op = ((Pair) form).car;
146: if (tr.matches(op, subsyntax,
147: LispLanguage.unquote_sym))
148: splicing = 0;
149: else if (tr.matches(op, subsyntax,
150: LispLanguage.unquotesplicing_sym))
151: splicing = 1;
152: }
153: if (splicing >= 0) {
154: form = ((Pair) form).cdr; // skip "unquote[splicing]".
155: Vector vec = new Vector();
156: cdr = null;
157: // R5RS allows only a single argument. But
158: // see Bawden: Quasiquotation in Lisp (1999), Appendix B.
159: for (;;) {
160: if (form instanceof SyntaxForm) {
161: subsyntax = (SyntaxForm) form;
162: form = subsyntax.form;
163: }
164: if (form == LList.Empty)
165: break;
166: if (form instanceof Pair) {
167: vec.addElement(tr.rewrite_car((Pair) form,
168: subsyntax));
169: form = ((Pair) form).cdr;
170: } else
171: return tr
172: .syntaxError("improper list argument to unquote");
173: }
174: int nargs = vec.size() + 1;
175: cdr = expand(pair.cdr, 1, syntax, seen, tr);
176: if (nargs > 1) {
177: Expression[] args = new Expression[nargs];
178: vec.copyInto(args);
179: args[nargs - 1] = coerceExpression(cdr, tr);
180: String method = splicing == 0 ? "consX"
181: : "append";
182: cdr = Invoke.makeInvokeStatic(quoteType,
183: method, args);
184: }
185: rest = pair;
186: break;
187: }
188: }
189: Object car = expand(pair.car, depth, syntax, seen, tr);
190: if (car == pair.car) {
191: rest = pair.cdr;
192: if (rest instanceof Pair) {
193: pair = (Pair) rest;
194: continue;
195: }
196: cdr = expand(rest, depth, syntax, seen, tr);
197: break;
198: }
199: cdr = expand(pair.cdr, depth, syntax, seen, tr);
200: if (car instanceof Expression || cdr instanceof Expression) {
201: Expression[] args = new Expression[2];
202: args[0] = coerceExpression(car, tr);
203: args[1] = coerceExpression(cdr, tr);
204: cdr = Invoke.makeInvokeStatic(Compilation.typePair,
205: "make", args);
206: } else
207: cdr = Translator.makePair(pair, car, cdr);
208: break;
209: }
210: // rest is the n'th cdr of list. cdr is the expansion of rest.
211: // The first n cars of list are returned identically by expand.
212: // These do need to be copied because cdr!=rest.
213: if (list == rest)
214: return cdr;
215: Pair p = list;
216: Pair prev = null;
217: for (;;) {
218: Pair q = Translator.makePair(p, p.car, null);
219: if (prev == null)
220: list = q;
221: else
222: prev.cdr = q;
223: prev = q;
224: if (p.cdr == rest)
225: break;
226: p = (Pair) p.cdr;
227: }
228: if (cdr instanceof Expression) {
229: Expression[] args = new Expression[2];
230: args[1] = (Expression) cdr;
231: if (prev == list) {
232: // The n==1 case: Only a single pair before rest.
233: args[0] = leaf(list.car, tr);
234: return Invoke.makeInvokeStatic(Compilation.typePair,
235: "make", args);
236: } else {
237: prev.cdr = LList.Empty;
238: args[0] = leaf(list, tr);
239: return Invoke.makeInvokeStatic(quoteType, "append",
240: args);
241: }
242: } else {
243: prev.cdr = cdr;
244: }
245: return list;
246: }
247:
248: private static final Object WORKING = new String("(working)");
249: private static final Object CYCLE = new String("(cycle)");
250:
251: /** Backquote-expand a template.
252: * @param template the quasiquoted template to expand
253: * @param depth - the (net) number of quasiquotes we are inside.
254: * The value QUOTE_DEPTH is a special case when we're inside
255: * a quote rather than a quasiquote.
256: * @param tr the rewrite context
257: * @return the expanded Expression (the result can be a non-expression,
258: * in which case it is implicitly a QuoteExp).
259: */
260: Object expand(Object template, int depth, SyntaxForm syntax,
261: Object seen, Translator tr) {
262: /* #ifdef use:java.util.IdentityHashMap */
263: IdentityHashMap map = (IdentityHashMap) seen;
264: Object old = map.get(template);
265: if (old == WORKING) {
266: map.put(template, CYCLE);
267: return old;
268: } else if (old == CYCLE) {
269: return old;
270: } else if (old != null)
271: return old;
272: /* #endif */
273: Object result;
274: if (template instanceof Pair)
275: result = expand_pair((Pair) template, depth, syntax, seen,
276: tr);
277: else if (template instanceof SyntaxForm) {
278: syntax = (SyntaxForm) template;
279: result = expand(syntax.form, depth, syntax, seen, tr);
280: } else if (template instanceof FVector) {
281: FVector vector = (FVector) template;
282: int n = vector.size();
283: Object[] buffer = new Object[n];
284: // For each element, the state is one of these four:
285: // 0: the expanded element is the same as the original
286: // 1: the expanded element is a constant
287: // 2: the expanded element is neither constant nor a slice
288: // 3: the element is sliced in
289: byte[] state = new byte[n];
290: byte max_state = 0;
291: for (int i = 0; i < n; i++) {
292: Object element = vector.get(i);
293: int element_depth = depth;
294: Pair pair;
295: if (element instanceof Pair
296: && depth > QUOTE_DEPTH
297: && tr.matches((pair = (Pair) element).car,
298: syntax,
299: LispLanguage.unquotesplicing_sym)
300: && --element_depth == 0) {
301: Pair pair_cdr;
302: if (!(pair.cdr instanceof Pair)
303: || (pair_cdr = (Pair) pair.cdr).cdr != LList.Empty)
304: return tr.syntaxError("invalid used of "
305: + pair.car + " in quasiquote template");
306: buffer[i] = tr.rewrite_car(pair_cdr, syntax);
307: state[i] = 3;
308: } else {
309: buffer[i] = expand(element, element_depth, syntax,
310: seen, tr);
311: if (buffer[i] == element)
312: state[i] = 0;
313: else if (buffer[i] instanceof Expression)
314: state[i] = 2;
315: else
316: state[i] = 1;
317: }
318: if (state[i] > max_state)
319: max_state = state[i];
320: }
321: if (max_state == 0)
322: result = vector;
323: else if (max_state == 1)
324: result = new FVector(buffer);
325: else {
326: Expression[] args = new Expression[n];
327: for (int i = 0; i < n; i++) {
328: if (state[i] == 3)
329: args[i] = (Expression) buffer[i];
330: else if (max_state < 3)
331: args[i] = coerceExpression(buffer[i], tr);
332: else if (state[i] < 2) {
333: Object[] arg1 = new Object[1];
334: arg1[0] = buffer[i];
335: args[i] = leaf(new FVector(arg1), tr);
336: } else {
337: Expression[] arg1 = new Expression[1];
338: arg1[0] = (Expression) buffer[i];
339: args[i] = Invoke.makeInvokeStatic(vectorType,
340: "vector", arg1);
341: }
342: }
343: if (max_state < 3)
344: result = Invoke.makeInvokeStatic(vectorType,
345: "vector", args);
346: else
347: result = Invoke.makeInvokeStatic(vectorAppendType,
348: "apply", args);
349: }
350: } else
351: result = template;
352: /* #ifdef use:java.util.IdentityHashMap */
353: if (template != result && map.get(template) == CYCLE)
354: tr.error('e', "cycle in non-literal data");
355: map.put(template, result);
356: /* #endif */
357: return result;
358: }
359:
360: public Expression rewrite(Object obj, Translator tr) {
361: Pair pair;
362: if (!(obj instanceof Pair)
363: || (pair = (Pair) obj).cdr != LList.Empty)
364: return tr.syntaxError("wrong number of arguments to quote");
365: return coerceExpression(expand(pair.car, isQuasi ? 1
366: : QUOTE_DEPTH, tr), tr);
367: }
368:
369: /** A wrapper around LList.consX to make it a "variable-arg method". */
370: public static Object consX$V(Object[] args) {
371: return LList.consX(args);
372: }
373:
374: /** Same as regular append, but handle SyntaxForm wrappers. */
375: public static Object append$V(Object[] args) {
376: int count = args.length;
377: if (count == 0)
378: return LList.Empty;
379: Object result = args[count - 1];
380: for (int i = count - 1; --i >= 0;) {
381: Object list = args[i];
382: Object copy = null;
383: Pair last = null;
384: SyntaxForm syntax = null;
385: for (;;) {
386: while (list instanceof SyntaxForm) {
387: syntax = (SyntaxForm) list;
388: list = syntax.form;
389: }
390: if (list == LList.Empty)
391: break;
392: Pair list_pair = (Pair) list;
393: Object car = list_pair.car;
394: if (syntax != null && !(car instanceof SyntaxForm))
395: car = SyntaxForm.make(car, syntax.scope);
396: Pair new_pair = new Pair(car, null);
397: if (last == null)
398: copy = new_pair;
399: else
400: last.cdr = new_pair;
401: last = new_pair;
402: list = list_pair.cdr;
403: }
404: if (last != null) {
405: last.cdr = result;
406: result = copy;
407: }
408: }
409: return result;
410: }
411:
412: static final ClassType vectorType = ClassType
413: .make("kawa.lib.vectors");
414: static final ClassType vectorAppendType = ClassType
415: .make("kawa.standard.vector_append");
416: static final ClassType quoteType = ClassType
417: .make("kawa.lang.Quote");
418: }
|