;===============================================================================
; WINLISP:
;
;
;                    M I N I M U M    O. O. P.    L A Y E R
;
; Follows the ObjVLisp model (P. COINTE OOPSLA '87 proceedings) minus
; the multi-inheritance feature.
;
; AUTHOR:     Hussein SHAFIE
;
; COPYRIGHT:  Gregory POPOVITCH (c) 1989
;
; REQUIRES:   'cmonlib' and 'abbrev' packages
; 
; CAVEATS:    - In this object model (unlike in the Smalltalk-80 model) class
;		variables are not inherited. That might cause some problems
;		if a class variable cv is referenced within a method of a 
;		class C:
;
;			[{MetaC} new 'name 'C
;				. . .
;				'cv		"cvstringvalue"
;				'methods	'(
;			aMess	(()
;					. . .
;					(if (equal #Ccv . . .
;					. . .
;
;		and C has a subclass SubC whose class is not a kind of MetaC
;		(thus SubC instances have no acces to the cv class variable)
;		and that doesn't redefine a method for message aMess:
;
;			[{Class} new 'name 'SubC
;				 'superClass	{C}]
;
;		What do you think will happen at the execution time of:
;
;			[anInstanceOfSubC aMess]
;
;		Answer: a mess...
;
;	      - For specification purposes, one may define an "empty" method 
;		for message aRequiredMess within the protocol of an abstract 
;		class AC.
;		This version of OOPL will not ensure that all non-abstract 
;		subclasses of AC actually implement a method for message 
;		aRequiredMess.
;	      
;             - Redefining a method for message ooplInitialize in classes
;		other than Object and Class may be hazardous for the system.
;===============================================================================

(setq #:winlisp:colon 'oopl)

;===============================================================================
;          if not already loaded, load abbreviations module;
;          and define some usefull functions.
;===============================================================================
(unless (typefn 'get-abbrev) (loadfile "abbrev"))

(defun makelist (n s)
       (if (<= n 0) () (cons s (makelist (1- n) s))))
(setq :gensym-str "g" :gensym-idx 100)
(defun gensym () (concat :gensym-str (incr :gensym-idx)))
(synonym 'makevector 'make-vector)

;===============================================================================
;                        E R R O R    M E S S A G E S
;===============================================================================

(defvar :notavar "not a symbol")
(defvar :notalist "not a list")
(defvar :badinstvarinit "usage: { <instance variable> <value> }*")
(defvar :badmethdef "usage:  <name> '(' <args>  { <statements> }+  ')'")
(defvar :notaninstvar "not an instance variable defined in class")
(defvar :notaclassvar "not a class variable of class")
(defvar :redefinstvar "instance variable redefined by subclass")
(defvar :illinstvarref "reference of a class or instance variable outside a method")
(defvar :doesnotunderstand "does not understand")        
(defvar :sendqsyntax "usage: '[' <receiver>|super <selector> { <argument> }* ']'")        
(defvar :illsendsuper "[super <selector> ... ] outside a method definition")
(defvar :notaclass "not a class")
(defvar :notinstantiable "abstract classes cannot be instantiated")

;===============================================================================
;                      P R I V A T E    F U N C T I O N S
;===============================================================================

(defmacro :make-typed-vector (type length init)
          ;; ------------------------------------------------------
          ;; Return a vector typed <type> with <length> elements
          ;; initialized to <init>.
          ;; ------------------------------------------------------
          `(let ( (new-vector (makevector ,length ,init)) )
                (typevector new-vector ,type)
                new-vector))

(defun :index (symbol list index)
       ;; -------------------------------------------------------------
       ;; Return the position index (starting at <index>) of <symbol> 
       ;; in <list>.
       ;; Return () if <symbol> is not a member of <list>.
       ;; -------------------------------------------------------------
       (when list
             (if (eq symbol (car list))
                 index
                 ;;ELSE
                 (:index symbol (cdr list) (1+ index)))))
           
(defun :initialize-instance (instance instvars inits)
       ;; -------------------------------------------------------------
       ;; Initialize some elements of vector <instance> according to
       ;; the specification <inits>.
       ;; <inits> is a list of associations symbolic key/value.
       ;; <instvars> is a list of keys, the first key beeing a symbolic
       ;; name for element 0 of the vector, the second for element 1, ...
       ;; -------------------------------------------------------------
       (when inits
             (let* ( (instvar (car inits))
                     (index   (:index instvar instvars 0)) )
                   (unless index
                           (error "{Class}:new"
                                  :notaninstvar
                                  (cons instvar 
                                        (send 'name (send 'class instance)))))
                   (unless (cdr inits)
                           (error "{Class}:new" :badinstvarinit instvar))
                   (vset instance index (cadr inits))
                   (:initialize-instance instance instvars (cddr inits)))))

(defmacro :install-class (class-object class-name super-class-name)
          ;; ------------------------------------------------------
          ;; Define <class-name> as an abbreviation for the symbol:
          ;; inheritance_path_up_to_<super-class-name>:<class-name>.
          ;; Store <class-object> as the value of this "long" symbol.
          ;; ------------------------------------------------------
          `(let ( (class-symbol (if ,super-class-name
                                    (symbol (get-abbrev ,super-class-name)
                                            ,class-name)
                                    ;;ELSE
                                    ,class-name)) )
                (put-abbrev ,class-name class-symbol)
                (set class-symbol ,class-object)))

(defun :install-methods (class methods)
       ;; -------------------------------------------------------------
       ;; Install the methods <methods> defined at the class <class>
       ;; creation time.
       ;; -------------------------------------------------------------
       (when methods
             (send 'addMethod class (car methods) (cadr methods))
             (:install-methods class (cddr methods))))
                                 
(defun :not-variablep (x)	(if (variablep x) () x))

(defun :merge-instvars (super-instvars self-instvars)
       ;; -------------------------------------------------------------
       ;; Check that <self-instvars> is a list of variables.
       ;; Check that no element of <self-instvars> is also an element
       ;; of <super-instvars>.
       ;; -------------------------------------------------------------
       (unless (listp self-instvars)
               (error "{Class}:new" :notalist self-instvars))

       (let ( (bad-instvar (any ':not-variablep self-instvars)) )

            (when bad-instvar
                  (error "{Class}:new" :notavar bad-instvar))

            (cond ( (null super-instvars)	self-instvars )
                  ( (null self-instvars)	super-instvars )
                  ( t		         ;CHECK FOR REDEFINED INSTANCE VARIABLES
                    (setq bad-instvar
                          (any '(lambda (instvar)
                                        (when (member instvar super-instvars)
                                              instvar))
                                self-instvars))
                    (if bad-instvar
                        (error "{Class}:new" :redefinstvar bad-instvar)
                        ;;ELSE
                        (nconc (copy super-instvars) self-instvars)) ))))
                                        
(defmacro :class (instance)		`(symeval (type-of ,instance)))

(defun :replace-refs (sexpr)
       (when (consp sexpr)
             (selectq (car sexpr)
                      ( :instvar-ref
                        (let* ( (instvar (cadr sexpr))
                                (index   (:index instvar *instvars* 0)) )
                              (if index
                                  (displace sexpr `(vref self ,index))
                                  ;;ELSE
                                  (error "{Class}:addMethod"
                                         :notaninstvar 
                                         (cons instvar *classname*)))) )
                      ( :classvar-ref
                        (let* ( (classvar (cadr sexpr))
                                (index    (:index classvar *classvars* 0)) )
                              (if index
                                  (displace sexpr 
                                            `(vref (:class self) ,index))
                                  ;;ELSE
                                  (error "{Class}:addMethod"
                                         :notaclassvar
                                         (cons classvar *classname*)))) )
                      ( :classname-ref
                        (displace sexpr `(quote ,*classname*)) )
                      ( t	
                        (:replace-refs (car sexpr))
                        (:replace-refs (cdr sexpr)) ))))
       
(defun :as-method (implementation instvars classvars classname)
       ;; -------------------------------------------------------------
       ;; Insert 'self' at the beginning of the lambda list starting
       ;; <implementation>.
       ;; Call :replace-refs in order to physically replace all instance
       ;; variable references (if found in <instvars>), all class
       ;; variable references (if found in <classvars>) by an equivalent
       ;; call to vref and all class name references by the name of the
       ;; class where the method is defined (<classname>).
       ;; -------------------------------------------------------------
       (let ( (*instvars*  instvars)
              (*classvars* classvars)
              (*classname* classname) )
            (setf (car implementation) (cons 'self (car implementation)))
            (:replace-refs (cdr implementation))
            implementation))

;;; ---------------------------------------------------------------------------
;;; Instance variable, class variable and class name references
;;; ---------------------------------------------------------------------------

(defmacro :instvar-ref (instvar)	`(error '|#I| :illinstvarref ,instvar))

(defsetf :instvar-ref (instvar) (val)	`(error '|#I| :illinstvarref ,instvar))

(defsharp |I| ()			`(:instvar-ref ,(read)))

(defmacro :classvar-ref (classvar)	`(error '|#C| :illinstvarref ,classvar))

(defsetf :classvar-ref (classvar) (val)	`(error '|#C| :illinstvarref ,classvar))

(defsharp |C| ()			`(:classvar-ref ,(read)))

(defmacro :classname-ref ()		`(error '|[| :illsendsuper ()))

;;; ---------------------------------------------------------------------------
;;; The message passing syntax is:
;;;	 '[' <receiver>|super <selector> { <argument> }* ']'
;;; The Lisp level syntax using send or send-super remains mandatory
;;; when the message selector has to be dynamically evaluated.
;;; ---------------------------------------------------------------------------

(dmc |]| ()		(error '|]| :sendqsyntax ()))

(dmc |[| ()
     (let ( (receiver  (read)) 
            (selector  (read)) )
          (unless (variablep selector)
                  (error '|[| :sendqsyntax selector))
          (if (eq receiver 'super)
              ;; |[| MUST CONS A NEW (:CLASSNAME-REF) EACH TIME IT IS CALLED
              ;; BECAUSE THE PURPOSE OF THIS DUMMY FUNCTION IS TO BE PHYSICALLY 
              ;; REPLACED BY AN ACTUAL CLASS NAME.
              `(send-super ,(list ':classname-ref) ',selector self 
                           ,.(read-delimited-list #/]))
              ;;ELSE
              `(send ',selector ,receiver ,.(read-delimited-list #/])))))

;===============================================================================
;                       P U B L I C    F U N C T I O N S
;===============================================================================

;(defun send (selector . receiver___args)
       ;; -------------------------------------------------------------
       ;; Send the message <selector> to the car of <receiver___args>
       ;; with the cdr of <receiver___args> as arguments.
       ;; -------------------------------------------------------------
;       (let ( (method (getfn (type-of (car receiver___args)) selector)) )
;            (if method
;                (apply method receiver___args)
;                ;;ELSE
;                (send 'doesNotUnderstand 
;                      (car receiver___args) 
;                      selector (cdr receiver___args)))))

(synonym 'send-super 'sendsuper)
;(defun send-super (classname selector . receiver___args)
       ;; -------------------------------------------------------------
       ;; Send the message <selector> to the car of <receiver___args>
       ;; CONSIDERED AS BEING AN INSTANCE OF CLASS <classname>'s
       ;; SUPERCLASS with the cdr of <receiver___args> as arguments.
       ;; -------------------------------------------------------------
;       (let ( (method (getfn (packagecell classname) selector)) )
;            (if method
;                (apply method receiver___args)
;                ;;ELSE
;                (send-super classname 
;                            'doesNotUnderstand 
;                            (car receiver___args) 
;                            selector (cdr receiver___args)))))

;;; ---------------------------------------------------------------------------
;;; "methods" inherited by both primitive objects and non primitive objects
;;; ---------------------------------------------------------------------------
(defun class (self)		(:class self))

(defun isKindOf (self aClass)
       [[self class] inheritsFrom aClass])
        
(defun doesNotUnderstand (self selector args)
       (error 'doesNotUnderstand :doesnotunderstand (cons self selector)))


;===============================================================================
;                     F O U N D A T I O N    C L A S S E S
;===============================================================================

;;; ---------------------------------------------------------------------------
;;; BOOTSTRAP PREPARATION: 
;;; In order to create the first classes 'Object' and then 'Class' the usual
;;; way (i.e. by sending the message 'new' to 'Class'), one has to do
;;; the hard way (by hand, in native lisp) first what will be automatically
;;; redone by the bootstrapped system.
;;; So the best documentation for the code that follows is its object oriented
;;; equivalent [{Class} new 'name 'Class 'superClass ...)
;;; ---------------------------------------------------------------------------

(put-abbrev 'Class '#:Object:Class)

(setq #:Object:Class
      #:Object:Class:#[ Class
                        ()
                        (name superClass instanceVariables methods)
                        () ])

(defun #:Object:Class:new (self . inits)
       (let ( (name              (vref self 0))
              (instanceVariables (vref self 2)) )
            (send 'ooplInitialize
                  (:make-typed-vector (get-abbrev name) 
                                      (length instanceVariables) 
                                      ())
                  inits)))

(defun #:Object:Class:ooplInitialize (self inits)
       (let ( (CinstanceVariables (vref (:class self) 2)) )
            (:initialize-instance self CinstanceVariables inits))

       (let* ( (name               (vref self 0))
               (superClass         (vref self 1))
               (superClassName     (when superClass 
                                         (send 'name superClass)))
               (superClassInstvars (when superClass
                                         (send 'instanceVariables superClass)))
               (IinstanceVariables (vref self 2)) 
               (methods            (vref self 3)) )
             (:install-class self name superClassName)
             (vset self 2 (:merge-instvars superClassInstvars 
                                           IinstanceVariables))
             (vset self 3 ())	
             (:install-methods self methods)
             self))

(defun #:Object:Class:addMethod (self selector implementation)
       (let* ( (name               (get-abbrev (vref self 0)))
               (functionName       (symbol name selector))
               (IinstanceVariables (vref self 2))
               (CinstanceVariables (vref (:class self) 2))
               (methods            (vref self 3)) )
             (apply 'defun (cons functionName
                                 (:as-method implementation
                                             IinstanceVariables
                                             CinstanceVariables
                                             name)))
             (vset self 3 (nconc methods (list selector functionName)))))
              
(defun #:Object:Class:name (self)			(vref self 0))

(defun #:Object:Class:instanceVariables (self)		(vref self 2))

;;; ---------------------------------------------------------------------------
;;; AbstractClass INSTANTIATION...
;;;	An abstract class will be used TO SPECIFY what is the structure/ 
;;;	behavior common to its subclasses and not directly as a template 
;;;	used to create objects. 
;;; ---------------------------------------------------------------------------

[{Class} new
	'name		'AbstractClass
        'superClass	{Class}
        'methods	'(
                                
new ( inits	
    ;; -------------------------------------------------------------------    
    ;; New is redefined to signal any attempt to instantiate an abstract
    ;; class as an error.
    ;; -------------------------------------------------------------------    
      	(error "{AbstractClass}:new" :notinstantiable self))

addMethod ((selector implementation)
           ;; ------------------------------------------------------
           ;; AddMethod is redefined in order to support an empty
           ;; implementation for a method, this kind of definition
           ;; being considered as a requirement spec for the receiver 
           ;; subclasses.
           ;; ------------------------------------------------------
		(if (cdr implementation)
                    [super addMethod selector implementation]
                    ;;ELSE
                    (setf #Imethods (nconc #Imethods (list selector ())))))

)]
 
;;; ---------------------------------------------------------------------------
;;; Object INSTANTIATION...
;;; ---------------------------------------------------------------------------

[{AbstractClass}  new 
	   'name			'Object
           'methods            		'(
                                           
ooplInitialize ((inits)
           ;; ---------------------------------------------------
           ;; Private - initialize the receiver as a terminal 
           ;;           instance according to <inits>.
           ;; ---------------------------------------------------
                (:initialize-instance self #CinstanceVariables inits)
                self)

)]

;;; ---------------------------------------------------------------------------
;;; Class INSTANTIATION...
;;; Notice that the functions that implement new, ooplInitialize, addMethod...
;;; are overwritten during the Class instantiation WHILE THEY ARE EXECUTED!!!
;;; ---------------------------------------------------------------------------
[{Class}  new
           'name		'Class
           'superClass		{Object}
           'instanceVariables	'(name superClass instanceVariables methods)
           'methods		'(

new ( inits
    ;; -------------------------------------------------------------------    
    ;; Non special objects basic constructor.
    ;; Is able to create a new instance of the receiver initialized 
    ;; according to <inits>.
    ;; -------------------------------------------------------------------    
      [(:make-typed-vector (get-abbrev #Iname) (length #IinstanceVariables) ())
  		ooplInitialize inits])

ooplInitialize ((inits)
           ;; ----------------------------------------------------
           ;; Private - initialize the receiver as a non terminal 
           ;;           instance according to <inits>.
           ;;           Implement static inheritance of instance
           ;;           variables.
           ;; ----------------------------------------------------
                [super ooplInitialize inits]
                (let* ( (superClass         #IsuperClass) 
                        (superClassName     (when superClass 
                                                  [superClass name]))
                        (superClassInstvars (when superClass
                                                  [superClass 
                                                  	instanceVariables]))
                        (methods            #Imethods) )
                      (:install-class self #Iname superClassName)
                      (setf #IinstanceVariables 
                            (:merge-instvars superClassInstvars
                                             #IinstanceVariables))
                      (setf #Imethods ())	
                      (:install-methods self methods)
                      self))
             
addMethod ((selector implementation)
          	(unless (and (variablep selector) (consp (cdr implementation)))
        		(error "{Class}:addMethod" 
                               :badmethdef (list selector implementation)))

       		(let* ( (name         (get-abbrev #Iname))
                        (functionName (symbol name selector)) )
                      (apply 'defun (cons functionName
                                          (:as-method implementation
                                                      #IinstanceVariables
                                                      #CinstanceVariables
                                                      name)))
                      (setf #Imethods (nconc #Imethods 
                                             (list selector functionName)))))

name (()		#Iname)

superClass (()		#IsuperClass)

instanceVariables (()	#IinstanceVariables)

methods (()		#Imethods)

inheritsFrom ((aClass)
	      ;; -----------------------------------------------
              ;; Answer t if the receiver inherits from aClass
              ;; Implementation note:
              ;;	without the test (equal aClass {Class})
              ;;	this method loops forever due to the
              ;;	reflexive nature of {Class}.
	      ;; -----------------------------------------------
		(unless (or (equal aClass {Class}) [aClass isKindOf {Class}])
                        (error "{Class}:inheritsFrom" :notaclass aClass))
                [self inheritsFromClass aClass])

inheritsFromClass ((aClass)
			(or (eq #Iname [aClass name])
                            (when #IsuperClass
                                  [#IsuperClass inheritsFromClass aClass])))

showImplementationOf ((methodName)
			(with ( (plist ':temp #Imethods) )
                              (funcall 'print (valfn (getprop ':temp methodName)))))

;prin (()		(prin "{" #Iname "}"))

)]

;;; ---------------------------------------------------------------------------
;;; Attempt to integrate primitive objects...
;;; ---------------------------------------------------------------------------

[{Class} new
	  'name			'MetaPrimitiveObject
          'superClass		{Class}
          'instanceVariables	'(primitiveAllocator)
          'methods		'(

new ( inits	(apply #IprimitiveAllocator inits))

primitiveAllocator ( userAllocator
		     ;; -----------------------------------------------
                     ;; If <userAllocator> is provided, set primitive
                     ;; allocator to that function, else answer the
                     ;; value of the current primitive allocator.
		     ;; -----------------------------------------------
                     	(if userAllocator
			    (setf #IprimitiveAllocator (car userAllocator))
                            ;;ELSE
                            #IprimitiveAllocator))

)]
           
[{MetaPrimitiveObject} new
	'name			   'symbol
        'primitiveAllocator 	   '(lambda inits
        			            (if inits
                                                (apply 'symbol inits)
                                                ;;ELSE
                                                (gensym)))]
                                   
[{MetaPrimitiveObject} new
	'name			   'string
        'primitiveAllocator        '(lambda inits
        			            (if inits
                                                (apply 'makestring inits)
                                                ;;ELSE
                                                (copy "")))]
            
[{MetaPrimitiveObject} new
	'name			   'vector
        'primitiveAllocator        '(lambda inits
        			            (if inits
                                                (apply 'makevector inits)
                                                ;;ELSE
                                                (makevector 0 ())))]
[{MetaPrimitiveObject} new
	'name			   'cons
        'primitiveAllocator        '(lambda inits
        			            (if inits
                                                (apply 'makelist inits)
                                                ;;ELSE
                                                ()))]
            
[{MetaPrimitiveObject} new
	'name			   'float
        'primitiveAllocator        '(lambda inits
        			            (if inits
                                                (apply 'float inits)
                                                ;;ELSE
                                                0.))]
            
[{MetaPrimitiveObject} new
	'name			   'fix
        'primitiveAllocator        '(lambda inits
        			            (if inits
                                                (apply 'fix inits)
                                                ;;ELSE
                                                0))]
            
[{MetaPrimitiveObject} new
	'name			   'null
        'primitiveAllocator        '(lambda inits ())]
