Ignore:
Timestamp:
10/11/03 14:58:59 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4300 r4305  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defclass.lisp,v 1.6 2003-10-11 00:16:55 piso Exp $
     4;;; $Id: defclass.lisp,v 1.7 2003-10-11 14:58:59 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    495495                 ,(canonicalize-direct-slots direct-slots)
    496496                 ,@(canonicalize-defclass-options options)))
     497
     498;;;
     499;;; Generic function metaobjects and standard-generic-function
     500;;;
     501
     502(defparameter the-defclass-standard-generic-function
     503  '(defclass standard-generic-function ()
     504    ((name :initarg :name)      ; :accessor generic-function-name
     505     (lambda-list               ; :accessor generic-function-lambda-list
     506      :initarg :lambda-list)
     507     (methods :initform ())     ; :accessor generic-function-methods
     508     (method-class              ; :accessor generic-function-method-class
     509      :initarg :method-class)
     510     (discriminating-function)  ; :accessor generic-function-
     511     ;    -discriminating-function
     512     (classes-to-emf-table      ; :accessor classes-to-emf-table
     513      :initform (make-hash-table :test #'equal)))))
     514
     515(defvar the-class-standard-gf (find-class 'standard-generic-function))
     516
     517(defun generic-function-name (gf)
     518  (slot-value gf 'name))
     519(defun (setf generic-function-name) (new-value gf)
     520  (setf (slot-value gf 'name) new-value))
     521
     522(defun generic-function-lambda-list (gf)
     523  (slot-value gf 'lambda-list))
     524(defun (setf generic-function-lambda-list) (new-value gf)
     525  (setf (slot-value gf 'lambda-list) new-value))
     526
     527(defun generic-function-methods (gf)
     528  (slot-value gf 'methods))
     529(defun (setf generic-function-methods) (new-value gf)
     530  (setf (slot-value gf 'methods) new-value))
     531
     532(defun generic-function-discriminating-function (gf)
     533  (slot-value gf 'discriminating-function))
     534(defun (setf generic-function-discriminating-function) (new-value gf)
     535  (setf (slot-value gf 'discriminating-function) new-value))
     536
     537(defun generic-function-method-class (gf)
     538  (slot-value gf 'method-class))
     539(defun (setf generic-function-method-class) (new-value gf)
     540  (setf (slot-value gf 'method-class) new-value))
     541
     542;;; Internal accessor for effective method function table
     543
     544(defun classes-to-emf-table (gf)
     545  (slot-value gf 'classes-to-emf-table))
     546(defun (setf classes-to-emf-table) (new-value gf)
     547  (setf (slot-value gf 'classes-to-emf-table) new-value))
     548
     549;;;
     550;;; Method metaobjects and standard-method
     551;;;
     552
     553(defparameter the-defclass-standard-method
     554  '(defclass standard-method ()
     555    ((lambda-list :initarg :lambda-list)     ; :accessor method-lambda-list
     556     (qualifiers :initarg :qualifiers)       ; :accessor method-qualifiers
     557     (specializers :initarg :specializers)   ; :accessor method-specializers
     558     (body :initarg :body)                   ; :accessor method-body
     559     (environment :initarg :environment)     ; :accessor method-environment
     560     (generic-function :initform nil)        ; :accessor method-generic-function
     561     (function))))                           ; :accessor method-function
     562
     563(defvar the-class-standard-method (find-class 'standard-method))
     564
     565(defun method-lambda-list (method) (slot-value method 'lambda-list))
     566(defun (setf method-lambda-list) (new-value method)
     567  (setf (slot-value method 'lambda-list) new-value))
     568
     569(defun method-qualifiers (method) (slot-value method 'qualifiers))
     570(defun (setf method-qualifiers) (new-value method)
     571  (setf (slot-value method 'qualifiers) new-value))
     572
     573(defun method-specializers (method) (slot-value method 'specializers))
     574(defun (setf method-specializers) (new-value method)
     575  (setf (slot-value method 'specializers) new-value))
     576
     577(defun method-body (method) (slot-value method 'body))
     578(defun (setf method-body) (new-value method)
     579  (setf (slot-value method 'body) new-value))
     580
     581(defun method-environment (method) (slot-value method 'environment))
     582(defun (setf method-environment) (new-value method)
     583  (setf (slot-value method 'environment) new-value))
     584
     585(defun method-generic-function (method)
     586  (slot-value method 'generic-function))
     587(defun (setf method-generic-function) (new-value method)
     588  (setf (slot-value method 'generic-function) new-value))
     589
     590(defun method-function (method) (slot-value method 'function))
     591(defun (setf method-function) (new-value method)
     592  (setf (slot-value method 'function) new-value))
     593
     594;;; defgeneric
     595
     596;; (defmacro defgeneric (function-name lambda-list &rest options)
     597;;   `(ensure-generic-function
     598;;     ',function-name
     599;;     :lambda-list ',lambda-list
     600;;     ,@(canonicalize-defgeneric-options options)))
     601
     602(defun canonicalize-defgeneric-options (options)
     603  (mapappend #'canonicalize-defgeneric-option options))
     604
     605(defun canonicalize-defgeneric-option (option)
     606  (case (car option)
     607    (:generic-function-class
     608     (list ':generic-function-class
     609           `(find-class ',(cadr option))))
     610    (:method-class
     611     (list ':method-class
     612           `(find-class ',(cadr option))))
     613    (t (list `',(car option) `',(cadr option)))))
     614
     615;;; find-generic-function looks up a generic function by name.  It's an
     616;;; artifact of the fact that our generic function metaobjects can't legally
     617;;; be stored a symbol's function value.
     618
     619(defparameter generic-function-table (make-hash-table :test #'equal))
     620
     621(defun find-generic-function (symbol &optional (errorp t))
     622  (let ((gf (gethash symbol generic-function-table nil)))
     623    (if (and (null gf) errorp)
     624        (error "No generic function named ~S." symbol)
     625        gf)))
     626
     627(defun (setf find-generic-function) (new-value symbol)
     628  (setf (gethash symbol generic-function-table) new-value))
     629
     630;;; ensure-generic-function
     631
     632(defun ensure-generic-function
     633  (function-name
     634   &rest all-keys
     635   &key (generic-function-class the-class-standard-gf)
     636   (method-class the-class-standard-method)
     637   &allow-other-keys)
     638  (format t "ensure-generic-function function-name = ~S~%" function-name)
     639  (if (find-generic-function function-name nil)
     640      (find-generic-function function-name)
     641      (let ((gf (apply (if (eq generic-function-class the-class-standard-gf)
     642                           #'make-instance-standard-generic-function
     643                           #'make-instance)
     644                       generic-function-class
     645                       :name function-name
     646                       :method-class method-class
     647                       all-keys)))
     648        (setf (find-generic-function function-name) gf)
     649        gf)))
     650
     651;;; finalize-generic-function
     652
     653;;; N.B. Same basic idea as finalize-inheritance.  Takes care of recomputing
     654;;; and storing the discriminating function, and clearing the effective method
     655;;; function table.
     656
     657(defun finalize-generic-function (gf)
     658  (setf (generic-function-discriminating-function gf)
     659        (funcall (if (eq (class-of gf) the-class-standard-gf)
     660                     #'std-compute-discriminating-function
     661                     #'compute-discriminating-function)
     662                 gf))
     663  (setf (fdefinition (generic-function-name gf))
     664        (generic-function-discriminating-function gf))
     665  (clrhash (classes-to-emf-table gf))
     666  (values))
     667
     668;;; make-instance-standard-generic-function creates and initializes an
     669;;; instance of standard-generic-function without falling into method lookup.
     670;;; However, it cannot be called until standard-generic-function exists.
     671
     672(defun make-instance-standard-generic-function
     673  (generic-function-class &key name lambda-list method-class)
     674  (declare (ignore generic-function-class))
     675  (let ((gf (std-allocate-instance the-class-standard-gf)))
     676    (setf (generic-function-name gf) name)
     677    (setf (generic-function-lambda-list gf) lambda-list)
     678    (setf (generic-function-methods gf) ())
     679    (setf (generic-function-method-class gf) method-class)
     680    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
     681    (finalize-generic-function gf)
     682    gf))
     683
     684;;; defmethod
     685
     686;; (defmacro defmethod (&rest args)
     687;;   (multiple-value-bind (function-name qualifiers
     688;;                                       lambda-list specializers body)
     689;;     (parse-defmethod args)
     690;;     `(ensure-method (find-generic-function ',function-name)
     691;;                     :lambda-list ',lambda-list
     692;;                     :qualifiers ',qualifiers
     693;;                     :specializers ,(canonicalize-specializers specializers)
     694;;                     :body ',body
     695;;                     :environment (top-level-environment))))
     696
     697(defun canonicalize-specializers (specializers)
     698  `(list ,@(mapcar #'canonicalize-specializer specializers)))
     699
     700(defun canonicalize-specializer (specializer)
     701  `(find-class ',specializer))
     702
     703(defun parse-defmethod (args)
     704  (let ((fn-spec (car args))
     705        (qualifiers ())
     706        (specialized-lambda-list nil)
     707        (body ())
     708        (parse-state :qualifiers))
     709    (dolist (arg (cdr args))
     710      (ecase parse-state
     711        (:qualifiers
     712         (if (and (atom arg) (not (null arg)))
     713             (push-on-end arg qualifiers)
     714             (progn (setq specialized-lambda-list arg)
     715               (setq parse-state :body))))
     716        (:body (push-on-end arg body))))
     717    (values fn-spec
     718            qualifiers
     719            (extract-lambda-list specialized-lambda-list)
     720            (extract-specializers specialized-lambda-list)
     721            (list* 'block
     722                   (if (consp fn-spec)
     723                       (cadr fn-spec)
     724                       fn-spec)
     725                   body))))
     726
     727;;; Several tedious functions for analyzing lambda lists
     728
     729(defun required-portion (gf args)
     730  (let ((number-required (length (gf-required-arglist gf))))
     731    (when (< (length args) number-required)
     732      (error "Too few arguments to generic function ~S." gf))
     733    (subseq args 0 number-required)))
     734
     735(defun gf-required-arglist (gf)
     736  (let ((plist
     737         (analyze-lambda-list
     738          (generic-function-lambda-list gf))))
     739    (getf plist ':required-args)))
     740
     741(defun extract-lambda-list (specialized-lambda-list)
     742  (let* ((plist (analyze-lambda-list specialized-lambda-list))
     743         (requireds (getf plist ':required-names))
     744         (rv (getf plist ':rest-var))
     745         (ks (getf plist ':key-args))
     746         (aok (getf plist ':allow-other-keys))
     747         (opts (getf plist ':optional-args))
     748         (auxs (getf plist ':auxiliary-args)))
     749    `(,@requireds
     750      ,@(if rv `(&rest ,rv) ())
     751      ,@(if (or ks aok) `(&key ,@ks) ())
     752      ,@(if aok '(&allow-other-keys) ())
     753      ,@(if opts `(&optional ,@opts) ())
     754      ,@(if auxs `(&aux ,@auxs) ()))))
     755
     756(defun extract-specializers (specialized-lambda-list)
     757  (let ((plist (analyze-lambda-list specialized-lambda-list)))
     758    (getf plist ':specializers)))
     759
     760(defun analyze-lambda-list (lambda-list)
     761  (labels ((make-keyword (symbol)
     762                         (intern (symbol-name symbol)
     763                                 (find-package 'keyword)))
     764           (get-keyword-from-arg (arg)
     765                                 (if (listp arg)
     766                                     (if (listp (car arg))
     767                                         (caar arg)
     768                                         (make-keyword (car arg)))
     769                                     (make-keyword arg))))
     770          (let ((keys ())           ; Just the keywords
     771                (key-args ())       ; Keywords argument specs
     772                (required-names ()) ; Just the variable names
     773                (required-args ())  ; Variable names & specializers
     774                (specializers ())   ; Just the specializers
     775                (rest-var nil)
     776                (optionals ())
     777                (auxs ())
     778                (allow-other-keys nil)
     779                (state :parsing-required))
     780            (dolist (arg lambda-list)
     781              (if (member arg lambda-list-keywords)
     782                  (ecase arg
     783                    (&optional
     784                     (setq state :parsing-optional))
     785                    (&rest
     786                     (setq state :parsing-rest))
     787                    (&key
     788                     (setq state :parsing-key))
     789                    (&allow-other-keys
     790                     (setq allow-other-keys 't))
     791                    (&aux
     792                     (setq state :parsing-aux)))
     793                  (case state
     794                    (:parsing-required
     795                     (push-on-end arg required-args)
     796                     (if (listp arg)
     797                         (progn (push-on-end (car arg) required-names)
     798                           (push-on-end (cadr arg) specializers))
     799                         (progn (push-on-end arg required-names)
     800                           (push-on-end 't specializers))))
     801                    (:parsing-optional (push-on-end arg optionals))
     802                    (:parsing-rest (setq rest-var arg))
     803                    (:parsing-key
     804                     (push-on-end (get-keyword-from-arg arg) keys)
     805                     (push-on-end arg key-args))
     806                    (:parsing-aux (push-on-end arg auxs)))))
     807            (list  :required-names required-names
     808                   :required-args required-args
     809                   :specializers specializers
     810                   :rest-var rest-var
     811                   :keywords keys
     812                   :key-args key-args
     813                   :auxiliary-args auxs
     814                   :optional-args optionals
     815                   :allow-other-keys allow-other-keys))))
     816
     817;;; ensure method
     818
     819(defun ensure-method (gf &rest all-keys)
     820  (let ((new-method
     821         (apply
     822          (if (eq (generic-function-method-class gf)
     823                  the-class-standard-method)
     824              #'make-instance-standard-method
     825              #'make-instance)
     826          (generic-function-method-class gf)
     827          all-keys)))
     828    (add-method gf new-method)
     829    new-method))
     830
     831;;; make-instance-standard-method creates and initializes an instance of
     832;;; standard-method without falling into method lookup.  However, it cannot
     833;;; be called until standard-method exists.
     834
     835(defun make-instance-standard-method (method-class
     836                                      &key lambda-list qualifiers
     837                                      specializers body environment)
     838  (declare (ignore method-class))
     839  (let ((method (std-allocate-instance the-class-standard-method)))
     840    (setf (method-lambda-list method) lambda-list)
     841    (setf (method-qualifiers method) qualifiers)
     842    (setf (method-specializers method) specializers)
     843    (setf (method-body method) body)
     844    (setf (method-environment method) environment)
     845    (setf (method-generic-function method) nil)
     846    (setf (method-function method)
     847          (std-compute-method-function method))
     848    method))
     849
     850;;; add-method
     851
     852;;; N.B. This version first removes any existing method on the generic function
     853;;; with the same qualifiers and specializers.  It's a pain to develop
     854;;; programs without this feature of full CLOS.
     855
     856(defun add-method (gf method)
     857  (let ((old-method
     858         (find-method gf (method-qualifiers method)
     859                      (method-specializers method) nil)))
     860    (when old-method (remove-method gf old-method)))
     861  (setf (method-generic-function method) gf)
     862  (push method (generic-function-methods gf))
     863  (dolist (specializer (method-specializers method))
     864    (pushnew method (class-direct-methods specializer)))
     865  (finalize-generic-function gf)
     866  method)
     867
     868(defun remove-method (gf method)
     869  (setf (generic-function-methods gf)
     870        (remove method (generic-function-methods gf)))
     871  (setf (method-generic-function method) nil)
     872  (dolist (class (method-specializers method))
     873    (setf (class-direct-methods class)
     874          (remove method (class-direct-methods class))))
     875  (finalize-generic-function gf)
     876  method)
     877
     878(defun find-method (gf qualifiers specializers
     879                       &optional (errorp t))
     880  (let ((method
     881         (find-if #'(lambda (method)
     882                     (and (equal qualifiers
     883                                 (method-qualifiers method))
     884                          (equal specializers
     885                                 (method-specializers method))))
     886                  (generic-function-methods gf))))
     887    (if (and (null method) errorp)
     888        (error "No such method for ~S." (generic-function-name gf))
     889        method)))
     890
     891;;; Reader and write methods
     892
     893(defun add-reader-method (class fn-name slot-name)
     894  (ensure-method
     895   (ensure-generic-function fn-name :lambda-list '(object))
     896   :lambda-list '(object)
     897   :qualifiers ()
     898   :specializers (list class)
     899   :body `(slot-value object ',slot-name)
     900   :environment (top-level-environment))
     901  (values))
     902
     903(defun add-writer-method (class fn-name slot-name)
     904  (ensure-method
     905   (ensure-generic-function
     906    fn-name :lambda-list '(new-value object))
     907   :lambda-list '(new-value object)
     908   :qualifiers ()
     909   :specializers (list (find-class 't) class)
     910   :body `(setf (slot-value object ',slot-name)
     911                new-value)
     912   :environment (top-level-environment))
     913  (values))
Note: See TracChangeset for help on using the changeset viewer.