001: /*
002: * GenericFunction.java
003: *
004: * Copyright (C) 2003-2004 Peter Graves
005: * $Id: GenericFunction.java,v 1.10 2004/06/11 23:36:42 piso Exp $
006: *
007: * This program is free software; you can redistribute it and/or
008: * modify it under the terms of the GNU General Public License
009: * as published by the Free Software Foundation; either version 2
010: * of the License, or (at your option) any later version.
011: *
012: * This program is distributed in the hope that it will be useful,
013: * but WITHOUT ANY WARRANTY; without even the implied warranty of
014: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
015: * GNU General Public License for more details.
016: *
017: * You should have received a copy of the GNU General Public License
018: * along with this program; if not, write to the Free Software
019: * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
020: */
021:
022: package org.armedbear.lisp;
023:
024: public final class GenericFunction extends StandardObject {
025: private LispObject discriminatingFunction;
026:
027: public GenericFunction(LispClass cls, SimpleVector slots) {
028: super (cls, slots);
029: }
030:
031: public LispObject getDiscriminatingFunction() {
032: return discriminatingFunction;
033: }
034:
035: public void setDiscriminatingFunction(LispObject function) {
036: discriminatingFunction = function;
037: }
038:
039: public LispObject execute() throws ConditionThrowable {
040: LispObject[] args = new LispObject[0];
041: return execute(args);
042: }
043:
044: public LispObject execute(LispObject arg) throws ConditionThrowable {
045: LispObject[] args = new LispObject[1];
046: args[0] = arg;
047: return execute(args);
048: }
049:
050: public LispObject execute(LispObject first, LispObject second)
051: throws ConditionThrowable {
052: LispObject[] args = new LispObject[2];
053: args[0] = first;
054: args[1] = second;
055: return execute(args);
056: }
057:
058: public LispObject execute(LispObject first, LispObject second,
059: LispObject third) throws ConditionThrowable {
060: LispObject[] args = new LispObject[3];
061: args[0] = first;
062: args[1] = second;
063: args[2] = third;
064: return execute(args);
065: }
066:
067: public LispObject execute(LispObject first, LispObject second,
068: LispObject third, LispObject fourth)
069: throws ConditionThrowable {
070: LispObject[] args = new LispObject[4];
071: args[0] = first;
072: args[1] = second;
073: args[2] = third;
074: args[3] = fourth;
075: return execute(args);
076: }
077:
078: public LispObject execute(LispObject[] args)
079: throws ConditionThrowable {
080: return funcall(getDiscriminatingFunction(), args, LispThread
081: .currentThread());
082: }
083:
084: public String writeToString() throws ConditionThrowable {
085: LispObject slots = getSlots();
086: if (slots instanceof AbstractVector) {
087: AbstractVector v = (AbstractVector) slots;
088: if (v.length() > 0) {
089: LispObject name = v.getRowMajor(0);
090: if (name != null) {
091: StringBuffer sb = new StringBuffer("#<");
092: sb.append(getLispClass().getSymbol()
093: .writeToString());
094: sb.append(' ');
095: sb.append(name.writeToString());
096: sb.append('>');
097: return sb.toString();
098: }
099: }
100: }
101: return super .writeToString();
102: }
103:
104: // Profiling.
105: private int callCount;
106:
107: public final int getCallCount() {
108: return callCount;
109: }
110:
111: public void setCallCount(int n) {
112: callCount = n;
113: }
114:
115: public final void incrementCallCount() {
116: ++callCount;
117: }
118:
119: private static final Primitive1 GENERIC_FUNCTION_DISCRIMINATING_FUNCTION = new Primitive1(
120: "generic-function-discriminating-function", PACKAGE_SYS,
121: false) {
122: public LispObject execute(LispObject arg)
123: throws ConditionThrowable {
124: if (arg instanceof GenericFunction)
125: return ((GenericFunction) arg)
126: .getDiscriminatingFunction();
127: return signal(new TypeError(arg, "generic function"));
128: }
129: };
130:
131: private static final Primitive1 _SET_GENERIC_FUNCTION_DISCRIMINATING_FUNCTION = new Primitive1(
132: "%set-generic-function-discriminating-function",
133: PACKAGE_SYS, false) {
134: public LispObject execute(LispObject first, LispObject second)
135: throws ConditionThrowable {
136: if (first instanceof GenericFunction) {
137: ((GenericFunction) first)
138: .setDiscriminatingFunction(second);
139: return second;
140: }
141: return signal(new TypeError(first, "generic function"));
142: }
143: };
144: }
|