home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / windows / winlisp.zip / LISPLIB.LZH / OOP.WL < prev    next >
Text File  |  1989-09-22  |  7KB  |  159 lines
  1. ;===============================================================================
  2. ; WinLisp:
  3. ;
  4. ;      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
  5. ;
  6. ; Copyright (c) Stephan POPOVITCH 1988-1989
  7. ; Author: Hussein SHAFIE
  8. ;===============================================================================
  9. (setq #:winlisp:colon 'wloop)
  10.  
  11. ;===============================================================================
  12. ;                       E R R O R    M E S S A G E S
  13. ;===============================================================================
  14. (setq :notavar                  "not a variable")
  15. (setq :notaclass                "not a class")
  16. (setq :classnameconfl           "name conflict with a previously defined class")
  17. (setq :initsyntax               "usage: (<instance-variable> <init-value>)")
  18. (setq :notaninstvar             "not an instance variable of class")
  19. (setq :dontunderstand           "does not understand")
  20.  
  21. ;===============================================================================
  22. ;          if not already loaded, load abbreviations module
  23. ;===============================================================================
  24. (unless (typefn 'get-abbrev) (loadfile "abbrev"))
  25.  
  26. ;===============================================================================
  27. ;                     P R I V A T E    F U N C T I O N S
  28. ;===============================================================================
  29. (defun :put-class-name (full-name)
  30.     (let* ( (class-name         (symbol () full-name))
  31.             (older-full-name    (and (abbrevp class-name)
  32.                      (get-abbrev class-name))) )
  33.           (unless (or (null older-full-name)
  34.                       ;; IT IS POSSIBLE TO OVERWRITE A CLASS DEFINITION 
  35.                       ;; THOUGH THIS PRACTICE IS VERY DANGEROUS:
  36.                       ;; PARTIAL OVERWRITING? INCONSISTENCY WITH SUBCLASSES?
  37.                       (eq older-full-name full-name))
  38.                 (error 'defclass 
  39.                        :classnameconfl (cons older-full-name full-name)))
  40.           (put-abbrev class-name full-name)))
  41.  
  42. (defun :get-instvars (class-full-name)
  43.     (when class-full-name
  44.           (append (:get-instvars (packagecell class-full-name))
  45.                   (getprop class-full-name ':defclass))))
  46.  
  47. (defun :subclassp-aux (class1 class2)
  48.        (when class1
  49.              (or (eq class1 class2)
  50.                  (:subclassp-aux (packagecell class1) class2))))
  51.  
  52. (defun :position (item list count)
  53.     (when list
  54.           (if (eq item (car list)) 
  55.               count
  56.               ;;ELSE
  57.               (:position item (cdr list) (1+ count)))))
  58.  
  59. ;===============================================================================
  60. ;                      P U B L I C    F U N C T I O N S
  61. ;===============================================================================
  62. (defun classp (sexpr)
  63.     (when (variablep sexpr)
  64.           (when (memq ':defclass (plist sexpr)) sexpr)))
  65.        
  66. (defun subclassp (class1 class2)
  67.     (when (and (classp class1) (classp class2))
  68.           (:subclassp-aux class1 class2)))
  69.  
  70. (defun field-list (class)
  71.     (unless (classp class)
  72.             (error 'field-list :notaclass class))
  73.     (:get-instvars class))
  74.  
  75. (defmacro defclass (name . instvars)
  76.     (unless (variablep name)
  77.             (error 'defclass :notavar name))
  78.     (mapc '(lambda (instvar)
  79.                (unless (variablep instvar)
  80.                        (error 'defclass :notavar instvar)))
  81.           instvars)
  82.     (let  ( (name       (if (packagecell name) name (symbol 'class name)))
  83.             (index      -1) )
  84.           `(progn
  85.             ;; DECLARATION OF THE NEW CLASS NAME FIRST, IN ORDER TO PREVENT
  86.             ;; THE EXECUTION OF THE REST OF THE CLASS DEFINITION IN CASE OF
  87.             ;; A CONFLICT WITH AN EXISTING CLASS NAME
  88.             (:put-class-name ',name)
  89.             ;; EVERY CLASS HAS A PROPERTY :DEFCLASS IN ITS FULL-NAME SYMBOL
  90.             ;; EVEN IF IT HAS NO INSTANCE VARIABLES
  91.             (putprop ',name ',instvars ':defclass)
  92.             ,.(mapcar
  93.                   '(lambda (instvar)
  94.                        (incr index)
  95.                        `(defun ,(symbol name instvar) (object . value)
  96.                             (if value
  97.                                 (vset object ,index (car value))
  98.                                 (vref object ,index))))
  99.                   (append (:get-instvars (packagecell name))
  100.                           instvars))
  101.             ',name)))
  102.  
  103. (defmacro new (class . inits)
  104.     (unless (classp class)
  105.             (error 'new :notaclass class))
  106.     (let  ( (instvars (:get-instvars class)) )
  107.           `((lambda (:instance)
  108.                 (typevector :instance ',class)
  109.                 ,.(mapcar
  110.                       '(lambda (init)
  111.                            (unless (listp init)
  112.                                    (error 'new :initsyntax init))
  113.                            `(vset :instance 
  114.                                   ,(or (:position (car init) instvars 0)
  115.                                        (error 'new 
  116.                                               :notaninstvar 
  117.                                               (cons (car init) class)))
  118.                                   ,(cadr init)))
  119.                        inits)
  120.                 :instance)
  121.             (make-vector ,(length instvars) ()))))
  122.               
  123. (defsharp |S| ()                (apply 'new (read)))
  124.                 
  125. (defmacro defmethod (name params . body)
  126.     (unless (variablep name)
  127.             (error 'defmethod :notavar name))
  128.     (let* ( (class        (or (classp (packagecell name))
  129.                               (error 'defmethod :notaclass (packagecell name))))
  130.             (instvars     (when (and (listp (car body)) (eq '&use (caar body)))
  131.                                 (cdar body)))
  132.             (definstvars  (when instvars (:get-instvars class))) )
  133.           `(defun ,name (self . ,params)
  134.                ,@(if instvars
  135.                      `((let ,(mapcar 
  136.                                 '(lambda (instvar)
  137.                                      `(,instvar 
  138.                                        (vref self
  139.                                             ,(or 
  140.                                                (:position instvar definstvars 0)
  141.                                                (error 'defmethod 
  142.                                                       :notaninstvar 
  143.                                                       (cons instvar class))))))
  144.                                  instvars)
  145.                             ,@(cdr body)))
  146.                      ;; ELSE, (&USE <INSTVARS>) NOT FOUND
  147.                      (if (equal (car body) '(&use))
  148.                          (cdr body)
  149.                          body)))))
  150.  
  151. ;===============================================================================
  152. ;                     C L A S S    B O O T S T R A P
  153. ;===============================================================================
  154. (putprop 'class () ':defclass)
  155. (put-abbrev 'class 'class)
  156.  
  157. (defmethod {class}:does-not-understand (selector . args)
  158.     (error self :dontunderstand selector))
  159.