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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
;;;; 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 "+"))
(let ((newval (gensym "NEWVAL-")))
`(let ((,newval ,value))
(handler-bind ((error
(lambda (&rest ignore)
(declare (ignore ignore))
(invoke-restart 'cl:continue))))
(makunbound ',name))
(defconstant ,name ,newval ,@(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
:noarg - means no initarg
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 :noarg) :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))
(no-arg? (find ':noarg 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?)
,@(unless no-arg?
(list :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))))
(defmacro fast (name (&rest lambda-list) -> return-type &body body)
"A fastfun is one for which every parameter is typed, a return type is
declared. DEF:FAST generates an optimized DEFUN.
Each positional parameter must be a list (VAR TYPE) &KEY &REST and
&OPTIONAL arguments all look like (VAR TYPE . MORE) where MORE is
whatever defun normally accepts in the lambda list for these
arguments.
E.g.
(def::fast sum-ints ((x integer) (y integer) &optional (z integer 0)) -> integer
\"Sums integers\"
(+ x y z))
"
(assert (string-equal -> "->") () "-> must be named -> ** chortle **.")
(multiple-value-bind (lambda-list type-declarations)
(loop
:with types := nil
:with ll := nil
:for x :in lambda-list
:do (cond ((lambda-opt-p x)
(push x ll))
((listp x)
(destructuring-bind (var type . other) x
(let ((found (find type types
:test #'equalp
:key #'second)))
(if found
(push var (cddr found))
(push (list 'cl:type type var) types)))
(push
(if other (cons var other) var)
ll))))
:finally (return (values (nreverse ll) types)))
(let ((docstring (when (stringp (first body)) (first body))))
`(defun ,name ,lambda-list
,@(when docstring (list docstring))
(declare ,@type-declarations
(values ,return-type)
(optimize (speed 3) (safety 0)))
,@(if docstring (rest body) body)))))
|
