Changeset 5028


Ignore:
Timestamp:
12/08/03 20:06:08 (17 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r5027 r5028  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: clos.lisp,v 1.13 2003-12-08 15:39:41 piso Exp $
     4;;; $Id: clos.lisp,v 1.14 2003-12-08 20:06:08 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    354354(defvar the-class-standard-class (find-class 'standard-class))
    355355
     356(defun find-slot-definition (class slot-name)
     357  (dolist (slot (class-slots class) nil)
     358    (when (eq slot-name (slot-definition-name slot))
     359      (return slot))))
     360
    356361(defun slot-location (class slot-name)
    357   (let ((slot (find slot-name (class-slots class) :key #'slot-definition-name)))
     362  (let ((slot (find-slot-definition class slot-name)))
    358363    (if slot
    359364        (let ((location (slot-definition-location slot)))
     
    364369        nil)))
    365370
    366 (defun slot-contents (slots location)
    367   (svref slots location))
     371(defmacro slot-contents (slots location)
     372  `(aref ,slots ,location))
    368373
    369374(defun (setf slot-contents) (new-value slots location)
     
    537542    :initarg :method-combination)
    538543   (classes-to-emf-table      ; :accessor classes-to-emf-table
    539     :initform (make-hash-table :test #'equal))))
     544    :initform (make-hash-table :test #'equal))
     545   (required-args :initform ())))
    540546
    541547(defvar the-class-standard-gf (find-class 'standard-generic-function))
     548
     549(defvar *sgf-required-args-index*
     550  (slot-location the-class-standard-gf 'required-args))
     551
     552(defvar *sgf-classes-to-emf-table-index*
     553  (slot-location the-class-standard-gf 'classes-to-emf-table))
    542554
    543555(defun generic-function-name (gf)
     
    572584
    573585(defun classes-to-emf-table (gf)
    574   (slot-value gf 'classes-to-emf-table))
     586;;   (slot-value gf 'classes-to-emf-table))
     587  (slot-contents (std-instance-slots gf) *sgf-classes-to-emf-table-index*))
    575588(defun (setf classes-to-emf-table) (new-value gf)
    576589  (setf (slot-value gf 'classes-to-emf-table) new-value))
     
    589602(defvar the-class-standard-method (find-class 'standard-method))
    590603
     604(defvar *sm-function-index*
     605  (slot-location the-class-standard-method 'function))
     606
    591607(defun method-lambda-list (method) (slot-value method 'lambda-list))
    592608(defun (setf method-lambda-list) (new-value method)
     
    614630  (setf (slot-value method 'generic-function) new-value))
    615631
    616 (defun method-function (method) (slot-value method 'function))
     632(defun method-function (method)
     633;;   (slot-value method 'function))
     634  (slot-contents (std-instance-slots method) *sm-function-index*))
    617635(defun (setf method-function) (new-value method)
    618636  (setf (slot-value method 'function) new-value))
     
    707725  (values))
    708726
     727(defun gf-required-args (gf)
     728  (slot-contents (std-instance-slots gf) *sgf-required-args-index*))
     729
    709730(defun make-instance-standard-generic-function (generic-function-class
    710731                                                &key name lambda-list
     
    719740    (setf (generic-function-method-combination gf) method-combination)
    720741    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
     742    (setf (slot-value gf 'required-args)
     743          (let ((plist (analyze-lambda-list (generic-function-lambda-list gf))))
     744            (getf plist ':required-args)))
    721745    (finalize-generic-function gf)
    722746    gf))
     
    785809
    786810(defun required-portion (gf args)
    787   (let ((number-required (length (gf-required-arglist gf))))
     811  (let ((number-required (length (gf-required-args gf))))
    788812    (when (< (length args) number-required)
    789813      (error 'program-error "not enough arguments for generic function ~S" gf))
    790814    (subseq args 0 number-required)))
    791 
    792 (defun gf-required-arglist (gf)
    793   (let ((plist (analyze-lambda-list (generic-function-lambda-list gf))))
    794     (getf plist ':required-args)))
    795815
    796816(defun extract-lambda-list (specialized-lambda-list)
     
    10741094          (setf (gethash classes (classes-to-emf-table gf)) emfun)
    10751095          (funcall emfun args))
    1076       (error "no methods applicable for generic function ~S with arguments ~S of classes ~S" gf args classes))))
     1096        (error "no applicable methods for generic function ~S with arguments ~S of classes ~S" gf args classes))))
    10771097
    10781098;;; compute-applicable-methods-using-classes
Note: See TracChangeset for help on using the changeset viewer.