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 9d25577dbe65814ef8f453a03e9438e07d206b70..4d017cb2a74aa51504f323d3d76ded8fc82b864d 100644 (file)
--- 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 218911099db78ebbfbb147a925f65ca9b21d38d3..902124f7816e389d5b15ee339bd28259d37a279e 100644 (file)
--- 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))))