Changeset 9228


Ignore:
Timestamp:
05/22/05 17:28:28 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

Location:
trunk/j/src/org/armedbear/lisp
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/Autoload.java

    r9227 r9228  
    33 *
    44 * Copyright (C) 2003-2005 Peter Graves
    5  * $Id: Autoload.java,v 1.230 2005-05-22 13:22:19 piso Exp $
     5 * $Id: Autoload.java,v 1.231 2005-05-22 17:28:28 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    462462        autoload(PACKAGE_JAVA, "%jregister-handler", "JHandler");
    463463        autoload(PACKAGE_JAVA, "%load-java-class-from-byte-array", "RuntimeClass");
     464        autoload(PACKAGE_MOP, "funcallable-instance-function", "StandardGenericFunction", false);
    464465        autoload(PACKAGE_MOP, "generic-function-name", "StandardGenericFunction", true);
    465466        autoload(PACKAGE_MOP, "method-qualifiers", "StandardMethod", true);
    466467        autoload(PACKAGE_MOP, "method-specializers", "StandardMethod", true);
     468        autoload(PACKAGE_MOP, "set-funcallable-instance-function", "StandardGenericFunction", true);
    467469        autoload(PACKAGE_PROF, "%start-profiler", "Profiler", true);
    468470        autoload(PACKAGE_PROF, "stop-profiler", "Profiler", true);
     
    551553        autoload(PACKAGE_SYS, "generic-function-argument-precedence-order","StandardGenericFunction", true);
    552554        autoload(PACKAGE_SYS, "generic-function-classes-to-emf-table","StandardGenericFunction", true);
    553         autoload(PACKAGE_SYS, "generic-function-discriminating-function", "StandardGenericFunction", true);
    554555        autoload(PACKAGE_SYS, "generic-function-documentation","StandardGenericFunction", true);
    555556        autoload(PACKAGE_SYS, "generic-function-initial-methods","StandardGenericFunction", true);
  • trunk/j/src/org/armedbear/lisp/StandardGenericFunction.java

    r9227 r9228  
    33 *
    44 * Copyright (C) 2003-2005 Peter Graves
    5  * $Id: StandardGenericFunction.java,v 1.2 2005-05-22 13:22:00 piso Exp $
     5 * $Id: StandardGenericFunction.java,v 1.3 2005-05-22 17:27:53 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    2424public final class StandardGenericFunction extends StandardObject
    2525{
     26    private LispObject function;
     27
    2628    public StandardGenericFunction()
    2729    {
     
    4244                symbol = pkg.intern(name.toUpperCase());
    4345            symbol.setSymbolFunction(this);
     46            this.function = function;
    4447            slots[StandardGenericFunctionClass.SLOT_INDEX_NAME] = symbol;
    4548            slots[StandardGenericFunctionClass.SLOT_INDEX_LAMBDA_LIST] =
    4649                lambdaList;
    47             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION] =
    48                 function;
    4950            slots[StandardGenericFunctionClass.SLOT_INDEX_REQUIRED_ARGS] =
    5051                lambdaList;
     
    5354            StandardMethod method =
    5455                new StandardMethod(this, function, lambdaList, specializers);
    55             slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] = list1(method);
     56            slots[StandardGenericFunctionClass.SLOT_INDEX_METHODS] =
     57                list1(method);
    5658            slots[StandardGenericFunctionClass.SLOT_INDEX_METHOD_CLASS] =
    5759                BuiltInClass.STANDARD_METHOD;
     
    7274    {
    7375        if (type == Symbol.COMPILED_FUNCTION) {
    74             LispObject discriminatingFunction =
    75                 slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    76             if (discriminatingFunction != null)
    77                 return discriminatingFunction.typep(type);
     76            if (function != null)
     77                return function.typep(type);
    7878            else
    7979                return NIL;
     
    9292    }
    9393
    94     public void setDiscriminatingFunction(LispObject function)
    95     {
    96         slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION] = function;
    97     }
    98 
    9994    public LispObject execute() throws ConditionThrowable
    10095    {
    101         LispObject discriminatingFunction =
    102             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    103         return discriminatingFunction.execute();
     96        return function.execute();
    10497    }
    10598
    10699    public LispObject execute(LispObject arg) throws ConditionThrowable
    107100    {
    108         LispObject discriminatingFunction =
    109             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    110         return discriminatingFunction.execute(arg);
     101        return function.execute(arg);
    111102    }
    112103
     
    114105        throws ConditionThrowable
    115106    {
    116         LispObject discriminatingFunction =
    117             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    118         return discriminatingFunction.execute(first, second);
     107        return function.execute(first, second);
    119108    }
    120109
     
    123112        throws ConditionThrowable
    124113    {
    125         LispObject discriminatingFunction =
    126             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    127         return discriminatingFunction.execute(first, second, third);
     114        return function.execute(first, second, third);
    128115    }
    129116
     
    132119        throws ConditionThrowable
    133120    {
    134         LispObject discriminatingFunction =
    135             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    136         return discriminatingFunction.execute(first, second, third, fourth);
     121        return function.execute(first, second, third, fourth);
    137122    }
    138123
     
    142127        throws ConditionThrowable
    143128    {
    144         LispObject discriminatingFunction =
    145             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    146         return discriminatingFunction.execute(first, second, third, fourth,
     129        return function.execute(first, second, third, fourth,
    147130                                              fifth);
    148131    }
     
    153136        throws ConditionThrowable
    154137    {
    155         LispObject discriminatingFunction =
    156             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    157         return discriminatingFunction.execute(first, second, third, fourth,
     138        return function.execute(first, second, third, fourth,
    158139                                              fifth, sixth);
    159140    }
     
    161142    public LispObject execute(LispObject[] args) throws ConditionThrowable
    162143    {
    163         LispObject discriminatingFunction =
    164             slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    165         return discriminatingFunction.execute(args);
     144        return function.execute(args);
    166145    }
    167146
     
    207186
    208187    // ### %generic-function-name
    209     public static final Primitive _GENERIC_FUNCTION_NAME =
     188    private static final Primitive _GENERIC_FUNCTION_NAME =
    210189        new Primitive("%generic-function-name", PACKAGE_SYS, true)
    211190    {
     
    216195            }
    217196            catch (ClassCastException e) {
    218                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     197                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    219198            }
    220199        }
     
    233212            }
    234213            catch (ClassCastException e) {
    235                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     214                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    236215            }
    237216        }
     
    248227            }
    249228            catch (ClassCastException e) {
    250                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     229                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    251230            }
    252231        }
     
    265244            }
    266245            catch (ClassCastException e) {
    267                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
    268             }
    269         }
    270     };
    271 
    272     // ### generic-function-discriminating-function
    273     private static final Primitive GENERIC_FUNCTION_DISCRIMINATING_FUNCTION =
    274         new Primitive("generic-function-discriminating-function", PACKAGE_SYS, true)
    275     {
    276         public LispObject execute(LispObject arg) throws ConditionThrowable
    277         {
    278             try {
    279                 return ((StandardGenericFunction)arg).slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION];
    280             }
    281             catch (ClassCastException e) {
    282                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
    283             }
    284         }
    285     };
    286 
    287     // ### %set-generic-function-discriminating-function
    288     private static final Primitive _SET_GENERIC_FUNCTION_DISCRIMINATING_FUNCTION =
    289         new Primitive("%set-generic-function-discriminating-function", PACKAGE_SYS, true)
    290     {
    291         public LispObject execute(LispObject first, LispObject second)
    292             throws ConditionThrowable
    293         {
    294             try {
    295                 ((StandardGenericFunction)first).slots[StandardGenericFunctionClass.SLOT_INDEX_DISCRIMINATING_FUNCTION] = second;
    296                 return second;
    297             }
    298             catch (ClassCastException e) {
    299                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     246                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
     247            }
     248        }
     249    };
     250
     251    // ### funcallable-instance-function funcallable-instance => function
     252    private static final Primitive FUNCALLABLE_INSTANCE_FUNCTION =
     253        new Primitive("funcallable-instance-function", PACKAGE_MOP, false,
     254                      "funcallable-instance")
     255    {
     256        public LispObject execute(LispObject arg)
     257            throws ConditionThrowable
     258        {
     259            try {
     260                return ((StandardGenericFunction)arg).function;
     261            }
     262            catch (ClassCastException e) {
     263                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
     264            }
     265        }
     266    };
     267
     268    // ### set-funcallable-instance-function funcallable-instance function => unspecified
     269    // AMOP p. 230
     270    private static final Primitive SET_FUNCALLABLE_INSTANCE_FUNCTION =
     271        new Primitive("set-funcallable-instance-function", PACKAGE_MOP, true,
     272                      "funcallable-instance function")
     273    {
     274        public LispObject execute(LispObject first, LispObject second)
     275            throws ConditionThrowable
     276        {
     277            try {
     278                ((StandardGenericFunction)first).function = second;
     279                return second;
     280            }
     281            catch (ClassCastException e) {
     282                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    300283            }
    301284        }
     
    312295            }
    313296            catch (ClassCastException e) {
    314                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     297                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    315298            }
    316299        }
     
    329312            }
    330313            catch (ClassCastException e) {
    331                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     314                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    332315            }
    333316        }
     
    344327            }
    345328            catch (ClassCastException e) {
    346                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     329                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    347330            }
    348331        }
     
    361344            }
    362345            catch (ClassCastException e) {
    363                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     346                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    364347            }
    365348        }
     
    376359            }
    377360            catch (ClassCastException e) {
    378                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     361                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    379362            }
    380363        }
     
    393376            }
    394377            catch (ClassCastException e) {
    395                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     378                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    396379            }
    397380        }
     
    408391            }
    409392            catch (ClassCastException e) {
    410                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     393                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    411394            }
    412395        }
     
    425408            }
    426409            catch (ClassCastException e) {
    427                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     410                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    428411            }
    429412        }
     
    440423            }
    441424            catch (ClassCastException e) {
    442                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     425                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    443426            }
    444427        }
     
    457440            }
    458441            catch (ClassCastException e) {
    459                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     442                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    460443            }
    461444        }
     
    472455            }
    473456            catch (ClassCastException e) {
    474                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     457                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    475458            }
    476459        }
     
    489472            }
    490473            catch (ClassCastException e) {
    491                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     474                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    492475            }
    493476        }
     
    504487            }
    505488            catch (ClassCastException e) {
    506                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     489                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    507490            }
    508491        }
     
    521504            }
    522505            catch (ClassCastException e) {
    523                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     506                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    524507            }
    525508        }
     
    536519            }
    537520            catch (ClassCastException e) {
    538                 return signal(new TypeError(arg, Symbol.GENERIC_FUNCTION));
     521                return signal(new TypeError(arg, Symbol.STANDARD_GENERIC_FUNCTION));
    539522            }
    540523        }
     
    553536            }
    554537            catch (ClassCastException e) {
    555                 return signal(new TypeError(first, Symbol.GENERIC_FUNCTION));
     538                return signal(new TypeError(first, Symbol.STANDARD_GENERIC_FUNCTION));
    556539            }
    557540        }
  • trunk/j/src/org/armedbear/lisp/StandardGenericFunctionClass.java

    r9218 r9228  
    33 *
    44 * Copyright (C) 2005 Peter Graves
    5  * $Id: StandardGenericFunctionClass.java,v 1.1 2005-05-21 15:29:19 piso Exp $
     5 * $Id: StandardGenericFunctionClass.java,v 1.2 2005-05-22 17:25:53 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    2424public final class StandardGenericFunctionClass extends StandardClass
    2525{
    26     public static final int SLOT_INDEX_NAME                      =  0;
    27     public static final int SLOT_INDEX_LAMBDA_LIST               =  1;
    28     public static final int SLOT_INDEX_DISCRIMINATING_FUNCTION   =  2;
    29     public static final int SLOT_INDEX_REQUIRED_ARGS             =  3;
    30     public static final int SLOT_INDEX_INITIAL_METHODS           =  4;
    31     public static final int SLOT_INDEX_METHODS                   =  5;
    32     public static final int SLOT_INDEX_METHOD_CLASS              =  6;
    33     public static final int SLOT_INDEX_METHOD_COMBINATION        =  7;
    34     public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER =  8;
    35     public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE      =  9;
    36     public static final int SLOT_INDEX_DOCUMENTATION             = 10;
     26    public static final int SLOT_INDEX_NAME                      = 0;
     27    public static final int SLOT_INDEX_LAMBDA_LIST               = 1;
     28    public static final int SLOT_INDEX_REQUIRED_ARGS             = 2;
     29    public static final int SLOT_INDEX_INITIAL_METHODS           = 3;
     30    public static final int SLOT_INDEX_METHODS                   = 4;
     31    public static final int SLOT_INDEX_METHOD_CLASS              = 5;
     32    public static final int SLOT_INDEX_METHOD_COMBINATION        = 6;
     33    public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 7;
     34    public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE      = 8;
     35    public static final int SLOT_INDEX_DOCUMENTATION             = 9;
    3736
    3837    public StandardGenericFunctionClass()
     
    4342            pkg.intern("NAME"),
    4443            pkg.intern("LAMBDA-LIST"),
    45             pkg.intern("DISCRIMINATING-FUNCTION"),
    4644            pkg.intern("REQUIRED-ARGS"),
    4745            pkg.intern("INITIAL-METHODS"),
  • trunk/j/src/org/armedbear/lisp/clos.lisp

    r9224 r9228  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.174 2005-05-21 15:50:53 piso Exp $
     4;;; $Id: clos.lisp,v 1.175 2005-05-22 17:28:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    824824            (%set-gf-required-args gf required-args)
    825825            (when apo-p
    826 ;;               (setf (slot-value gf 'argument-precedence-order)
    827826              (setf (generic-function-argument-precedence-order gf)
    828827                    (if argument-precedence-order
     
    848847
    849848(defun finalize-generic-function (gf)
    850   (%set-generic-function-discriminating-function
     849  (set-funcallable-instance-function
    851850   gf
    852851   (funcall (if (eq (class-of gf) the-class-standard-gf)
     
    879878           (required-args (getf plist ':required-args)))
    880879      (%set-gf-required-args gf required-args)
    881 ;;       (setf (slot-value gf 'argument-precedence-order)
    882880      (setf (generic-function-argument-precedence-order gf)
    883881            (if argument-precedence-order
Note: See TracChangeset for help on using the changeset viewer.