Fixato `is-instance`

`class-name` doveva essere un parametro opzionale con default `t`.
Mancavano anche i controlli per dire che `instance` è una sottoclasse

diff --git a/Lisp/README.org b/Lisp/README.org
index d5da2c9db23cf4f0caf505ebee105c108f2b5659..37430e96ad3a9e45868c116027348118c50d8dc0 100644 (file)
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -76,18 +76,18 @@
 #+begin_src lisp :tangle ool.lisp
 (defun field (instance field-name)
   (unless (listp instance)
-    (error "~A non è un instanza") instance)
+    (error "~A non è un instanza" instance))
   (field-helper (getf instance :fields) field-name))
 
 (defun field-helper (fields field-name)
   (cond ((null fields) nil)
-       ((eq (caar fields) field-name) (cadar fields))
-       (T (field-helper (cdr fields) field-name))))
+             ((eq (caar fields) field-name) (cadar fields))
+             (t (field-helper (cdr fields) field-name))))
 #+end_src
 
 *** Esempio pratico
 
-** fields
+** field*
 *** Definizione
 
 
@@ -95,8 +95,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
@@ -238,10 +238,13 @@
 
 ** Controlla se il simbolo passato è un'instance della class
 #+begin_src lisp :tangle ool.lisp
-(defun is-instance (instance class-name)
-  (if (eq (getf instance :classname) class-name)
-      T
-      NIL))
+(defun is-instance (instance &optional (class-name t))
+  (if (eq class-name t)
+      (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))))
 #+end_src
 
 ** Controllo tipo valore

diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp
index 55c4aa36fb841430d3099fba5ad20faceeb02007..71e780fa4d913d3b2ea9a4db6cbce3235b0f74dc 100644 (file)
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -2,14 +2,14 @@
 ;;;; <eventuali collaborazioni>
 
 (defun def-class (classname parents &optional (fields nil) (methods nil))
-  (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"))
+  (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 "'~A' non è un simbolo"
+             (not (symbolp classname))) (error "'~A' non è un simbolo"
                                                     classname))
              ((is-class classname)
-              (error "'~A' è una classe già definita" classname)))
+              (error "'~A' è una classe già definita" classname)))
 
   ;; Aggiunge la coppia `classname` e classe in forma di lista
   ;; all'hash-table
@@ -23,7 +23,7 @@
 
 (defun make (classname &rest fields)
   (unless (is-class classname)
-    (error "'~A' non è una classe" classname))
+    (error "'~A' non è una classe" classname))
 
   ((lambda (instance)
      (setf (getf instance :type) 'object)
@@ -32,18 +32,18 @@
 
 (defun field (instance field-name)
   (unless (listp instance)
-    (error "~A non è un instanza") instance)
+    (error "~A non è un instanza" instance))
   (field-helper (getf instance :fields) field-name))
 
 (defun field-helper (fields field-name)
   (cond ((null fields) nil)
-       ((eq (caar fields) field-name) (cadar fields))
-       (T (field-helper (cdr fields) field-name))))
+             ((eq (caar fields) field-name) (cadar fields))
+             (t (field-helper (cdr fields) field-name))))
 
 (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)))))
 
 (defparameter *classes-specs* (make-hash-table))
 
@@ -76,7 +76,7 @@
       (if (is-class (car parents))
                  (inherit (merge-class class (class-spec (car parents)))
                           (cdr parents))
-            (error "`~A` non è una classe" (car parents)))))
+            (error "`~A` non è una classe" (car parents)))))
 
 (defun merge-class (child super)
   (list :classname (getf child :classname)
@@ -92,7 +92,7 @@
   (if (null super-parents)
       child-parent
 
-      ;; Se il genitore di `super` corrente NON è un membro
+      ;; 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
@@ -111,8 +111,8 @@
                        (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
+;; È 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)
@@ -121,8 +121,8 @@
           (field-name-exists name (rest fields)))))
 
 (defun create-instance (listclass new-fields)
-  ;; Se c'è almeno un field da cambiare
-  ;; il cui nome non è una proprietà della classe
+  ;; 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)))
@@ -158,10 +158,13 @@
       (class-spec name)
       nil))
 
-(defun is-instance (instance class-name)
-  (if (eq (getf instance :classname) class-name)
-      T
-      NIL))
+(defun is-instance (instance &optional (class-name t))
+  (if (eq class-name t)
+      (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)
   (cond ((null fields) nil)
@@ -171,12 +174,12 @@
 
 (defun type-check-field (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 terna (name value type)"
                      "o una coppia (name value)"))))
 
 (defun type-check (value type)
@@ -186,6 +189,6 @@
                     (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))))
+             (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))))