;===============================================================================
; WinLisp:
;
;      O B J E C T - O R I E N T E D    P R O G R A M M I N G   L A Y E R
;
; Copyright (c) Stephan POPOVITCH 1988-1989
; Author: Hussein SHAFIE
;===============================================================================
(setq #:winlisp:colon 'wloop)

;===============================================================================
;                       E R R O R    M E S S A G E S
;===============================================================================
(setq :notavar                  "not a variable")
(setq :notaclass                "not a class")
(setq :classnameconfl           "name conflict with a previously defined class")
(setq :initsyntax               "usage: (<instance-variable> <init-value>)")
(setq :notaninstvar             "not an instance variable of class")
(setq :dontunderstand           "does not understand")

;===============================================================================
;          if not already loaded, load abbreviations module
;===============================================================================
(unless (typefn 'get-abbrev) (loadfile "abbrev"))

;===============================================================================
;                     P R I V A T E    F U N C T I O N S
;===============================================================================
(defun :put-class-name (full-name)
    (let* ( (class-name         (symbol () full-name))
            (older-full-name    (and (abbrevp class-name)
				     (get-abbrev class-name))) )
          (unless (or (null older-full-name)
                      ;; IT IS POSSIBLE TO OVERWRITE A CLASS DEFINITION 
                      ;; THOUGH THIS PRACTICE IS VERY DANGEROUS:
                      ;; PARTIAL OVERWRITING? INCONSISTENCY WITH SUBCLASSES?
                      (eq older-full-name full-name))
                (error 'defclass 
                       :classnameconfl (cons older-full-name full-name)))
          (put-abbrev class-name full-name)))

(defun :get-instvars (class-full-name)
    (when class-full-name
          (append (:get-instvars (packagecell class-full-name))
                  (getprop class-full-name ':defclass))))

(defun :subclassp-aux (class1 class2)
       (when class1
             (or (eq class1 class2)
                 (:subclassp-aux (packagecell class1) class2))))

(defun :position (item list count)
    (when list
          (if (eq item (car list)) 
              count
              ;;ELSE
              (:position item (cdr list) (1+ count)))))
 
;===============================================================================
;                      P U B L I C    F U N C T I O N S
;===============================================================================
(defun classp (sexpr)
    (when (variablep sexpr)
          (when (memq ':defclass (plist sexpr)) sexpr)))
       
(defun subclassp (class1 class2)
    (when (and (classp class1) (classp class2))
          (:subclassp-aux class1 class2)))

(defun field-list (class)
    (unless (classp class)
            (error 'field-list :notaclass class))
    (:get-instvars class))

(defmacro defclass (name . instvars)
    (unless (variablep name)
            (error 'defclass :notavar name))
    (mapc '(lambda (instvar)
               (unless (variablep instvar)
                       (error 'defclass :notavar instvar)))
          instvars)
    (let  ( (name       (if (packagecell name) name (symbol 'class name)))
            (index      -1) )
          `(progn
            ;; DECLARATION OF THE NEW CLASS NAME FIRST, IN ORDER TO PREVENT
            ;; THE EXECUTION OF THE REST OF THE CLASS DEFINITION IN CASE OF
            ;; A CONFLICT WITH AN EXISTING CLASS NAME
            (:put-class-name ',name)
            ;; EVERY CLASS HAS A PROPERTY :DEFCLASS IN ITS FULL-NAME SYMBOL
            ;; EVEN IF IT HAS NO INSTANCE VARIABLES
            (putprop ',name ',instvars ':defclass)
            ,.(mapcar
                  '(lambda (instvar)
                       (incr index)
                       `(defun ,(symbol name instvar) (object . value)
                            (if value
                                (vset object ,index (car value))
                                (vref object ,index))))
                  (append (:get-instvars (packagecell name))
                          instvars))
            ',name)))

(defmacro new (class . inits)
    (unless (classp class)
            (error 'new :notaclass class))
    (let  ( (instvars (:get-instvars class)) )
          `((lambda (:instance)
                (typevector :instance ',class)
                ,.(mapcar
                      '(lambda (init)
                           (unless (listp init)
                                   (error 'new :initsyntax init))
                           `(vset :instance 
                                  ,(or (:position (car init) instvars 0)
                                       (error 'new 
                                              :notaninstvar 
                                              (cons (car init) class)))
                                  ,(cadr init)))
                       inits)
                :instance)
            (make-vector ,(length instvars) ()))))
              
(defsharp |S| ()                (apply 'new (read)))
                
(defmacro defmethod (name params . body)
    (unless (variablep name)
            (error 'defmethod :notavar name))
    (let* ( (class        (or (classp (packagecell name))
                              (error 'defmethod :notaclass (packagecell name))))
            (instvars     (when (and (listp (car body)) (eq '&use (caar body)))
                                (cdar body)))
            (definstvars  (when instvars (:get-instvars class))) )
          `(defun ,name (self . ,params)
               ,@(if instvars
                     `((let ,(mapcar 
                                '(lambda (instvar)
                                     `(,instvar 
                                       (vref self
                                            ,(or 
                                               (:position instvar definstvars 0)
                                               (error 'defmethod 
                                                      :notaninstvar 
                                                      (cons instvar class))))))
                                 instvars)
                            ,@(cdr body)))
                     ;; ELSE, (&USE <INSTVARS>) NOT FOUND
                     (if (equal (car body) '(&use))
                         (cdr body)
                         body)))))

;===============================================================================
;                     C L A S S    B O O T S T R A P
;===============================================================================
(putprop 'class () ':defclass)
(put-abbrev 'class 'class)

(defmethod {class}:does-not-understand (selector . args)
    (error self :dontunderstand selector))
