`inherit` fatta

diff --git a/Lisp/README.org b/Lisp/README.org
index 5aa1b1ae6d8b3c7a221183477274fd366c4e60f7..b05a4f172ef853b188a25eb7dec2785c27268813 100644 (file)
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -15,19 +15,17 @@
 ;;;; <eventuali collaborazioni>
 
 (defun def-class (classname parents &optional (fields nil) (methods nil))
-  (defun make-class (parents fields methods)
-    (let ((class (list :parents parents
-                      :fields (cdr fields)
-                      :methods (cdr methods))))
-      (if (null parents) class (inherit class parents))))
-
   (cond ((not (listp parents)) (error "`parents` non è una lista"))
         ((not (listp fields)) (error "`fields` non è una lista"))
         ((not (listp methods)) (error "`methods` non è una lista"))
         ((or (null classname)
              (not (symbolp classname))) (error "`classname` non è un simbolo")))
+
+  ;; Aggiunge la coppia `classname` e classe in forma di lista
+  ;; all'hash-table
   (add-class-spec classname (setf (symbol-value classname)
                                  (make-class parents fields methods)))
+  ;; e restituisce il nome della classe
   classname)
 #+end_src
 
@@ -76,3 +74,62 @@
 (defun class-spec (name)
   (gethash name *classes-specs*))
 #+end_src
+
+** Creazione della classe in formato lista
+#+begin_src lisp :tangle ool.lisp
+(defun make-class (parents fields methods)
+  (inherit (list :parents parents
+                    :fields (cdr fields)
+                    :methods (cdr methods)) parents))
+#+end_src
+
+*** Ereditazione dai genitori
+#+begin_src lisp :tangle ool.lisp
+(defun inherit (class parents)
+  (if (null parents)
+      class
+      (inherit (merge-class class (class-spec (car parents)))
+               (cdr parents))))
+
+(defun merge-class (child super)
+  (list :parents (merge-parents (getf super :parents)
+                                (getf child :parents))
+        :fields (merge-parts (getf super :fields)
+                              (getf child :fields))
+        :methods (merge-parts (getf super :methods)
+                               (getf child :methods))))
+#+end_src
+
+**** Merge dei genitori delle superclassi con quelli della classe figlio
+#+begin_src lisp :tangle ool.lisp
+(defun merge-parents (super-parents child-parent)
+  (if (null super-parents)
+      child-parent
+
+      ;; Se il genitore di `super` corrente NON è un membro
+      ;; della lista dei genitore del figlio
+      (if (not (member (car super-parents) child-parent))
+         ;; fai una chiamata ricorsiva aggiungendolo ai genitori del figlio
+          (merge-parents (cdr super-parents) (cons (car super-parents) child-parent))
+         ;; altrimenti vai al prossimo senza aggiungerlo
+          (merge-parents (cdr super-parents) child-parent))))
+#+end_src
+
+**** Merge field/method dei genitori con quelli della classe figlio
+#+begin_src lisp :tangle ool.lisp
+(defun merge-parts (parent-fields class-fields)
+  (if (null parent-fields)
+      class-fields
+      (if (not (field-name-exists (first (car parent-fields)) class-fields))
+          (merge-parts (cdr parent-fields) (cons (car parent-fields) class-fields))
+          (merge-parts (cdr parent-fields) class-fields))))
+
+;; È necessaria questa funzione in quanto i field sono a loro volta
+;; liste (name value &optional type) ma è di fatto lo stesso
+;; comportamento di `member`
+(defun field-name-exists (name fields)
+  (if (null fields)
+      nil
+      (or (equal name (first (first fields)))
+          (field-name-exists name (rest fields)))))
+#+end_src

diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp
index a5ce16286536e555c8f96db6ecc36a9061fe7f83..44a05e2adcbc2eeba38541a99491f20bd6af0778 100644 (file)
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -2,19 +2,17 @@
 ;;;; <eventuali collaborazioni>
 
 (defun def-class (classname parents &optional (fields nil) (methods nil))
-  (defun make-class (parents fields methods)
-    (let ((class (list :parents parents
-                      :fields (cdr fields)
-                      :methods (cdr methods))))
-      (if (null parents) class (inherit class parents))))
-
   (cond ((not (listp parents)) (error "`parents` non è una lista"))
         ((not (listp fields)) (error "`fields` non è una lista"))
         ((not (listp methods)) (error "`methods` non è una lista"))
         ((or (null classname)
              (not (symbolp classname))) (error "`classname` non è un simbolo")))
+
+  ;; Aggiunge la coppia `classname` e classe in forma di lista
+  ;; all'hash-table
   (add-class-spec classname (setf (symbol-value classname)
                                  (make-class parents fields methods)))
+  ;; e restituisce il nome della classe
   classname)
 
 
@@ -30,3 +28,50 @@
 
 (defun class-spec (name)
   (gethash name *classes-specs*))
+
+(defun make-class (parents fields methods)
+  (inherit (list :parents parents
+                    :fields (cdr fields)
+                    :methods (cdr methods)) parents))
+
+(defun inherit (class parents)
+  (if (null parents)
+      class
+      (inherit (merge-class class (class-spec (car parents)))
+               (cdr parents))))
+
+(defun merge-class (child super)
+  (list :parents (merge-parents (getf super :parents)
+                                (getf child :parents))
+        :fields (merge-parts (getf super :fields)
+                              (getf child :fields))
+        :methods (merge-parts (getf super :methods)
+                               (getf child :methods))))
+
+(defun merge-parents (super-parents child-parent)
+  (if (null super-parents)
+      child-parent
+
+      ;; Se il genitore di `super` corrente NON è un membro
+      ;; della lista dei genitore del figlio
+      (if (not (member (car super-parents) child-parent))
+         ;; fai una chiamata ricorsiva aggiungendolo ai genitori del figlio
+          (merge-parents (cdr super-parents) (cons (car super-parents) child-parent))
+         ;; altrimenti vai al prossimo senza aggiungerlo
+          (merge-parents (cdr super-parents) child-parent))))
+
+(defun merge-parts (parent-fields class-fields)
+  (if (null parent-fields)
+      class-fields
+      (if (not (field-name-exists (first (car parent-fields)) class-fields))
+          (merge-parts (cdr parent-fields) (cons (car parent-fields) class-fields))
+          (merge-parts (cdr parent-fields) class-fields))))
+
+;; È necessaria questa funzione in quanto i field sono a loro volta
+;; liste (name value &optional type) ma è di fatto lo stesso
+;; comportamento di `member`
+(defun field-name-exists (name fields)
+  (if (null fields)
+      nil
+      (or (equal name (first (first fields)))
+          (field-name-exists name (rest fields)))))