Aggiunto qualche esempio e modificato parametri di field*

diff --git a/Lisp/README.org b/Lisp/README.org
index c2eec8c5c59368c618a85ba40ed3f828d766255d..e97c4f0b45aef5f549f6b20982dadf91ee592105 100644 (file)
--- 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 72fb14a368694e4b047d8a852467aa825f38994b..c00136723367ccc8fb832ce69fa00ae14c8fd745 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)
@@ -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))))