From: kier-mirko <mirkotolentino1@gmail.com>
Date: Tue, 2 Jan 2024 15:19:39 +0000 (+0100)
Subject: Aggiunto qualche esempio e modificato parametri di field*
X-Git-Url: http://git.leonardobizzoni.com/?a=commitdiff_plain;h=dcc4541f41cd20aafd59808271dc369dcf22cb3e;p=ObjectOriented-Prolog-Lisp

Aggiunto qualche esempio e modificato parametri di field*
---

diff --git a/Lisp/README.org b/Lisp/README.org
index c2eec8c..e97c4f0 100644
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -36,7 +36,16 @@
 #+end_src
 
 *** Esempio pratico
-
+#+begin_src lisp
+(def-class 'foo nil
+  '(fields (foo 42))
+  '(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)))))
+#+end_src
 
 ** make
 *** Definizione
@@ -55,7 +64,10 @@
 #+end_src
 
 *** Esempio pratico
-
+#+begin_src lisp
+(defparameter f (make 'foo))
+(defparameter b (make 'bar 'bar "69"))
+#+end_src
 
 ** field
 *** Definizione
@@ -79,7 +91,7 @@
 
 *** Implementazione
 #+begin_src lisp :tangle ool.lisp
-(defun field* (instance fields)
+(defun field* (instance &rest fields)
   (cond ((null fields) nil)
 	((null (cdr fields)) (field instance (car fields)))
 	((null (field instance (car fields))) nil)
diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp
index 72fb14a..c001367 100644
--- 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)
@@ -38,7 +38,7 @@
 	((eq (caar fields) field-name) (cadar fields))
 	(T (field-helper (cdr fields) field-name))))
 
-(defun field* (instance fields)
+(defun field* (instance &rest fields)
   (cond ((null fields) nil)
 	((null (cdr fields)) (field instance (car fields)))
 	((null (field instance (car fields))) nil)
@@ -75,7 +75,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)
@@ -91,7 +91,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
@@ -110,18 +110,18 @@
                        (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)
       nil
-      (or (equal name (first (first fields)))
+      (or (eq name (first (first fields)))
           (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)))
@@ -170,12 +170,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)
@@ -185,6 +185,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))))