fatta la `make`

diff --git a/Lisp/README.org b/Lisp/README.org
index 4d017cb2a74aa51504f323d3d76ded8fc82b864d..e510d36ced9971bb3a19e762436e4ba72de9e0a7 100644 (file)
--- a/Lisp/README.org
+++ b/Lisp/README.org
@@ -27,7 +27,10 @@
   ;; Aggiunge la coppia `classname` e classe in forma di lista
   ;; all'hash-table
   (add-class-spec classname (setf (symbol-value classname)
-                                 (make-class classname parents fields methods)))
+                                 (make-class classname
+                                             parents
+                                             fields
+                                             methods)))
   ;; e restituisce il nome della classe
   classname)
 #+end_src
@@ -41,6 +44,14 @@
 
 *** Implementazione
 #+begin_src lisp :tangle ool.lisp
+(defun make (classname &rest fields)
+  (unless (is-class classname)
+    (error "'~A' non è una classe" classname))
+
+  ((lambda (instance)
+     (setf (getf instance :type) 'object)
+     (create-instance instance fields))
+   (copy-list (class-spec classname))))
 #+end_src
 
 *** Esempio pratico
@@ -157,6 +168,42 @@
           (field-name-exists name (rest fields)))))
 #+end_src
 
+** Creazione di un'istanza
+#+begin_src lisp :tangle ool.lisp
+(defun create-instance (listclass new-fields)
+  ;; 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)))
+    (error "Non esiste il field `~A` in '~A'"
+          (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)))))
+
+(defun set-instance-field (instance name value)
+  ;; `setf` modifica in-place
+  (setf (getf instance :fields)
+       (set-field (getf instance :fields) name value))
+
+  ;; quindi serve resistuire `instance`
+  instance)
+
+(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)))))
+#+end_src
+
 ** Stabilire se un simbolo è una classe
 #+begin_src lisp :tangle ool.lisp
 (defun is-class (name)

diff --git a/Lisp/ool.lisp b/Lisp/ool.lisp
index 902124f7816e389d5b15ee339bd28259d37a279e..f1878c79d0e63d030353713dd1f101483f1c6194 100644 (file)
--- a/Lisp/ool.lisp
+++ b/Lisp/ool.lisp
@@ -14,11 +14,21 @@
   ;; Aggiunge la coppia `classname` e classe in forma di lista
   ;; all'hash-table
   (add-class-spec classname (setf (symbol-value classname)
-                                 (make-class classname parents fields methods)))
+                                 (make-class classname
+                                             parents
+                                             fields
+                                             methods)))
   ;; e restituisce il nome della classe
   classname)
 
+(defun make (classname &rest fields)
+  (unless (is-class classname)
+    (error "'~A' non è una classe" classname))
 
+  ((lambda (instance)
+     (setf (getf instance :type) 'object)
+     (create-instance instance fields))
+   (copy-list (class-spec classname))))
 
 
 
@@ -99,6 +109,39 @@
       (or (equal 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
+  (unless (or (null new-fields)
+             (field-name-exists (car new-fields)
+                                (getf listclass :fields)))
+    (error "Non esiste il field `~A` in '~A'"
+          (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)))))
+
+(defun set-instance-field (instance name value)
+  ;; `setf` modifica in-place
+  (setf (getf instance :fields)
+       (set-field (getf instance :fields) name value))
+
+  ;; quindi serve resistuire `instance`
+  instance)
+
+(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)))))
+
 (defun is-class (name)
   (if (equal (getf (class-spec name) :type) 'class)
       (class-spec name)