class.lisp

(defparameter *self* nil)

;; `class-name` property list -> { :metaclass-symbol, :member-variables, :class-variables, :attributes}

(defmacro class  (name super &body body)
  (let ((member-vars (collect-member-vars name body))
	(class-vars (collect-class-vars name body))
	(metaclass-name (get-metaclass-symbol name)))
    (multiple-value-bind (methods inits attributes) (parse-body body)
	;; method -> (def name (args) body)
	;; attribute -> (:keyword ...)
	;; init -> not (method or attribute)
      (set-attributes name attributes)
      `(symbol-macrolet
	   ;; @member-var and @@class-var expand to symbol-macrolet bindings
	   ,(expand-symbol-macrolets name member-vars class-vars)
	 ;; expand to metaclass definition
	 ,(expand-defmetaclass metaclass-name class-vars attributes)
	 ,(expand-validate-superclass metaclass-name 'standard-class)
	 ;; expand to class definition
	 ,(expand-defclass name metaclass-name super member-vars attributes)
	 ;; (setf <class> class-object)
	 (setf ,name (find-class ',name))
	 ,@inits
;;	 ,(expand-attributes name member-bars attributes)
	 ,@(mapcar
	    #'(lambda (clause)
		(expand-defmethod name clause))
	    methods)))))

(defun get-metaclass-symbol (name)
  (let ((sym (get name :metaclass-symbol nil)))
    (if (not (null sym))
	sym
	(let ((result (gensym (format nil "META-~A" name))))
	  (setf (get name :metaclass-symbol) result)
	  result))))

(defun collect-member-vars (name body)
  (let ((vars
	 (remove-duplicates
	  (collect-symbol-if #'member-var-p body))))
    (dolist (var vars)
      (pushnew var (get name :member-variables)))
    (get name :member-variables)))

(defun collect-class-vars (name body)
  (let ((vars
	 (remove-duplicates
	  (collect-symbol-if #'class-var-p body))))
    (dolist (var vars)
      (pushnew var (get name :class-variables)))
    (get name :class-variables)))

(defun collect-symbol-if (test lst)
  (labels
      ((inner (rest acc)
	 (cond
	   ((atom rest)
	    (if (funcall test rest)
		(cons rest acc)
		acc))
	   ((listp rest)
	    (inner (cdr rest) (inner (car rest) acc))))))
    (inner lst nil)))

(defun class-var-p (sym)
  (and (symbolp sym)
       (let ((name (symbol-name sym)))
	 (and (>= (length name) 3)
	      (string= "@@" name :end2 2)))))

(defun member-var-p (sym)
  (and (symbolp sym)
       (let ((name (symbol-name sym)))
	 (and (>= (length name) 2)
	      (char= #\@ (char name 0))
	      (char/= #\@ (char name 1))))))

(defun var-name (var)
  (cond
    ((class-var-p var) (subseq (symbol-name var) 2))
    ((member-var-p var) (subseq (symbol-name var) 1))
    (T (symbol-name var))))

(defun parse-body (body)
  ;; return  (values defs init)
  (let (methods init attributes)
    (dolist (clause body)
       (cond
	 ((and (listp clause)
	       (eq 'def (car clause) ))
	  (push clause methods))
	 ((and (listp clause)
	       (keywordp (car clause)))
	  (push clause attributes))
	 (T (push clause init))))
    (values 
     (nreverse methods)
     (nreverse init)
     (nreverse attributes))))

(defun expand-symbol-macrolets (name member-vars class-vars)
  (append
   (mapcar
    #'(lambda (var)
	`(,var (slot-value *self* ',var)))
    member-vars)
   (mapcar
    #'(lambda (var)
	`(,var (slot-value ,name ',var)))
    class-vars)))

(defun set-attributes (name attributes)
    (dolist (attr attributes)
      (if (assoc (car attr) (get name :attributes nil))
	  (rplacd (assoc (car attr) (get name :attributes nil))
		(cdr attr))
	  (push attr (get name :attributes nil))))
  (get name :attributes))

(defun expand-member-var-definition (var)
  `(,var :initarg ,(intern (var-name var) :keyword)))
(defun expand-class-var-definition (var)
  `(,var :initarg ,(intern (var-name var) :keyword)))

(defun expand-defmetaclass (name class-vars attributes)
  `(defclass ,name (standard-class)
     (,@(mapcar #'expand-class-var-definition class-vars))))

(defun expand-validate-superclass (class super)
  `(defmethod validate-superclass ((class ,class) (super ,super))
     T))

(defun expand-defclass (name metaclass-name super member-vars attributes)
  `(defclass ,name ,super
     (,@(mapcar #'expand-member-var-definition member-vars))
     (:metaclass ,metaclass-name)))

;; clause -> (def fn-name {qualifier}* (args) body)
(defun expand-defmethod (name clause)
  (if (keywordp (third clause))
      (destructuring-bind (def fn-name qualifier args &rest body) clause
	    (declare (ignore def))
	    `(defmethod ,fn-name ,qualifier ((*self* ,name) ,@args)
	       ,@body))
      (destructuring-bind (def fn-name args &rest body) clause
	(declare (ignore def))
	`(defmethod ,fn-name ((*self* ,name) ,@args)
	   ,@body))))


;; example
(class <foo> ()
  (def sum ()
    (+ @@a @b))
  
  (setf @@a 10)
  
  (def set-b (b)
    (setf @b b)))