blob: 5899b36b1280dbc4007d7026280f78b5c0c67e69 (
plain)
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
|
(defpackage #:sarcasm.util
(:use #:cl)
(:export
#:take-until
#:def/class))
(in-package #:sarcasm.util)
(defun take-until (pred list)
"Returns two values: FRONT BACK.
FRONT contains the first N members X of LIST for which (PRED X) is NIL.
BACK contains everything after the members of FRONT.
(EQUALP LIST
(MULTIPLE-VALUE-BIND (FRONT BACK) (TAKE-UNTIL PRED LIST)
(APPEND FRONT BACK))
Is always T."
(loop :for (x . back) :on list
:for fx? := (funcall pred x)
:until fx?
:collect x :into front
:finally (return (values front (if fx? (cons x back) nil)))))
(defun partition (pred list)
"Returns two list values: YES NO.
YES is everything for which PRED is T, NO is everything else."
(loop :for e :in list
:when (funcall pred e)
:collect e :into yes
:else
:collect e :into no
:finally (return (values yes no))))
(defmacro def/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 integer :initarg 0)
Would expand into three slot definitions
(X :accessor X :initarg :X :type integer :initarg 0)
(Y :accessor Y :initarg :Y :type integer :initarg 0)
(Z :accessor Z :initarg :Z :type integer :initarg 0)
CLASS-OPTIONS is a PLIST of class options."
(labels
((make-accessor-name (slot &optional prefix?)
(if prefix?
(intern (format nil "~a-~a" name slot))
slot))
(singlep (x)
(find x '(:prefix) :test #'eq))
(parse-slot-spec-expr (expr)
" (names ... &key kwargs)"
(multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr)
(multiple-value-bind (kwargs singles) (partition #'singlep kwargs)
(loop
:with prefix-accessor? := (find ':prefix singles :test #'eq)
:for slot :in slot-names
:collect `(,slot
:accessor ,(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))))
|
