Final version of mydefstruct
This commit is contained in:
		@@ -1,3 +1,8 @@
 | 
			
		||||
(defpackage :my-structures
 | 
			
		||||
  (:use :cl)
 | 
			
		||||
  (:export #:mydefstruct))
 | 
			
		||||
 | 
			
		||||
(in-package :my-structures)
 | 
			
		||||
 | 
			
		||||
(defun constructor-name (sym)
 | 
			
		||||
  (intern (concatenate 'string "MAKE-" (string sym))))
 | 
			
		||||
@@ -8,19 +13,31 @@
 | 
			
		||||
(defun setter-name (name 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 name) ,slots
 | 
			
		||||
     (list ,@slots)))
 | 
			
		||||
     (list ',name ,@slots)))
 | 
			
		||||
(defun accessors (name slots)
 | 
			
		||||
  (loop for slot in slots
 | 
			
		||||
	for i upfrom 0 collect
 | 
			
		||||
	for i upfrom 1 collect
 | 
			
		||||
	`(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)
 | 
			
		||||
  (loop for slot in slots
 | 
			
		||||
	for i upfrom 0 collect
 | 
			
		||||
	for i upfrom 1 collect
 | 
			
		||||
	`(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)
 | 
			
		||||
  (loop for slot in slots collect
 | 
			
		||||
	`(defsetf ,(accessor-name name slot)
 | 
			
		||||
 
 | 
			
		||||
		Reference in New Issue
	
	Block a user