Changeset 13970


Ignore:
Timestamp:
06/17/12 10:54:11 (9 years ago)
Author:
rschlatte
Message:

implement generic-function-declarations

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunction.java

    r13947 r13970  
    6666    slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
    6767      NIL;
     68    slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL;
    6869    slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] = NIL;
    6970    slots[StandardGenericFunctionClass.SLOT_INDEX_DOCUMENTATION] = NIL;
     
    115116    slots[StandardGenericFunctionClass.SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER] =
    116117      NIL;
     118    slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = NIL;
    117119    slots[StandardGenericFunctionClass.SLOT_INDEX_CLASSES_TO_EMF_TABLE] =
    118120      NIL;
     
    484486    }
    485487  };
     488
     489  private static final Primitive GENERIC_FUNCTION_DECLARATIONS
     490    = new pf_generic_function_declarations();
     491  @DocString(name="%generic-function-declarations")
     492  private static final class pf_generic_function_declarations extends Primitive
     493  {
     494    pf_generic_function_declarations()
     495    {
     496      super("%generic-function-declarations", PACKAGE_SYS, true);
     497    }
     498    @Override
     499    public LispObject execute(LispObject arg)
     500    {
     501      return checkStandardGenericFunction(arg)
     502        .slots[StandardGenericFunctionClass .SLOT_INDEX_DECLARATIONS];
     503    }
     504  };
     505
     506  private static final Primitive SET_GENERIC_FUNCTION_DECLARATIONS
     507    = new pf_set_generic_function_declarations();
     508  @DocString(name="set-generic-function-declarations")
     509  private static final class pf_set_generic_function_declarations extends Primitive
     510  {
     511    pf_set_generic_function_declarations()
     512    {
     513      super("set-generic-function-declarations", PACKAGE_SYS, true);
     514    }
     515    @Override
     516    public LispObject execute(LispObject first, LispObject second)
     517    {
     518      checkStandardGenericFunction(first)
     519        .slots[StandardGenericFunctionClass.SLOT_INDEX_DECLARATIONS] = second;
     520      return second;
     521    }
     522  };
     523
     524
    486525
    487526  private static final Primitive GENERIC_FUNCTION_CLASSES_TO_EMF_TABLE
  • trunk/abcl/src/org/armedbear/lisp/StandardGenericFunctionClass.java

    r13947 r13970  
    4747  public static final int SLOT_INDEX_METHOD_COMBINATION        = 7;
    4848  public static final int SLOT_INDEX_ARGUMENT_PRECEDENCE_ORDER = 8;
    49   public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE      = 9;
    50   public static final int SLOT_INDEX_DOCUMENTATION             = 10;
     49  public static final int SLOT_INDEX_DECLARATIONS              = 9;
     50  public static final int SLOT_INDEX_CLASSES_TO_EMF_TABLE      = 10;
     51  public static final int SLOT_INDEX_DOCUMENTATION             = 11;
    5152
    5253  public StandardGenericFunctionClass()
     
    6667        pkg.intern("%METHOD-COMBINATION"),
    6768        pkg.intern("ARGUMENT-PRECEDENCE-ORDER"),
     69        Symbol.DECLARATIONS,
    6870        pkg.intern("CLASSES-TO-EMF-TABLE"),
    6971        Symbol._DOCUMENTATION
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13968 r13970  
    14131413  (let ((options ())
    14141414        (methods ())
     1415        (declarations ())
    14151416        (documentation nil))
    14161417    (dolist (item options-and-method-descriptions)
    14171418      (case (car item)
    1418         (declare) ; FIXME
     1419        (declare
     1420         (when declarations
     1421           (error 'program-error
     1422                  :format-control "Two declare forms in definition of generic function ~S."
     1423                  :format-arguments (list function-name)))
     1424         (setf declarations t)
     1425         (push (list :declarations (cdr item)) options))
    14191426        (:documentation
    14201427         (when documentation
     
    16091616                                                method-combination
    16101617                                                argument-precedence-order
     1618                                                declarations
    16111619                                                documentation)
    16121620  ;; to avoid circularities, we do not call generic functions in here.
     
    16191627    (set-generic-function-method-class gf method-class)
    16201628    (set-generic-function-method-combination gf method-combination)
     1629    (set-generic-function-declarations gf declarations)
    16211630    (set-generic-function-documentation gf documentation)
    16221631    (set-generic-function-classes-to-emf-table gf nil)
     
    40314040
    40324041;;; Readers for generic function metaobjects
    4033 ;;; See AMOP pg. 216ff.
     4042;;; AMOP pg. 216ff.
    40344043(atomic-defgeneric generic-function-argument-precedence-order (generic-function)
    40354044  (:method ((generic-function standard-generic-function))
     
    40384047(atomic-defgeneric generic-function-declarations (generic-function)
    40394048  (:method ((generic-function standard-generic-function))
    4040     ;; TODO: add slot to StandardGenericFunctionClass.java, use it
    4041     nil))
     4049    (sys:%generic-function-declarations generic-function)))
    40424050
    40434051(atomic-defgeneric generic-function-lambda-list (generic-function)
     
    42554263                                  method-combination
    42564264                                  argument-precedence-order
     4265                                  declarations
    42574266                                  documentation
    42584267                                &allow-other-keys)
    42594268  (declare (ignore lambda-list generic-function-class method-class
    4260                    method-combination argument-precedence-order documentation))
     4269                   method-combination argument-precedence-order declarations
     4270                   documentation))
    42614271  (apply #'ensure-generic-function-using-class
    42624272         (find-generic-function function-name nil)
Note: See TracChangeset for help on using the changeset viewer.