prototypes.lisp 5.8 KB
Newer Older
David O'Toole's avatar
David O'Toole committed
1 2
;;; prototypes.lisp --- an alternative object system for Common Lisp

3
;; Copyright (C) 2007-2016  David O'Toole
David O'Toole's avatar
David O'Toole committed
4
;; Author: David O'Toole dto@xelf.me
David O'Toole's avatar
David O'Toole committed
5 6 7
;; Keywords: oop
;;
;; This file is free software; you can redistribute it and/or modify
David O'Toole's avatar
David O'Toole committed
8
;; it under the terms of the GNU Lesser General Public License as published by
David O'Toole's avatar
David O'Toole committed
9 10 11 12 13 14
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
David O'Toole's avatar
David O'Toole committed
15
;; GNU Lesser General Public License for more details.
David O'Toole's avatar
David O'Toole committed
16
;;
David O'Toole's avatar
David O'Toole committed
17
;; You should have received a copy of the GNU Lesser General Public License
David O'Toole's avatar
David O'Toole committed
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
;; Floor, Boston, MA 02110-1301, USA.

;;; Code: 

(in-package :xelf)

;;; Utility functions

(defun merge-hashes (a b &optional predicate)
  (prog1 a
    (maphash #'(lambda (key value)
		 (when (or (null predicate)
			   (funcall predicate key))
		   (setf (gethash key a) value)))
	     b)))
35

David O'Toole's avatar
David O'Toole committed
36
;;; Obsolete field reference syntax
David O'Toole's avatar
David O'Toole committed
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66

(defvar *field-reference-prefix* "%")

(defun transform-tree (tester transformer tree)
  (cond ((consp tree)
	 ;; it's a cons. process the two subtrees.
	 (destructuring-bind (left . right) tree
	   (cons
	    ;; process left subtree.
	    (if (funcall tester left)
		(funcall transformer left)
		;; nothing to transform here. move on down the left side.
		(if (consp left)
		    (transform-tree tester transformer left)
		    left))
	    ;; process right subtree.
	    (transform-tree tester transformer right))))
	;; it's not a cons. test it.
	((funcall tester tree)
	 (funcall transformer tree))
	;; it failed the test. leave it alone.
	(t tree)))

;;; field references of the form %foo

(defun field-reference-p (form)
  "Return non-nil if FORM is a symbol like %foo."
  (if (symbolp form)
      (let ((name (symbol-name form)))
	(and (> (length name) 1)
David O'Toole's avatar
David O'Toole committed
67 68
	     (or (string= "%" (subseq name 0 1))
		 (string= "@" (subseq name 0 1)))
David O'Toole's avatar
David O'Toole committed
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
	     ;; don't catch double %%
	     (not (string= "%" (subseq name 1 2)))))))

(defmacro with-input-values (symbols form &body body)
  (assert (every #'symbolp symbols))
  (let ((thing (gensym)))
    (flet ((make-clause (symbol)
	     `(,symbol (evaluate 
			(input-block ,thing 
				     ,(make-keyword symbol))))))
      `(let* ((,thing ,form)
	      ,@(mapcar #'make-clause symbols))
	 ,@body))))
		      
(defun input-reference-p (form)
  "Return non-nil if FORM is a symbol like %%foo."
  (if (symbolp form)
      (let ((name (symbol-name form)))
	(and (> (length name) 2)
	     (string= "%%" (subseq name 0 2))))))

(defun make-accessor-macrolet-clause (symbol)
  (list symbol
David O'Toole's avatar
David O'Toole committed
92 93
	`(slot-value self
	  ',(make-non-keyword
David O'Toole's avatar
David O'Toole committed
94
	     ;; strip percent sign 
David O'Toole's avatar
David O'Toole committed
95
	    (subseq (symbol-name symbol) 1)))))
David O'Toole's avatar
David O'Toole committed
96 97 98 99 100 101

(defun make-accessor-flet-clause (symbol)
  `(,symbol (thing)
	    (field-value ,symbol thing)))

(defun transform-method-body (body)
David O'Toole's avatar
David O'Toole committed
102
  (let (fields)
David O'Toole's avatar
David O'Toole committed
103 104 105 106 107 108 109 110 111 112
    ;; collect %foo symbols used in body
    (transform-tree #'field-reference-p
		    #'(lambda (symbol)
			;; don't modify input
			(prog1 symbol
			  ;; just collect
			  (pushnew symbol fields)))
		    body)
    ;; arrange for the substitution
    `(symbol-macrolet 
David O'Toole's avatar
David O'Toole committed
113
	 ,(mapcar #'make-accessor-macrolet-clause fields)
David O'Toole's avatar
David O'Toole committed
114 115
       ,@body)))

116 117 118
(defmacro with-local-fields (&body body)
  (transform-method-body body))

David O'Toole's avatar
David O'Toole committed
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
(defmacro define-method
    (method-specifier prototype-name arglist &body method-body)
  ;; build the components of the defun
  (let ((method-name (etypecase method-specifier
		       (symbol method-specifier)
		       (list (first method-specifier))))
	(options (when (listp method-specifier)
		   (rest method-specifier))))
    (let* ((documentation (if (stringp (first method-body))
			      (first method-body)))
	   (body2 (remove-if #'stringp (transform-method-body method-body)))
	   ;; handle DECLARE forms when these appear first
	   (declaration (when (and (listp (first body2))
				   (eq 'declare (first (first body2))))
			  (first body2)))
	   (declaration2 (append '(declare (ignorable self))
				 (when declaration
				   ;; paste, skipping the declaration keyword
				   (rest declaration))))
	   (field-name (make-keyword method-name))
David O'Toole's avatar
David O'Toole committed
139 140 141
	   (method-symbol-name (symbol-name method-name)))
      `(defmethod ,(intern method-symbol-name) ((self ,(or prototype-name 'node)) ,@arglist)
	 ,body2))))
David O'Toole's avatar
David O'Toole committed
142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170

(defun transform-declaration (D)
  "Convert the declaration D into a canonical field
descriptor.

The descriptor D must be either a symbol, in which case a field is
defined with no options, or a list of the form:

 (:FIELD-NAME . OPTIONS)

Where OPTIONS is a property list of field options.

The returned entry will be of the form:

 (:FIELD-NAME OPTIONS) 

and will be suitable for use with the functions that operate on field
descriptors, and for inclusion in the association list
%field-descriptors.

See also `define-prototype'.
"
  (etypecase D
    (symbol (list (make-keyword D) nil))
    (list (list (make-keyword (car D)) (cdr D)))))

(defun plist-to-descriptors (plist)
  (let (descriptors)
    (loop while plist do
David O'Toole's avatar
David O'Toole committed
171
      (let* ((field (pop plist))
David O'Toole's avatar
David O'Toole committed
172
	     (value (pop plist)))
David O'Toole's avatar
David O'Toole committed
173
	(push (list field :initform value :initarg (make-keyword field) :accessor field)
David O'Toole's avatar
David O'Toole committed
174 175 176
	      descriptors)))
    (nreverse descriptors)))

David O'Toole's avatar
David O'Toole committed
177 178
;; (plist-to-descriptors '(:a 1 :b 2))
	
David O'Toole's avatar
David O'Toole committed
179 180 181 182 183
(defmacro define-prototype (name
			    (&key super 
				  documentation
				  &allow-other-keys)
			    &body declarations)
David O'Toole's avatar
David O'Toole committed
184
  (let* ((pre-descriptors (if (symbolp (first declarations))
David O'Toole's avatar
David O'Toole committed
185 186 187
			      (plist-to-descriptors declarations)
			      declarations))
	 (descriptors (mapcar #'transform-declaration 
David O'Toole's avatar
David O'Toole committed
188
			      pre-descriptors)))
David O'Toole's avatar
David O'Toole committed
189
    `(progn  
David O'Toole's avatar
David O'Toole committed
190
       (defclass ,name ,(when super (list super)) ,pre-descriptors))))
David O'Toole's avatar
David O'Toole committed
191 192 193 194
  
;;; Clipboard

;;; prototypes.lisp ends here