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
|
;;;; def.lisp
(in-package #:def)
(defmacro var (name &key doc (init nil initp))
"DEFVAR with optional documentation and optional initform. Lets you
easily document uninitialized special variables."
(assert (good-muffed-var-name-p name) (name)
"Special variable ~s is not wearing earmuffs :(")
`(progn
(defvar ,name)
,@(when initp
(list `(setf ,name ,init)))
,@(when doc
(list `(setf (documentation ',name 'cl:variable) ,doc)))))
(defmacro const (name value &optional doc)
"Define a constant in a way that is redefinable whenever the form is
reevaluated."
(assert (good-muffed-var-name-p name :muffer "+"))
`(progn
(handler-bind ((error
(lambda (&rest ignore)
(declare (ignore ignore))
(invoke-restart 'cl:continue))))
(makunbound ',name))
(defconstant ,name ,value ,@(when doc (list doc)))))
(defmacro class (name (&rest supers) &body slots-and-options)
"Define a class.
SLOTS-AND-OPTIONS := (SLOT-SPEC1 ... SLOT-SPECN . CLASS-OPTIONS)
Each SLOT-SPEC is a list of slot names followed by keyword slot
options, E.g:
(X Y Z :type real :initform 0)
Would expand into three slot definitions
(X :accessor X :initarg :X :type real :initform 0)
(Y :accessor Y :initarg :Y :type real :initform 0)
(Z :accessor Z :initarg :Z :type real :initform 0)
There are a few flag style slot definition arguments. Flags do not
have an value after them, all flags must come before other options. Flags are:
:prefix - prefix the accessor by the class name
:ro - only define a reader
:wo - only define a writer
By default an accessor is defined.
CLASS-OPTIONS is a PLIST of class options.
E.g.
(def:class pt (thing)
(x y z :prefix :type real :initform 0)
(label :type :string)
"
(labels
((make-accessor-name (slot &optional prefix?)
(if prefix?
(intern (format nil "~a-~a" name slot))
slot))
(singlep (x)
(find x '(:prefix :ro :wo) :test #'eq))
(parse-slot-spec-expr (expr)
" (names ... &key kwargs)"
(multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr)
(multiple-value-bind (singles kwargs) (partition #'singlep kwargs)
(let ((prefix-accessor? (find ':prefix singles :test #'eq))
(read-only? (find ':ro singles :test #'eq))
(write-only? (find ':wo singles :test #'eq)))
(assert (not (and read-only? write-only?)) ()
"A slot cannot be both read-only (:ro) and write-only (:wo).")
(loop
:with accessor-type := (cond (read-only? :reader)
(write-only? :writer)
(t :accessor))
:for slot :in slot-names
:collect `(,slot
,accessor-type ,(make-accessor-name slot prefix-accessor?)
:initarg ,(alexandria:make-keyword slot)
,@kwargs))))))
(parse-class-options (kwargs)
(loop :for (key val . more) :on kwargs :by #'cddr
:collect (list key val))))
(let* ((slot-defs (loop :for expr :in slots-and-options
:while (listp expr)
:append (parse-slot-spec-expr expr)))
(options (parse-class-options
(nth-value 1 (take-until #'keywordp slots-and-options)))))
`(defclass ,name ,supers
(,@slot-defs)
,@options))))
|
