From 82d9a5afa8592456fe848106a9957d8d5ed2ac22 Mon Sep 17 00:00:00 2001 From: LeonardoBizzoni Date: Wed, 3 Jan 2024 09:40:28 +0100 Subject: [PATCH] Fixato `is-instance` MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit `class-name` doveva essere un parametro opzionale con default `t`. Mancavano anche i controlli per dire che `instance` è una sottoclasse --- Lisp/README.org | 23 ++++++++++++--------- Lisp/ool.lisp | 55 ++++++++++++++++++++++++++----------------------- 2 files changed, 42 insertions(+), 36 deletions(-) diff --git a/Lisp/README.org b/Lisp/README.org index d5da2c9..37430e9 100644 --- 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 55c4aa3..71e780f 100644 --- a/Lisp/ool.lisp +++ b/Lisp/ool.lisp @@ -2,14 +2,14 @@ ;;;; (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)))) -- 2.52.0