Tagliato tutto <80 colonne e fixato type-checks in make

diff --git a/Lisp/README.org b/Lisp/README.org
index 3dbd1bb92734e18642f6d2aa53bea96dea8562ba..bba23141ed56bc2db67cbde4ae574b8e78888d01 100644 (file)
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -1,5 +1,7 @@
 #+title: 🔥 OOΛ in Common Lisp 🔥
-#+author: Bizzoni Leonardo (899629), Barone Matteo(894594), Kier Mirko Tolentino(899728)
+#+author: Bizzoni Leonardo (899629)
+#+author: Barone Matteo(894594)
+#+author: Kier Mirko Tolentino(899728)
 
 * Breve descrizione
 42
@@ -20,9 +22,9 @@
         ((not (listp methods)) (error "`methods` non è una lista"))
         ((or (null classname)
              (not (symbolp classname))) (error "'~A' non è un simbolo"
-                                                    classname))
-             ((is-class classname)
-              (error "'~A' è una classe già definita" 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
@@ -39,12 +41,15 @@
 #+begin_src lisp
 (def-class 'foo nil
   '(fields (foo 42))
-  '(methods (foo (number)
-            (format "Sum: ~D~%" (+ number (field this 'foo))))))
+  '(methods
+    (foo (number)
+     (format "Sum: ~D~%" (+ number (field this 'foo))))))
 
 (def-class 'bar nil
   '(fields (bar "42"))
-  '(methods (foo nil (format "Favourite number is ~D~%" field(this 'bar)))))
+  '(methods
+    (foo ()
+     (format "Favourite number is ~D~%" field(this 'bar)))))
 #+end_src
 
 ** make
@@ -66,7 +71,7 @@
 *** Esempio pratico
 #+begin_src lisp
 (defparameter f (make 'foo))
-(defparameter b (make 'bar 'bar "69"))
+(defparameter b (make 'bar 'bar "42"))
 #+end_src
 
 ** field
@@ -81,8 +86,11 @@
 
 (defun field-helper (fields field-name)
   (cond ((null fields) nil)
-             ((eq (caar fields) field-name) (cadar fields))
-             (t (field-helper (cdr fields) field-name))))
+       ;; Se sono uguali il primo elemento della prima lista di `fields`
+       ;; ed il nome del field restituisci il secondo
+        ;; elemento della prima lista di `fields`
+       ((eq (caar fields) field-name) (cadar fields))
+       (t (field-helper (cdr fields) field-name))))
 #+end_src
 
 *** Esempio pratico
@@ -95,8 +103,8 @@
 #+begin_src lisp :tangle ool.lisp
 (defun field* (instance &rest fields)
   (cond ((null fields) nil)
-             ((null (cdr fields)) (field instance (car fields)))
-             (t (field* (field instance (car fields)) (cdr fields)))))
+       ((null (cdr fields)) (field instance (car fields)))
+       (t (field* (field instance (car fields)) (cdr fields)))))
 #+end_src
 
 *** Esempio pratico
@@ -120,18 +128,21 @@
     (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'")))
 
-  (create-methods classname (cdr methods))
-  (type-check-fields (cdr fields))
-  (inherit (list :classname classname
-                    :type 'class
-                    :parents parents
-                    :fields (cdr fields)
-                    :methods (cdr methods)) parents))
+  (define-methods (cdr methods))
+  (validate-fields-type (cdr fields))
+  (inherit
+   (list :classname classname
+        :type 'class
+        :parents parents
+        :fields (cdr fields)
+        :methods (cdr methods))
+   parents))
 #+end_src
 
 *** Ereditazione dai genitori
@@ -140,9 +151,9 @@
   (if (null parents)
       class
       (if (is-class (car parents))
-                 (inherit (merge-class class (class-spec (car parents)))
-                          (cdr parents))
-            (error "`~A` non è una classe" (car parents)))))
+         (inherit (merge-class class (class-spec (car parents)))
+                  (cdr parents))
+          (error "`~A` non è una classe" (car parents)))))
 
 (defun merge-class (child super)
   (list :classname (getf child :classname)
@@ -195,16 +206,22 @@
 
 *** Creazione di metodi
 #+begin_src lisp :tangle ool.lisp
-(defun create-methods (classname methods)
+(defun define-methods (methods)
+  ;; Per ogni metodi
   (mapcar
    (lambda (method)
+     ;; definisci una funzione
      (setf (symbol-function (first method))
-           (lambda (this &rest args)
-               (unless (is-instance this)
-                 (error "~A non è un'istanza" this))
-               (unless (get-method (getf this :methods) (first method))
-                 (error "~A non ha un metodo ~A" (getf this :classname) (first method)))
-              (apply (get-body this (first method)) (append (list this) args)))))
+          ;; con primo argomento l'istanza su cui chiamare il metodo
+          ;; e gli altri argomenti del metodo
+          (lambda (this &rest args)
+            (unless (is-instance this)
+              (error "~A non è un'istanza" this))
+            (unless (get-method (getf this :methods) (first method))
+              (error "~A non ha un metodo ~A"
+                     (getf this :classname) (first method)))
+            (apply (get-method-body this (first method))
+                   (append (list this) args)))))
    methods))
 
 
@@ -212,15 +229,14 @@
   (cond ((null methods) nil)
        ((eq (caar methods) name) (car methods))
         (t (get-method (cdr methods) name))))
-#+end_src
 
-*** Get Body
-#+begin_src lisp :tangle ool.lisp
-(defun get-body (this method-name)
+(defun get-method-body (this method-name)
   (eval
    (append
     (list 'lambda
-         (append '(this) (cadr (get-method (getf this :methods) method-name))))
+         (append
+          '(this)
+          (cadr (get-method (getf this :methods) method-name))))
     (cddr
      (get-method (getf this :methods) method-name)))))
 #+end_src
@@ -255,10 +271,11 @@
 
 (defun set-field (fields name value)
   (cond ((null fields) nil)
-           ((equal (first (car fields)) name)
-              (cons (list (first (car fields)) value) (cdr fields)))
-           (t (append (list (car fields))
-                      (set-field (cdr fields) name value)))))
+       ((equal (first (car fields)) name)
+        (type-check-field (car fields) value)
+        (cons (list (first (car fields)) value) (cdr fields)))
+       (t (append (list (car fields))
+                  (set-field (cdr fields) name value)))))
 #+end_src
 
 ** Stabilire se un simbolo è una classe
@@ -273,7 +290,10 @@
 #+begin_src lisp :tangle ool.lisp
 (defun is-instance (instance &optional (class-name t))
   (if (eq class-name t)
-      (and (listp instance) (eq (getf instance :type) 'object))
+      (or (null instance)
+          (and (listp instance)
+              (eq (getf instance :type) 'object)))
+
       (and (listp instance)
            (or (eq (getf instance :classname) class-name)
                (member class-name (getf instance :parents)))
@@ -282,30 +302,35 @@
 
 ** Controllo tipo valore
 #+begin_src lisp :tangle ool.lisp
-(defun type-check-fields (fields)
+(defun validate-fields-type (fields)
   (cond ((null fields) nil)
-           (t (type-check-field (car fields))
-           (type-check-fields (cdr fields)))))
+       (t (validate-field-type (car fields))
+           (validate-fields-type (cdr fields)))))
 
-
-(defun type-check-field (field)
+(defun validate-field-type (field)
   (unless (listp field)
-    (error "~S ~S" "Un field di un classe o è una terna (name value type)"
+    (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)"))))
+
+  (cond
+    ;; Se non c'è un tipo allora
+    ;; non è necessario controllare il tipo del valore
+    ((= (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-field (field value)
+  (if (eq (length field) 2)
+      t
+      (type-check value (third field))))
 
 (defun type-check (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))))
+      (if (is-instance value type)
+         t
+         (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 dcfbd287fef92f1ee71939032a47e9de8aea7aeb..7d680249692fad358dc98e45b7594887837d11d8 100644 (file)
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -37,6 +37,9 @@
 
 (defun field-helper (fields field-name)
   (cond ((null fields) nil)
+             ;; Se sono uguali il primo elemento della prima lista di `fields`
+             ;; ed il nome del field restituisci il secondo
+        ;; elemento della prima lista di `fields`
              ((eq (caar fields) field-name) (cadar fields))
              (t (field-helper (cdr fields) field-name))))
 
@@ -58,18 +61,21 @@
     (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'")))
 
-  (create-methods classname (cdr methods))
-  (type-check-fields (cdr fields))
-  (inherit (list :classname classname
-                    :type 'class
-                    :parents parents
-                    :fields (cdr fields)
-                    :methods (cdr methods)) parents))
+  (define-methods (cdr methods))
+  (validate-fields-type (cdr fields))
+  (inherit
+      (list :classname classname
+               :type 'class
+               :parents parents
+               :fields (cdr fields)
+               :methods (cdr methods))
+      parents))
 
 (defun inherit (class parents)
   (if (null parents)
@@ -121,16 +127,22 @@
       (or (equal name (first (first fields)))
           (field-name-exists name (rest fields)))))
 
-(defun create-methods (classname methods)
+(defun define-methods (methods)
+  ;; Per ogni metodi
   (mapcar
    (lambda (method)
+     ;; definisci una funzione
      (setf (symbol-function (first method))
-           (lambda (this &rest args)
-               (unless (is-instance this)
-                 (error "~A non è un'istanza" this))
-               (unless (get-method (getf this :methods) (first method))
-                 (error "~A non ha un metodo ~A" (getf this :classname) (first method)))
-              (apply (get-body this (first method)) (append (list this) args)))))
+              ;; con primo argomento l'istanza su cui chiamare il metodo
+              ;; e gli altri argomenti del metodo
+              (lambda (this &rest args)
+                (unless (is-instance this)
+                  (error "~A non è un'istanza" this))
+                (unless (get-method (getf this :methods) (first method))
+                  (error "~A non ha un metodo ~A"
+                         (getf this :classname) (first method)))
+                (apply (get-method-body this (first method))
+                       (append (list this) args)))))
    methods))
 
 
@@ -139,11 +151,13 @@
        ((eq (caar methods) name) (car methods))
         (t (get-method (cdr methods) name))))
 
-(defun get-body (this method-name)
+(defun get-method-body (this method-name)
   (eval
    (append
     (list 'lambda
-         (append '(this) (cadr (get-method (getf this :methods) method-name))))
+         (append
+          '(this)
+          (cadr (get-method (getf this :methods) method-name))))
     (cddr
      (get-method (getf this :methods) method-name)))))
 
@@ -151,19 +165,19 @@
   ;; Se c'è almeno un field da cambiare
   ;; il cui nome non è una proprietà della classe
   (unless (or (null new-fields)
-             (field-name-exists (car new-fields)
-                                (getf listclass :fields)))
+                 (field-name-exists (car new-fields)
+                                    (getf listclass :fields)))
     (error "Non esiste il field `~A` in '~A'"
-          (car new-fields)
-          (getf listclass :classname)))
+              (car new-fields)
+              (getf listclass :classname)))
 
   (if (null new-fields)
       listclass
       (create-instance
-       (set-instance-field listclass
-                          (first new-fields)   ;; nome del field
-                          (second new-fields)) ;; nuovo valore
-       (cdr (cdr new-fields)))))
+          (set-instance-field listclass
+                                 (first new-fields)   ;; nome del field
+                                 (second new-fields)) ;; nuovo valore
+          (cdr (cdr new-fields)))))
 
 (defun set-instance-field (instance name value)
   ;; `setf` modifica in-place
@@ -176,7 +190,8 @@
 (defun set-field (fields name value)
   (cond ((null fields) nil)
            ((equal (first (car fields)) name)
-              (cons (list (first (car fields)) value) (cdr fields)))
+                (type-check-field (car fields) value)
+                (cons (list (first (car fields)) value) (cdr fields)))
            (t (append (list (car fields))
                       (set-field (cdr fields) name value)))))
 
@@ -187,35 +202,43 @@
 
 (defun is-instance (instance &optional (class-name t))
   (if (eq class-name t)
-      (and (listp instance) (eq (getf instance :type) 'object))
+      (or (null instance)
+          (and (listp instance)
+                  (eq (getf instance :type) 'object)))
+
       (and (listp instance)
            (or (eq (getf instance :classname) class-name)
                (member class-name (getf instance :parents)))
            (eq (getf instance :type) 'object))))
 
-(defun type-check-fields (fields)
+(defun validate-fields-type (fields)
   (cond ((null fields) nil)
-           (t (type-check-field (car fields))
-           (type-check-fields (cdr fields)))))
-
+           (t (validate-field-type (car fields))
+           (validate-fields-type (cdr fields)))))
 
-(defun type-check-field (field)
+(defun validate-field-type (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)"))))
+    (error "~S ~S"
+              "Un field di un classe o è una terna (name value type)"
+              "o una coppia (name value)"))
+
+  (cond
+    ;; Se non c'è un tipo allora
+    ;; non è necessario controllare il tipo del valore
+    ((= (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-field (field value)
+  (if (eq (length field) 2)
+      t
+      (type-check value (third field))))
 
 (defun type-check (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))))
+      (if (is-instance value type)
+             t
+             (error "~A non è di tipo ~A" value type))
+      (unless (typep value type) (error "~A non è di tipo ~A" value type))))