From: LeonardoBizzoni <leo2002714@gmail.com>
Date: Mon, 1 Jan 2024 07:32:23 +0000 (+0100)
Subject: controllo dei tipi sulle classi
X-Git-Url: http://git.leonardobizzoni.com/?a=commitdiff_plain;h=fd6fc242418d8f308ce6750af33d121b66c571f3;p=ObjectOriented-Prolog-Lisp

controllo dei tipi sulle classi

Dato che per ora non ci sono istanze ho usato `is-class` sul valore ma
sarà sicuramente da sostituire con `is-instance` quando ci sarà la
funzione `make`
---

diff --git a/Lisp/README.org b/Lisp/README.org
index 9d25577..4d017cb 100644
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -20,12 +20,14 @@
         ((not (listp methods)) (error "`methods` non è una lista"))
         ((or (null classname)
              (not (symbolp classname))) (error "'~A' non è un simbolo"
-					             classname)))
+					             classname))
+ 	      ((is-class classname)
+	       (error "'~A' è una classe già definita" classname)))
 
   ;; 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)))
+				  (make-class classname parents fields methods)))
   ;; e restituisce il nome della classe
   classname)
 #+end_src
@@ -78,7 +80,7 @@
 
 ** Creazione della classe in formato lista
 #+begin_src lisp :tangle ool.lisp
-(defun make-class (parents fields methods)
+(defun make-class (classname parents fields methods)
   (unless (null fields)
     (unless (equal (car fields) 'fields)
       (error "Il primo argomento della lista di fields ~S"
@@ -89,7 +91,8 @@
              "deve essere il simbolo 'methods'")))
 
   (type-check-fields (cdr fields))
-  (inherit (list :type 'class
+  (inherit (list :classname classname
+	             :type 'class
 		     :parents parents
 		     :fields (cdr fields)
 		     :methods (cdr methods)) parents))
@@ -106,7 +109,8 @@
             (error "`~A` non è una classe" (car parents)))))
 
 (defun merge-class (child super)
-  (list :type 'class
+  (list :classname (getf child :classname)
+        :type 'class
         :parents (merge-parents (getf super :parents)
                                 (getf child :parents))
         :fields (merge-parts (getf super :fields)
@@ -180,5 +184,13 @@
 		      "o una coppia (name value)"))))
 
 (defun type-check (value type)
-  (unless (typep value type) (error "~A non è di tipo ~A" value type)))
+  (if (is-class type)
+    (if (is-class value) ;; probabilmente da cambiare in `is-instance`
+	  (if (equal (getf (class-spec type) :classname)
+		     (getf (class-spec value) :classname))
+	    t
+	    (unless (member type (getf (class-spec value) :parents))
+	      (error "'~A' non è di tipo '~A'" value type)))
+	  (unless (null value) (error "'~A' non è di tipo '~A'" value type)))
+    (unless (typep value type) (error "~A non è di tipo ~A" value type))))
 #+end_src
diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp
index 2189110..902124f 100644
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -7,12 +7,14 @@
         ((not (listp methods)) (error "`methods` non è una lista"))
         ((or (null classname)
              (not (symbolp classname))) (error "'~A' non è un simbolo"
-					             classname)))
+					             classname))
+ 	      ((is-class classname)
+	       (error "'~A' è una classe già definita" classname)))
 
   ;; 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)))
+				  (make-class classname parents fields methods)))
   ;; e restituisce il nome della classe
   classname)
 
@@ -30,7 +32,7 @@
 (defun class-spec (name)
   (gethash name *classes-specs*))
 
-(defun make-class (parents fields methods)
+(defun make-class (classname parents fields methods)
   (unless (null fields)
     (unless (equal (car fields) 'fields)
       (error "Il primo argomento della lista di fields ~S"
@@ -41,7 +43,8 @@
              "deve essere il simbolo 'methods'")))
 
   (type-check-fields (cdr fields))
-  (inherit (list :type 'class
+  (inherit (list :classname classname
+	             :type 'class
 		     :parents parents
 		     :fields (cdr fields)
 		     :methods (cdr methods)) parents))
@@ -55,7 +58,8 @@
             (error "`~A` non è una classe" (car parents)))))
 
 (defun merge-class (child super)
-  (list :type 'class
+  (list :classname (getf child :classname)
+        :type 'class
         :parents (merge-parents (getf super :parents)
                                 (getf child :parents))
         :fields (merge-parts (getf super :fields)
@@ -117,4 +121,12 @@
 		      "o una coppia (name value)"))))
 
 (defun type-check (value type)
-  (unless (typep value type) (error "~A non è di tipo ~A" value type)))
+  (if (is-class type)
+    (if (is-class value) ;; probabilmente da cambiare in `is-instance`
+	  (if (equal (getf (class-spec type) :classname)
+		     (getf (class-spec value) :classname))
+	    t
+	    (unless (member type (getf (class-spec value) :parents))
+	      (error "'~A' non è di tipo '~A'" value type)))
+	  (unless (null value) (error "'~A' non è di tipo '~A'" value type)))
+    (unless (typep value type) (error "~A non è di tipo ~A" value type))))