;; objective-lisp.l -- syntactic extensions to XLisp for OOP
;;

;
; extend reader syntax so that [obj args...]
; reads as (send obj args...)
;

(setf (aref *readtable* (char-int #\[)) ; #\[ table entry
      (cons :tmacro
	    (lambda (f c &aux ex ret)	; second arg is not used
	      (do ()
		  ((eq (non-comment-char f) #\]))
		  (let ((cell (cons (read f) nil))
			)
		    (if ex (setf (cdr ex) cell) (setf ret cell))
		    (setf ex cell)))
	      (read-char f)		; toss the trailing #\)
	      (cons (cons 'send ret) NIL))
	    ))

(setf (aref *readtable* (char-int #\]))
      (cons :tmacro
	    (lambda (f c)
	      (error "misplaced right bracket"))))


(defun non-comment-char (f)
  (do ((c (peek-char t f) (peek-char t f))
       )
      ((not (eq (aref *readtable* (char-int c))
		(aref *readtable* (char-int #\;))))
       c)
      (read-line f)
      ) )


;
; defclass, defmethod forms
;

;
; (defmethod _class_ :selector (args) body...)
; adds a method to _class_
;
(defmacro defMethod (cls message arglist &rest body)
  `[,cls :answer ',message ',arglist
	 ',body]
  )

(defMethod Class :SET-PNAME (NAME)
  (SETF PNAME (STRING NAME))
  )

;
; (defClassMethod _class_ :selector (args) body...)
; adds a method to _class_'s metaclass.
;
(defmacro defClassMethod (cls message arglist &rest body)
  `[[,cls :class] :answer ,message ',arglist
    ',body]
  )

;
; In order to have class methods, every normal class
; is an instance of a metaclass. All the metaclasses
; are instances of class.
;

;
; Create the root of the metaclass hierarchy
;

(setf MetaClass [Class :new () () Class])
[MetaClass :set-pname 'MetaClass]

(defMethod Class :for (name super)
  (let ((mc [MetaClass :new () () [super :class]])
	)
    [mc :set-pname (concatenate 'string (string name) "-MetaClass")]
    mc
    ) )

;
; Create a class and its metaclass.
;

(defmacro defClass (cl super &optional ivars cvars)
  (if (null super) (setq super 'Object))
  `(let ((mc [MetaClass :for ',cl ,super])
	 )
     (setf ,cl [mc :new ',ivars ',cvars ,super])
     [,cl :set-pname ',cl]
     )
  )

(provide 'objective-lisp)