From: LeonardoBizzoni Date: Sun, 31 Dec 2023 10:34:08 +0000 (+0100) Subject: Controllo dei tipi base X-Git-Url: http://git.leonardobizzoni.com/?a=commitdiff_plain;h=5534861a058ee7bb5e3ec7e6a52d6ac5ece28d5a;p=ObjectOriented-Prolog-Lisp Controllo dei tipi base --- diff --git a/Lisp/README.org b/Lisp/README.org index 09c83d8..9d25577 100644 --- 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 3d87ac4..2189110 100644 --- 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)))