/
masd-structure.lisp
105 lines (81 loc) · 3.75 KB
/
masd-structure.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
(in-package #:masd)
(defun indiff-name (name)
(list name :accessor name
:initarg (make-keyword (symbol-name name))))
(defmacro slot-access-macro (name slot)
`(defmacro ,(intern (symbol-name (concatenate-symbol name '- slot)) (symbol-package name)) (,name)
`(slot-value ,,name ',',slot)))
(defmacro defclassi (name direct-superclasses &rest direct-slots)
`(defclass ,name ,direct-superclasses
,(iter (for s in direct-slots)
(collect (indiff-name s)))))
(defmacro defclassia (name direct-superclasses &rest direct-slots)
`(progn (defclassi ,name ,direct-superclasses ,@direct-slots)
(make-instance ',name) ;lehet nem segit semmit :O
,@(iterate:iter (iterate:for s in direct-slots)
(iterate:collect `(slot-access-macro ,name ,s)))))
(defun class-slots (name)
(remove-duplicates (apply #'append (mapcar #'sb-mop:class-slots (sb-mop:class-precedence-list (find-class name))))
:test #'equal))
(defun class-slot-names (name)
(mapcar #'sb-mop::slot-definition-name (class-slots name)))
(defun class-slot-names-keywords (name)
(mapcar #'make-keyword (class-slot-names name)))
(defun class-slot-first-initargs (name)
(remove-duplicates (mapcar #'car (mapcar #'sb-mop::slot-definition-initargs (class-slots name)))))
(defun class-slot-first-initargs-keywords (name)
(mapcar #'make-keyword (mapcar #'symbol-name (class-slot-first-initargs name))))
(defun make-instance-un (class &rest initargs)
(apply #'make-instance class (iter (for s in (class-slot-first-initargs-keywords class))
(appending (let ((v (getf initargs s)))
(if v
(list s v)
(list s nil)))))))
(defmacro make-instance-mun (class &rest initargs)
`(make-instance ,class ,@(iterate:iter (for s in (class-slot-first-initargs-keywords (eval class)))
(iterate:appending (let ((v (getf initargs s)))
(if v
(list s v)
(list s nil)))))))
(defun struct-slots (name)
(sb-mop:class-slots (find-class name)))
(defun struct-slot-names (name)
(mapcar #'sb-mop:slot-definition-name (struct-slots name)))
(defun struct-slot-name-keywords (name)
(mapcar #'make-keyword (struct-slot-names name)))
;; only for high-end
(defmacro struct-slot-names-m (name)
`(struct-slot-names-quoted ',name))
;; makes a copy - but the new given values are replaced
;; FIXME -> az instance-t nem csereli ki!! :O
;; egyszer megcsinalni!!!!
;; (defmacro copy-class (class instance &body new-slot-value-pairs)
;; (let
(defmacro diff-copy (type instance &body slot-new-value-pairs)
(let ((nn (mapcar (lambda (knv) (symbol-name (car knv))) (tupelize slot-new-value-pairs))))
(let ((on (set-difference (mapcar #'symbol-name (struct-slot-names-quoted type)) nn :test #'equal)))
(oncesyms (instance)
(append `(,(intern (interncase (concatenate 'string "make-" (symbol-name type)))))
(iter (for n in on)
(collect (make-keyword n))
(collect (list (intern (interncase (concatenate 'string (symbol-name type) "-" n)))
instance)))
slot-new-value-pairs)))))
(defun unbound-slots-to-nil (type object)
(iter (for n in (class-slot-names type))
(handler-case (slot-value object n)
(unbound-slot () (setf (slot-value object n) nil))))
object)
;; CLOSHOZ
;; (defmacro indiff-name (name)
;; `(,name :accessor ,name
;; :initarg (make-keyword (symbol-name ',name))))
;; (defun clone-struct-quoted (class-name &rest slot-value-sequence)
;; (apply #'make-
;; ((mapcar #:car (tupelize slot-value-sequence 2))
;; (defmacro unio-slots (&rest structs)
;; (gensyms (s)
;; `(remove-duplicates (iter (for ,s in ',structs)
;; (appending (struct-slots ,s))))))
;; (defmacro defstruct-unio (name &rest structs)
;; (append (list 'defstruct name) `((unio-slots ,@structs))))