Controllo dei tipi base

diff --git a/Lisp/README.org b/Lisp/README.org
index 09c83d8e095cf0c69978a83b89f5113e93ca151d..9d25577dbe65814ef8f453a03e9438e07d206b70 100644 (file)
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -19,7 +19,8 @@
         ((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")))
+             (not (symbolp classname))) (error "'~A' non è un simbolo"
+                                                    classname)))
 
   ;; Aggiunge la coppia `classname` e classe in forma di lista
   ;; all'hash-table
@@ -78,6 +79,16 @@
 ** Creazione della classe in formato lista
 #+begin_src lisp :tangle ool.lisp
 (defun make-class (parents fields methods)
+  (unless (null fields)
+    (unless (equal (car fields) 'fields)
+      (error "Il primo argomento della lista di fields ~S"
+            "deve essere il simbolo 'fields'")))
+  (unless (null methods)
+    (unless (equal (car methods) 'methods)
+      (error "Il primo argomento della lista di methods ~S"
+             "deve essere il simbolo 'methods'")))
+
+  (type-check-fields (cdr fields))
   (inherit (list :type 'class
                     :parents parents
                     :fields (cdr fields)
@@ -113,8 +124,10 @@
       ;; 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))
+         ;; 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
@@ -124,8 +137,10 @@
 (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))
+      (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
@@ -145,3 +160,25 @@
       (class-spec name)
       nil))
 #+end_src
+
+** Controllo tipo valore
+#+begin_src lisp :tangle ool.lisp
+(defun type-check-fields (fields)
+  (cond ((null fields) nil)
+           (t (type-check-field (car fields))
+           (type-check-fields (cdr fields)))))
+
+
+(defun type-check-field (field)
+  (unless (listp field)
+    (error "~S ~S" "Un field di un classe o è una terna (name value type)"
+          "o una coppia (name value)"))
+  (cond ((= (length field) 2) t)
+           ((= (length field) 3) (type-check (second field) (third field)))
+           (t (error "Un field di un classe ~S ~S"
+                  "o è una terna (name value type)"
+                     "o una coppia (name value)"))))
+
+(defun type-check (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 3d87ac4b84de6026588a9314f85faacb69bd9317..218911099db78ebbfbb147a925f65ca9b21d38d3 100644 (file)
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -6,7 +6,8 @@
         ((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")))
+             (not (symbolp classname))) (error "'~A' non è un simbolo"
+                                                    classname)))
 
   ;; Aggiunge la coppia `classname` e classe in forma di lista
   ;; all'hash-table
@@ -30,6 +31,16 @@
   (gethash name *classes-specs*))
 
 (defun make-class (parents fields methods)
+  (unless (null fields)
+    (unless (equal (car fields) 'fields)
+      (error "Il primo argomento della lista di fields ~S"
+            "deve essere il simbolo 'fields'")))
+  (unless (null methods)
+    (unless (equal (car methods) 'methods)
+      (error "Il primo argomento della lista di methods ~S"
+             "deve essere il simbolo 'methods'")))
+
+  (type-check-fields (cdr fields))
   (inherit (list :type 'class
                     :parents parents
                     :fields (cdr fields)
@@ -59,16 +70,20 @@
       ;; 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))
+         ;; 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))
+      (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
@@ -84,3 +99,22 @@
   (if (equal (getf (class-spec name) :type) 'class)
       (class-spec name)
       nil))
+
+(defun type-check-fields (fields)
+  (cond ((null fields) nil)
+           (t (type-check-field (car fields))
+           (type-check-fields (cdr fields)))))
+
+
+(defun type-check-field (field)
+  (unless (listp field)
+    (error "~S ~S" "Un field di un classe o è una terna (name value type)"
+          "o una coppia (name value)"))
+  (cond ((= (length field) 2) t)
+           ((= (length field) 3) (type-check (second field) (third field)))
+           (t (error "Un field di un classe ~S ~S"
+                  "o è una terna (name value type)"
+                     "o una coppia (name value)"))))
+
+(defun type-check (value type)
+  (unless (typep value type) (error "~A non è di tipo ~A" value type)))