001: /*
002: * Jatha - a Common LISP-compatible LISP library in Java.
003: * Copyright (C) 1997-2005 Micheal Scott Hewett
004: *
005: * This library is free software; you can redistribute it and/or
006: * modify it under the terms of the GNU Lesser General Public
007: * License as published by the Free Software Foundation; either
008: * version 2.1 of the License, or (at your option) any later version.
009: *
010: * This library is distributed in the hope that it will be useful,
011: * but WITHOUT ANY WARRANTY; without even the implied warranty of
012: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
013: * Lesser General Public License for more details.
014: *
015: * You should have received a copy of the GNU Lesser General Public
016: * License along with this library; if not, write to the Free Software
017: * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
018: *
019: *
020: * For further information, please contact Micheal Hewett at
021: * hewett@cs.stanford.edu
022: *
023: */
024: /**
025: * $Id: ReturnFromPrimitive.java,v 1.1 2005/06/01 13:08:02 olagus Exp $
026: */package org.jatha.compile;
027:
028: import org.jatha.Jatha;
029: import org.jatha.dynatype.*;
030: import org.jatha.machine.*;
031:
032: /**
033: * <p>The RETURN-FROM special form. Takes two parameters, the tag of the block to return from, and the value to return.</p>
034: * <p>(return-from name result)</p>
035: * <p>the tag name is not evaluated and must be a symbol or nil.</p>
036: * <p>the result is optional, and defaults to nil if not specified. it is evaluated.</p>
037: *
038: * @author <a href="mailto:Ola.Bini@itc.ki.se">Ola Bini</a>
039: * @version $Revision: 1.1 $
040: */
041: public class ReturnFromPrimitive extends LispPrimitive {
042: public ReturnFromPrimitive(final Jatha lisp) {
043: super (lisp, "RETURN-FROM", 1, 2);
044: }
045:
046: public void Execute(final SECDMachine machine)
047: throws CompilerException {
048: final LispValue tag = machine.S.pop();
049: final LispValue args = machine.S.pop();
050: final LispValue retVal = (args.basic_length() == 0) ? f_lisp.NIL
051: : args.car();
052: machine.S.push(retVal);
053: findBlock(tag, machine);
054: }
055:
056: private void findBlock(final LispValue tag,
057: final SECDMachine machine) throws CompilerException {
058: LispValue currVal = null;
059: while (true) {
060: currVal = machine.C.pop();
061: while (currVal != f_lisp.NIL && currVal != machine.RTN
062: && currVal != machine.RTN_IF
063: && currVal != machine.RTN_IT
064: && currVal != machine.JOIN
065: && currVal != machine.BLK) {
066: currVal = machine.C.pop();
067: }
068: if (currVal == machine.BLK) {
069: currVal = machine.C.pop();
070: if (tag == currVal) {
071: return; // We found the place!
072: }
073: } else if (currVal == machine.RTN
074: || currVal == machine.RTN_IF
075: || currVal == machine.RTN_IT
076: || currVal == machine.JOIN) {
077: ((SECDop) currVal).Execute(machine);
078: } else {
079: throw new IllegalArgumentException(
080: "RETURN-FROM called with in bad form, no matching block outside");
081: }
082: }
083: }
084:
085: public LispValue CompileArgs(final LispCompiler compiler,
086: final SECDMachine machine, final LispValue args,
087: final LispValue valueList, final LispValue code)
088: throws CompilerException {
089: final LispValue tag = args.car();
090: if (!compiler.getLegalBlocks().contains(tag)) {
091: throw new IllegalReturnStatement(
092: "No enclosing lexical block with tag " + tag);
093: }
094: final LispValue fullCode = args.cdr();
095: final LispValue compiledCode = compiler.compileArgsLeftToRight(
096: fullCode, valueList, f_lisp.makeCons(machine.LIS,
097: f_lisp.makeCons(fullCode.length(), f_lisp
098: .makeCons(machine.LDC, f_lisp.makeCons(
099: tag, code)))));
100: return compiledCode;
101: }
102:
103: public static class IllegalReturnStatement extends
104: CompilerException {
105: IllegalReturnStatement() {
106: super ();
107: }
108:
109: IllegalReturnStatement(final String s) {
110: super (s);
111: }
112: }
113: }// ReturnFromPrimitive
|