Artificial flavors

From EDM2
Jump to: navigation, search

Artificial flavors is a small extension to CLOS that makes it compatible with the Flavours object system, but Flavours is an object system was bolted onto LISP at MIT and was later used by Symbolics in addition to a few other LISP tool makers. Flavours highly influenced CLOS but there are still a few differences between the two systems and Artificial flavors aids in porting old code to modern LISP systems, it is especially useful for porting of code developed on old Symbolics machines. The code was originally developed for Portable Common Loops, but this version should work with any CLOS system.

Please note that the code here below is copyrighted and not under the Attribution-Share Alike 3.0 licence like the rest of the EDM/2 Wiki.

;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: (artificial-flavors :nicknames (af) :use cl) -*-
;;; A  straightforward partial implementation of Symbolics New Flavors in PCL.
;;; Michael Travers 8 Dec 88
;;; updated for "5/22/89 Victoria PCL", 13 September 89
;;; CLOS version 24 Aug 90

#+:Genera
(eval-when (load compile)
  (unless (member :clos *features*)
    (error "Sorry, CLOS is required.  Look for the PCL version in the attic.")))

;;; We DON'T package-use CLOS, because we define our own version of defmethod, etc.
;;; instead we refer to CLOS symbols eith explicit pkg names.

(cl:defpackage artificial-flavors
  (:nicknames "AF")
  (:use #+:GENERA cl #+:MCL common-lisp)
  (:shadow defmethod make-instance)
  (:export defflavor defmethod make-instance symbol-value-in-instance boundp-in-instance
	   compile-flavor-methods self))

#+:MCL
(defpackage clos
  (:use CCL CL)
  (:export defclass defmethod with-slots initialize-instance find-class make-instance slot-value slot-boundp))

(in-package af)

(defmacro defflavor (name ivs components &rest options)
  (let ((reader-slots nil)
	(writer-slots nil)
        (init-slots nil)
	(bare-ivs nil)
        (keyword-package (find-package 'keyword)))
    (dolist (option options)
      (let ((option-name (if (listp option) (car option) option))
	    (option-value (if (listp option) (cdr option) nil)))
	(flet ((spec-or-all-ivs (spec)
		 (or spec
		     (mapcar #'(lambda (iv) (if (listp iv) (car iv) iv)) ivs))))
	  (case option-name
	    (:writable-instance-variables
	      (setq writer-slots (spec-or-all-ivs option-value))
	      (setq reader-slots (nunion reader-slots (spec-or-all-ivs option-value))))
	    (:readable-instance-variables
	      (setq reader-slots (nunion reader-slots (spec-or-all-ivs option-value))))
	    (:initable-instance-variables
             (setq init-slots (spec-or-all-ivs option-value)))
	    (t (error "Can't handle defflavor option ~A" option-name))))))
    (setq reader-slots (set-difference reader-slots writer-slots))
    (flet ((process-iv (iv-form)
	     (let ((iv (if (listp iv-form) (car iv-form) iv-form)))
	       (push iv bare-ivs)
	       `(,iv
		 ,@(if (and (listp iv-form) (cdr iv-form))
                     `(:initform ,(cadr iv-form)))
                 ,@(if (member iv init-slots)
                     `(:initarg ,(intern (symbol-name iv) keyword-package)))
		 ,@(if (member iv reader-slots)
                     `(:reader ,(implode name "-" iv)))
		 ,@(if (member iv writer-slots)
                     `(:accessor ,(implode name "-" iv)))))))
      `(eval-when (compile load eval)		;We have to compile class to expand methods
	 (clos:defclass ,name ,components ,(mapcar #'process-iv ivs))))))

(defun implode (&rest components)
  (intern (apply #'concatenate 'string (mapcar #'string components))))

(defmacro defmethod ((function class &optional type) arglist &body body)
  (if (eq function 'make-instance)
      (setq function 'clos:initialize-instance))
  (multiple-value-bind (decls body)
      (split-off-declarations body)
    `(clos:defmethod ,function ,@(if type (list type)) ((self ,class) ,@arglist)
       ,@decls
       ;; Like with-slots, but avoids an extra binding (and compiler warnings)
       (symbol-macrolet ,(mapcar #'(lambda (s) `(,s (slot-value self ',s)))
                               (slots-for-class class))
         #+:CCL (declare (ccl::ignore-if-unused ,@(slots-for-class class))) 
	 ,@body))))

(defun slots-for-class (class-name)
  (let ((class (clos:find-class class-name)))
    (mapcar #'(lambda (sd)			
	      (clos::slot-definition-name sd))
	    #-ccl-2 (clos::class-slots class)
	    #+ccl-2 (clos::class-instance-slots class)
            )))

(defun split-off-declarations (body)
  (do ((rest body (cdr rest))
       (declarations nil))
      ((null rest)
       (values declarations nil))
    (if (or (stringp (car rest))
	    (and (listp (car rest))
		 (eq 'declare (car (car rest)))))
	(push (car rest) declarations)
	(return-from split-off-declarations
	  (values (nreverse declarations) rest)))))

(defun make-instance (class &rest init-plist)
  (apply #'clos:make-instance class init-plist))

(defmacro symbol-value-in-instance (instance symbol)
  `(clos:slot-value ,instance ,symbol))

;; (defsetf symbol-value-in-instance pcl::set-slot-value)

(defmacro boundp-in-instance (instance symbol)
  `(clos:slot-boundp ,instance ,symbol))

(defmacro compile-flavor-methods (&rest ignore)
  #+:mcl (declare (ignore ignore)))

(#-:mcl provide #+:mcl ccl:provide 'artificial-flavors)
(push :artificial-flavors *features*)

Author

  • Michael Travers