From 4dc39fbd8f90581646fc558ff5fa59c2b8036149 Mon Sep 17 00:00:00 2001 From: LeonardoBizzoni Date: Tue, 9 Jan 2024 12:56:04 +0100 Subject: [PATCH] Tagliato tutto <80 colonne e fixato type-checks in make --- Lisp/README.org | 141 ++++++++++++++++++++++++++++-------------------- Lisp/ool.lisp | 115 +++++++++++++++++++++++---------------- 2 files changed, 152 insertions(+), 104 deletions(-) diff --git a/Lisp/README.org b/Lisp/README.org index 3dbd1bb..bba2314 100644 --- 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 dcfbd28..7d68024 100644 --- 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)))) -- 2.52.0