Final version of mydefstruct
This commit is contained in:
parent
24a7d9b46b
commit
e5bbbd6201
@ -1,3 +1,8 @@
|
|||||||
|
(defpackage :my-structures
|
||||||
|
(:use :cl)
|
||||||
|
(:export #:mydefstruct))
|
||||||
|
|
||||||
|
(in-package :my-structures)
|
||||||
|
|
||||||
(defun constructor-name (sym)
|
(defun constructor-name (sym)
|
||||||
(intern (concatenate 'string "MAKE-" (string sym))))
|
(intern (concatenate 'string "MAKE-" (string sym))))
|
||||||
@ -8,19 +13,31 @@
|
|||||||
(defun setter-name (name sym)
|
(defun setter-name (name sym)
|
||||||
(intern (concatenate 'string "SET-" (string name) "-" (string sym))))
|
(intern (concatenate 'string "SET-" (string name) "-" (string sym))))
|
||||||
|
|
||||||
|
(defun obj-type (obj)
|
||||||
|
(car obj))
|
||||||
|
|
||||||
|
(defun make-error-message (real expected)
|
||||||
|
(format nil "Accessor called on wrong type! Expected ~a but found ~a"
|
||||||
|
expected real))
|
||||||
|
|
||||||
|
|
||||||
(defun constructor (name slots)
|
(defun constructor (name slots)
|
||||||
`(defun ,(constructor-name name) ,slots
|
`(defun ,(constructor-name name) ,slots
|
||||||
(list ,@slots)))
|
(list ',name ,@slots)))
|
||||||
(defun accessors (name slots)
|
(defun accessors (name slots)
|
||||||
(loop for slot in slots
|
(loop for slot in slots
|
||||||
for i upfrom 0 collect
|
for i upfrom 1 collect
|
||||||
`(defun ,(accessor-name name slot) (obj)
|
`(defun ,(accessor-name name slot) (obj)
|
||||||
(nth ,i obj))))
|
(if (eql (obj-type obj) ',name)
|
||||||
|
(nth ,i obj)
|
||||||
|
(error (make-error-message (obj-type obj) ',name))))))
|
||||||
(defun setters (name slots)
|
(defun setters (name slots)
|
||||||
(loop for slot in slots
|
(loop for slot in slots
|
||||||
for i upfrom 0 collect
|
for i upfrom 1 collect
|
||||||
`(defun ,(setter-name name slot) (obj val)
|
`(defun ,(setter-name name slot) (obj val)
|
||||||
(setf (nth ,i obj) val))))
|
(if (eql (obj-type obj) ',name)
|
||||||
|
(setf (nth ,i obj) val)
|
||||||
|
(error (make-error-message (obj-type obj) ',name))))))
|
||||||
(defun setfers (name slots)
|
(defun setfers (name slots)
|
||||||
(loop for slot in slots collect
|
(loop for slot in slots collect
|
||||||
`(defsetf ,(accessor-name name slot)
|
`(defsetf ,(accessor-name name slot)
|
||||||
|
Loading…
x
Reference in New Issue
Block a user