1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
4 #+cl-tuples-debug
(declaim (optimize (speed 0) (safety 3) (debug 3)))
5 #-cl-tuples-debug
(declaim (optimize (speed 3) (safety 1) (debug 0)))
7 (in-package :cl-tuples
)
9 (defun construct-tuple-array-reference (type-name tuple-array-name index
)
10 "Given a tuple type and an array index, return a form for returnign the array index"
11 `(the ,(tuple-element-type type-name
) (aref (the ,(tuple-typespec* type-name
) ,tuple-array-name
) ,index
)))
13 (defun construct-tuple-value-type (type-name)
14 "Given a tuple name construct the for of a value typespec for it eg (values single-float single-float)"
15 `(values ,@(loop for i from
0 below
(tuple-size type-name
) collect
(tuple-element-type type-name
))))
17 (defun construct-tuple-slots (type-name)
18 "Given a tuple type return a list of slots sutable for the body of a defstruct body eg: ((A 0.0 :TYPE SINGLE-FLOAT) (B 0.0 :TYPE SINGLE-FLOAT))"
19 (loop for e in
(tuple-elements type-name
)
21 (list e
(tuple-initial-element type-name
) :type
(tuple-element-type type-name
))))
23 (defparameter *tuple-expander-keywords
*
24 '(:def-tuple-values
:def-tuple-key-values
25 :def-tuple-type
:def-tuple-array-type
31 :def-with-tuple
:def-with-tuple
* :def-with-tuple-aref
32 :def-tuple-set
:def-tuple-setter
:def-tuple-aref-setter
*
33 :def-tuple-aref-setter
34 :def-tuple-vector-push
:def-tuple-vector-push-extend
35 :def-tuple-vector-push
* :def-tuple-vector-push-extend
*
36 :def-new-tuple
:def-tuple-maker
37 :def-tuple-maker
* :def-tuple-array-maker
38 :def-tuple-array-dimensions
39 :def-tuple-fill-pointer
:def-tuple-setf-fill-pointer
40 :def-tuple-setf
* :def-tuple-array-setf
*
45 (defgeneric tuple-symbol
(type-name expansion
))
47 (defgeneric tuple-expansion-fn
(type-name expansion
))
49 ;; eg. (vector3d-values* 1 2 3) => #{ 1 2 3 }
50 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-values
)))
51 (make-adorned-symbol type-name
:suffix
"VALUES" :asterisk t
))
53 ;; eg (vector3d-values* 1.2 3.0 1.2) => #{ 1.2 3.0 1.2 }
54 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-values
)))
55 "Expand to a macro that will create a values form representing our tuple type."
56 `(defmacro ,(tuple-symbol type-name expansion
) (&rest elements
)
57 `(the ,',(construct-tuple-value-type type-name
)
58 (values ,@elements
))))
60 ;; eg. (vector3d-key-values z 1.0 x 2.0) => #{ 2.0 0.0 1.0 }
61 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-key-values
)))
62 (make-adorned-symbol type-name
:suffix
"KEY-VALUES" :asterisk NIL
))
64 ;; create freshly initialised multiple values e.g. (vector3d-key-values z 1.0 x 2.0) => #{ 2.0 0.0 1.0 }
65 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-key-values
)))
66 `(defmacro ,(tuple-symbol type-name expansion
)
68 (initial-element ,(tuple-initial-element type-name
))
69 ,@(mapcar (lambda (element)
70 `((,element
,element
) initial-element
))
71 (tuple-elements type-name
)))
72 `(,',(tuple-symbol type-name
:def-tuple-values
)
73 ,,@(tuple-elements type-name
))))
75 ;; deftype form for the multiple value equivalent of the struct
76 ;; eg. (deftype vector3d* () `(values single-float single-float single-float))
77 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-type
)))
78 (make-adorned-symbol type-name
:asterisk t
))
80 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-type
)))
81 "Expand the tuple multiple value deftype form."
82 `(deftype ,(tuple-symbol type-name expansion
) ()
83 ,(construct-tuple-value-type type-name
)))
85 ;; deftype form for the array equivalent of the struct
86 ;; eg (deftype vector3d-array () (vector single-float *))
87 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-type
)))
88 (make-adorned-symbol type-name
:suffix
"ARRAY"))
90 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-type
)))
91 "Expand the deftype form for an array of tuples"
92 `(deftype ,(tuple-symbol type-name expansion
) ()
93 (vector ,(tuple-element-type type-name
) *)))
95 ;; deftype form to generate the structure definition eg (defstruct vector3d ..)
96 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-struct
)))
97 (make-adorned-symbol type-name
))
99 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-struct
)))
100 "Defines a structure that will hold the tuple based on a vector."
101 `(defstruct (,(tuple-symbol type-name expansion
) (:type vector
) (:constructor nil
))
102 ,@(construct-tuple-slots type-name
)))
104 ;; -- generalised access --
106 ;; return macro that will convert an array to a values form (vector3d* v) => #{ x y z }
107 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-getter
)))
108 (make-adorned-symbol type-name
:asterisk t
))
110 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-getter
)))
111 "Create a macro that will return the contents of a place representing our tuple as a value form"
112 `(defmacro ,(tuple-symbol type-name
:def-tuple-getter
) (tuple-array-name)
113 `(the ,(construct-tuple-value-type ',type-name
)
116 for index from
0 below
(tuple-size ',type-name
)
118 (construct-tuple-array-reference ',type-name tuple-array-name index
))))))
121 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
122 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-setter
)))
123 (make-adorned-symbol type-name
:suffix
"SETTER" :asterisk t
))
125 (defun construct-tuple-set-aref (type-name tuple-place index varlist
)
126 `(setf (aref (the ,(tuple-typespec* type-name
) ,tuple-place
) ,index
) ,(nth index varlist
)))
128 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-setter
)))
129 "Create a macro that will set an tuple place form to the values of a tuple value form"
130 `(defmacro ,(tuple-symbol type-name
:def-tuple-setter
) (tuple-place tuple-values
)
131 (let* ((varlist (make-gensym-list ,(tuple-size type-name
))))
132 `(multiple-value-bind
135 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
138 for index from
0 below
,(tuple-size type-name
)
140 (construct-tuple-set-aref ',type-name tuple-place index varlist
)))))))
142 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
143 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-set
)))
144 (make-adorned-symbol type-name
:prefix
"SET"))
146 ;; to do -- this needs type declarations
147 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-set
)))
148 `(defun ,(tuple-symbol type-name
:def-tuple-set
) (tuple-place ,@(tuple-elements type-name
))
150 for index from
0 below
(tuple-size type-name
)
152 `(setf (aref tuple-place
,index
) ,(nth index
(tuple-elements type-name
))))))
154 ;; generalised reference to a tuple place
155 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-setf
*)))
156 (make-adorned-symbol type-name
:suffix
"SETTER" :asterisk t
))
158 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-setf
*)))
159 "Expand form that creates generalized reference to a tuple place"
160 `(defsetf ,(tuple-symbol type-name
:def-tuple-getter
) ,(tuple-symbol type-name
:def-tuple-setter
)))
164 ;; to do -- possibly re-engineer as a macro
166 ;; create a flat array dimensioned to hold n tuples eg. (make-vector3d-array 3 :adjustable t)
167 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-maker
)))
168 (make-adorned-symbol type-name
:prefix
"MAKE" :suffix
"ARRAY" ))
170 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-maker
)))
171 "Create macro that creates a array of tuple array places."
172 `(defun ,(tuple-symbol type-name
:def-tuple-array-maker
) (dimensions &key adjustable
(initial-element ,(tuple-initial-element type-name
)) (fill-pointer nil fill-pointer-p
))
173 (make-array (* ,(tuple-size type-name
) dimensions
)
174 :adjustable adjustable
175 :initial-element initial-element
176 :fill-pointer
(when fill-pointer-p
(* ,(tuple-size type-name
) fill-pointer
))
177 :element-type
',(tuple-element-type type-name
))))
180 ;; create an array accessor that will pick an individual tuple out of an array of tuples
181 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref
)))
182 (make-adorned-symbol type-name
:suffix
"AREF"))
184 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref
)))
185 "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
186 `(defun ,(tuple-symbol type-name
:def-tuple-aref
) (tuple-array tuple-index
)
187 (the ,(tuple-typespec* type-name
)
188 (subseq (the ,(tuple-typespec** type-name
) tuple-array
)
189 (* ,(tuple-size type-name
) tuple-index
)
190 (* ,(tuple-size type-name
) (1+ tuple-index
))))))
193 ;; create an array accessor that accesses an array of tuples and produces a value form eg (vector3d-aref* vecs 2) => #{ 2.3 4.3 2.4 }
194 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref
*)))
195 (make-adorned-symbol type-name
:suffix
"AREF" :asterisk t
))
197 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref
*)))
198 "Create a macro that will index an array that is considered to be an array of tuples and extract an individual tuple as a value form"
199 (let ((tuple-size (tuple-size type-name
)))
200 `(defmacro ,(tuple-symbol type-name
:def-tuple-aref
*) (tuple-array array-index
)
201 (let ((array-index-sym (gensym)))
202 `(let ((,array-index-sym
(* ,',tuple-size
,array-index
)))
203 (the ,',(tuple-typespec type-name
)
205 (for counter below
,tuple-size
)
206 (collect `(aref (the ,',(tuple-typespec** type-name
) ,tuple-array
)
207 (the fixnum
(+ ,counter
,array-index-sym
))))))))))))
209 ;; decided not to use this one..
210 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-nth-tuple
)))
211 (make-adorned-symbol type-name
:prefix
"NTH"))
213 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-nth-tuple
)))
214 `(defun ,(tuple-symbol type-name
:def-tuple-setter
) (index tuple-place
)
215 (make-array ,(tuple-size type-name
) :displaced-to tuple-place
:displaced-index-offset
(* ,(tuple-size type-name
) index
))))
217 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
)))
218 (make-adorned-symbol type-name
:suffix
"AREF-SETTER"))
220 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
)))
221 "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
222 `(defun ,(tuple-symbol type-name
:def-tuple-aref-setter
) (array-name tuple-index tuple
)
223 (setf (subseq array-name
224 (* ,(tuple-size type-name
) tuple-index
)
225 (* ,(tuple-size type-name
) (1+ tuple-index
)))
228 ;; create a setter macro (for generalised setf places) that will set a tuple value form into an indexed array
229 ;; eg (vector3d-aref-setter vecs 2 #{ 2.3 2.3 4.2 })
230 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
*)))
231 (make-adorned-symbol type-name
:suffix
"AREF-SETTER" :asterisk t
))
233 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
*)))
234 "Create a macro that will set an indexed array of tuple places to the values of a tuple value form"
235 `(defmacro ,(tuple-symbol type-name
:def-tuple-aref-setter
*) (array-name array-index tuple-values
)
236 (let* ((varlist (make-gensym-list ,(tuple-size type-name
)))
237 (array-index-sym (gensym)))
238 `(let ((,array-index-sym
(* ,',(tuple-size type-name
) ,array-index
)))
242 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
243 (values ,@(let ((counter 0))
244 (mapcar #'(lambda (x)
246 `(setf (aref (the ,',(tuple-typespec** type-name
) ,array-name
)
247 (the fixnum
(+ (the fixnum
,counter
) (the fixnum
,array-index-sym
))))
248 (the ,',(tuple-element-type type-name
) ,x
))
252 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-setf
)))
253 (make-adorned-symbol type-name
:suffix
"AREF" ))
255 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-setf
)))
256 "Expand form that creates generalized reference to tuple-arrays"
257 `(defsetf ,(tuple-symbol type-name
:def-tuple-aref
)
258 ,(tuple-symbol type-name
:def-tuple-aref-setter
)))
260 ;; generalised reference to an array of tuples via value forms
261 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-setf
*)))
262 (make-adorned-symbol type-name
:suffix
"AREF" :asterisk t
))
264 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-setf
*)))
265 "Expand form that creates generalized reference to tuple-arrays"
266 `(defsetf ,(tuple-symbol type-name
:def-tuple-aref
*)
267 ,(tuple-symbol type-name
:def-tuple-aref-setter
*)))
269 ;; create a function that returns the dimensions of an array scaled down to tuple units
270 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-dimensions
)))
271 (make-adorned-symbol type-name
:suffix
"ARRAY-DIMENSIONS"))
273 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-dimensions
)))
274 "Create macro that returns the number of tuples in an array of tuple places."
275 `(defun ,(tuple-symbol type-name
:def-tuple-array-dimensions
) (tuple-array)
276 (the fixnum
(/ (the fixnum
(length tuple-array
)) (the fixnum
,(tuple-size type-name
))))))
278 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
279 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-fill-pointer
)))
280 (make-adorned-symbol type-name
:suffix
"FILL-POINTER"))
282 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-fill-pointer
)))
283 "Create macro that returns the number of tuples in an array of tuple places."
284 `(defun ,(tuple-symbol type-name
:def-tuple-fill-pointer
) (tuple-array)
285 (the fixnum
(/ (the fixnum
(fill-pointer tuple-array
)) (the fixnum
,(tuple-size type-name
))))))
287 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
288 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-setf-fill-pointer
)))
289 (make-adorned-symbol type-name
:suffix
"FILL-POINTER"))
291 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-setf-fill-pointer
)))
292 "Create macro that returns the number of tuples in an array of tuple places."
293 (with-gensyms (actual-fill-ptr)
294 `(defun (setf ,(tuple-symbol type-name
:def-tuple-fill-pointer
)) (value tuple-array
)
295 (declare (type fixnum value
))
296 (let ((,actual-fill-ptr
297 (the fixnum
(* value
(the fixnum
,(tuple-size type-name
))))))
298 (setf (fill-pointer tuple-array
) ,actual-fill-ptr
)))))
302 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push
)))
303 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH"))
306 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push
)))
307 "Create a macro that will push a tuple value form into an array of existing tuple places."
308 `(defun ,(tuple-symbol type-name
:def-tuple-vector-push
) (tuple array-name
)
309 (declare (type ,(tuple-typespec* type-name
) tuple
) (type ,(tuple-typespec** type-name
) array-name
))
311 for index from
0 below
,(tuple-size type-name
)
312 do
(vector-push (the ,(tuple-element-type type-name
) (aref tuple index
)) array-name
))
313 (the fixnum
(/ (the fixnum
(fill-pointer array-name
)) (the fixnum
,(tuple-size type-name
))))))
315 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
)))
316 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH-EXTEND"))
319 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
)))
320 "Create a macro that will push a tuple value form into an array of existing tuple places."
321 `(defun ,(tuple-symbol type-name
:def-tuple-vector-push-extend
) (tuple array-name
)
322 (declare (type ,(tuple-typespec* type-name
) tuple
) (type ,(tuple-typespec** type-name
) array-name
))
324 for index from
0 below
(the fixnum
,(tuple-size type-name
))
325 do
(vector-push-extend (aref tuple
(the fixnum index
)) array-name
))
326 (the fixnum
(/ (the fixnum
(fill-pointer array-name
)) (the fixnum
,(tuple-size type-name
))))))
328 ;; eg. (vector3d-push* vecs #{ 0.0 1.0 3.0 })
329 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push
*)))
330 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH" :asterisk t
))
333 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push
*)))
334 "Create a macro that will push a tuple value form into an array of existing tuple places."
335 `(defmacro ,(tuple-symbol type-name
:def-tuple-vector-push
*) (tuple-values array-name
)
336 (let* ((varlist (make-gensym-list ,(tuple-size type-name
))))
341 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
343 for index from
0 below
,(tuple-size type-name
)
345 `(vector-push (the fixnum
,(nth index varlist
)) (the ,',(tuple-typespec** type-name
) ,array-name
))))
346 (the fixnum
(/ (the fixnum
(fill-pointer ,array-name
)) (the fixnum
,',(tuple-size type-name
))))))))
348 ;; eg. (vector3d-push-extend* vecs #{ 0.0 1.0 3.0 })
349 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
*)))
350 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH-EXTEND" :asterisk t
))
352 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
*)))
353 "Create a macro that will push a tuple value form into an array of existing tuple places, extending if adjustable."
354 `(defmacro ,(tuple-symbol type-name
:def-tuple-vector-push-extend
*) (tuple-values array-name
)
355 (let* ((varlist (make-gensym-list ,(tuple-size type-name
))))
360 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
362 for index from
0 below
,(tuple-size type-name
)
364 `(vector-push-extend (the fixnum
,(nth index varlist
)) (the ,',(tuple-typespec** type-name
) ,array-name
) ,',(tuple-size type-name
))))
365 (the fixnum
(/ (the fixnum
(fill-pointer ,array-name
)) (the fixnum
,',(tuple-size type-name
))))))))
368 ;; bind tuple vector to symbols during evaluation of the form eg (with-vector3d #( 1.0 2.0 3.0 ) (x y z) (fomat t "~A" (list x y z)))
369 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-with-tuple
)))
370 (make-adorned-symbol type-name
:prefix
"WITH"))
372 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-with-tuple
)))
373 "Create a wrapper that will bind a tuple place to symbols during evaluation of the body."
374 `(defmacro ,(tuple-symbol type-name
:def-with-tuple
) (tuple-place element-syms
&body forms
)
375 (assert (= (length element-syms
) ,(tuple-size type-name
)) nil
"Incorrect length element-syms supplied to with-tuple*")
376 ` (multiple-value-bind
378 (values ,@(let ((counter 0))
379 (mapcar #'(lambda (x)
382 `(aref (the ,',(tuple-typespec** type-name
) ,tuple-place
) ,counter
)
385 (declare (ignorable ,@element-syms
) (type ,',(tuple-element-type type-name
) ,@element-syms
))
388 ;; bind tuple values to symbols during evaluation of the form eg (with-vector3d* #{ 1.0 2.0 3.0 } (x y z) (fomat t "~A" (list x y z)))
389 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-with-tuple
*)))
390 (make-adorned-symbol type-name
:prefix
"WITH" :asterisk t
))
392 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-with-tuple
*)))
393 "Create a wrapper that will bind a tuple value form to symbols during evaluation of the body."
394 `(defmacro ,(tuple-symbol type-name
:def-with-tuple
*) (tuple element-syms
&body forms
)
395 (assert (= (length element-syms
) ,(tuple-size type-name
)) nil
"Incorrect length element-syms supplied to with-tuple")
396 `(multiple-value-bind
399 (declare (ignorable ,@element-syms
) (type ,',(tuple-element-type type-name
) ,@element-syms
))
403 ;; bind tuple array elements to symbols during evaluation of the form eg (with-vector3d-aref (vecs 2 (x y z)) (fomat t "~A" (list x y z)))
404 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-with-tuple-aref
)))
405 (make-adorned-symbol type-name
:prefix
"WITH" :suffix
"AREF" ))
407 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-with-tuple-aref
)))
408 "Create a wrapper macro that will bind an indexed tuple form in an array to symbols turing evaluation of the body."
409 `(defmacro ,(tuple-symbol type-name
:def-with-tuple-aref
) ((array-name index element-syms
) &body forms
)
410 (assert (= (length element-syms
) ,(tuple-size type-name
)) nil
"Incorrect length element-syms supplied to with-tuple-aref")
411 (let* ((array-index-sym (gensym)))
412 `(let ((,array-index-sym
(* ,',(tuple-size type-name
) ,index
)))
415 ;; this is the bit we need to generate
416 (values ,@(let ((counter 0))
417 (mapcar #'(lambda (x)
420 `(aref (the ,',(tuple-typespec** type-name
) ,array-name
) (+ ,counter
,array-index-sym
))
423 (declare (ignorable ,@element-syms
) (type ,',(tuple-element-type type-name
)))
426 ;; -- constructors --
427 (defun construct-tuple-array-maker (type-name)
428 `(make-array ,(tuple-size type-name
) :initial-element
,(tuple-initial-element type-name
) :element-type
',(tuple-element-type type-name
)))
430 ;; create a new tuple, freshly initialised eg (new-vector3d) => #( 0.0 0.0 0.0 )
431 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-new-tuple
)))
432 (make-adorned-symbol type-name
:prefix
"NEW" ))
434 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-new-tuple
)))
435 "Create a macro that creates a new tuple."
436 `(defmacro ,(tuple-symbol type-name
:def-new-tuple
) ()
437 `(the ,',(tuple-typespec* type-name
)
438 ,(construct-tuple-array-maker ',type-name
))))
441 ;; create and initalise a tupe eg (make-vector3d 0.0 1.0 2.0) => #( 0.0 1.0 2.0 )
442 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-maker
)))
443 (make-adorned-symbol type-name
:prefix
"MAKE"))
445 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-maker
)))
446 "Create a macro that creates new tuple place and initialize it from a list of elements"
447 `(defmacro ,(tuple-symbol type-name
:def-tuple-maker
) (&rest elements
)
448 (assert (= (length elements
) ,(tuple-size type-name
)))
449 (let ((tuple-sym (gensym)))
451 ,(construct-tuple-array-maker ',type-name
)))
452 (declare (type ,',(tuple-typespec* type-name
) ,tuple-sym
))
453 (,',(tuple-symbol type-name
:def-tuple-setter
) ,tuple-sym
(values ,@elements
))
457 ;; --- create and initialise from multiple values eg (make-vector3d* #{ 12.0 3.0 6.0 })
458 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-maker
*)))
459 (make-adorned-symbol type-name
:prefix
"MAKE" :asterisk t
))
461 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-maker
*)))
462 "Create a macro that creates new tuple place, form and initialize it with values"
463 `(defmacro ,(tuple-symbol type-name
:def-tuple-maker
*) (tuple-values)
464 (let ((varlist (make-gensym-list ,(tuple-size type-name
)))
467 (declare (type fixnum counter-sym
))
469 ,(construct-tuple-array-maker ',type-name
)))
470 (declare (type ,',(tuple-typespec* type-name
) ,tuple-sym
))
474 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
475 (progn ,@(mapcar #'(lambda (x)
477 `(setf (aref ,tuple-sym
(the fixnum
,counter-sym
)) ,x
)
482 ;; eg. (vector2d-map* (+) #{1.0 2.0} #{4.0 5.0}) => #{5.0 7.0}
483 ;; or even (vector2d-map* (and) #{1.0 2.0} #{3.0 4.0}) => #{3.0 4.0}
484 ;; and (vector2d-map* ((lambda (a b) (funcall #'+ a b))) #{1.0 2.0} #{4.0 5.0}) => #{5.0 7.0}
485 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-map
)))
486 (make-adorned-symbol type-name
:suffix
"MAP*" :asterisk NIL
))
488 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-map
)))
489 `(defmacro ,(tuple-symbol type-name expansion
) (operator &rest args
)
491 (mapcar (lambda (arg)
492 (declare (ignore arg
))
493 (make-gensym-list ,(tuple-size type-name
)))
496 `(,',(tuple-symbol type-name
:def-tuple-values
)
498 (for index below
,(tuple-size type-name
))
499 (collect `(,@operator
,@(mapcar (lambda (gensyms)
503 (for arg in
(reverse args
))
504 (for gensyms in
(reverse symbols
))
505 (setf values
`(,',(tuple-symbol type-name
:def-with-tuple
*)
510 ;; eg. (vector3d-reduce* '+ #{1.0 2.0 3.0}) => 6.0
511 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-reduce
)))
512 (make-adorned-symbol type-name
:suffix
"REDUCE*" :asterisk NIL
))
514 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-reduce
)))
515 `(defmacro ,(tuple-symbol type-name expansion
) (operator tuple
)
516 (let ((symbols (make-gensym-list ,(tuple-size type-name
))))
517 `(,',(tuple-symbol type-name
:def-with-tuple
*)
519 (,@operator
,@symbols
)))))
522 ;; -- def-tuple-op expanders begin here ------------------------------------
524 ;; (in-package :tuple-types)
526 ;; (defclass %tuple-fun ()
527 ;; ((name :intiarg :fun-name)
528 ;; (params :initarg :params)
529 ;; (types :initarg :types)
530 ;; (elements :initarg :elements)))
532 ;; (in-package :cl-tuples)
534 (defun symbol-macro-expander-fn (n names types elements gensyms body
)
535 "Wrap the body of def tuple op in symbol macros mapped to gensyms to prevent
537 ;; if this is a tuple type with elements, we expand using with-tuple
538 (if (tuple-typep (nth n types
))
540 (assert (= (length (nth n gensyms
))
541 (length (nth n elements
)))
542 nil
"~A contains too few elements for a ~A" (nth n elements
) (nth n types
))
545 for gensym in
(nth n gensyms
)
546 for element in
(nth n elements
) collect
`(,element
,gensym
))
547 ;; (declare (ignorable ,@',(nth n gensyms)))
548 (symbol-macrolet ((,',(nth n names
) (,',(make-adorned-symbol (nth n types
) :suffix
"VALUES" :asterisk t
)
550 for gensym in
(nth n gensyms
)
552 ;; recurs down to the next parameter
553 ,,(if (< (1+ n
) (length names
))
554 (symbol-macro-expander-fn (1+ n
) names types elements gensyms body
)
556 ``(progn ,@',body
)))))
557 ;; if this is not a tuple type, and theres more to come, recurse down
558 (if (< (1+ n
) (length names
))
559 (symbol-macro-expander-fn (1+ n
) names types elements gensyms body
)
560 ;; otherwise, bottom out
561 ``(progn ,@',body
))))
564 (defun arg-expander-fn-aux (n names types elements gensyms body
)
565 "Handle the expansion of the n-th parameter in a def-tuple-op call list. Names are the "
567 ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
568 (if (tuple-typep (nth n types
))
569 (if (< (1+ n
) (length names
))
570 (arg-expander-fn-aux (1+ n
) names types elements gensyms body
)
571 (symbol-macro-expander-fn 0 names types elements gensyms body
))
572 ;; otherwise just use a straight symbol
573 ``(let ((,',(nth n names
) (the ,',(nth n types
) ,,(nth n names
))))
574 ,,(if (< (1+ n
) (length names
))
575 (arg-expander-fn-aux (1+ n
) names types elements gensyms body
)
576 (symbol-macro-expander-fn 0 names types elements gensyms body
))))
577 ;; if there are no associated parameters with this op, just expand the body
578 (symbol-macro-expander-fn 0 nil nil nil nil body
)))
580 (defun arg-expander-fn-aux-with (n names types elements gensyms body
)
581 "Handle the tuple type case, expanding into -WITH macros. The rest is
582 handled by ARG-EXPANDER-FN-AUX in a separate step."
584 ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
585 (if (tuple-typep (nth n types
))
586 ``(,',(make-adorned-symbol (nth n types
) :prefix
"WITH" :asterisk t
)
587 ,,(nth n names
) ,',(nth n gensyms
)
588 ,,(if (< (1+ n
) (length names
))
589 (arg-expander-fn-aux-with (1+ n
) names types elements gensyms body
)
590 (arg-expander-fn-aux 0 names types elements gensyms body
)))
591 ;; otherwise just use a straight symbol
592 (if (< (1+ n
) (length names
))
593 (arg-expander-fn-aux-with (1+ n
) names types elements gensyms body
)
594 (arg-expander-fn-aux 0 names types elements gensyms body
)))
595 ;; if there are no associated parameters with this op, just expand the body
596 (symbol-macro-expander-fn 0 nil nil nil nil body
)))
598 (defun body-expander-fn (names types elements gensyms body
)
599 "Expand the declarations and return type wrapper round a def-tuple-op. form"
600 ;; have we specifed a return type?
601 (if (eq (caar body
) :return
)
603 ;; is it a tuple type?
604 (if (tuple-typep (cadar body
))
605 ;; yes, expand into type spec
606 (tuple-typespec (cadar body
))
607 ;; no, just use literal expansion
609 ;; the rest of the body is the actual body
610 (real-body (cddar body
)))
611 ;; when we have a parameter list, expand it
613 ,,(arg-expander-fn-aux-with 0 names types elements gensyms real-body
)))
614 ;; ;; otherwise splice in the quoted body
615 ;; ``(the ,',ret-type
616 ;; (progn ,@',real-body)))
617 ;; no we havent specified a return type, just fall in
618 (arg-expander-fn-aux-with 0 names types elements gensyms body
)))
620 (defun def-tuple-expander-fn (params types elements forms
)
621 "Helper function for def-tuple-op. Expands the arguments into a series of WITH-* forms so that
622 symbols are bound to tuple elements in the body of the operator."
623 (assert (= (length params
) (length types
) (length elements
)) ()
624 "Malformed def-tuple-op argument list.")
625 ;; if the first of the forms is a string then it's a docstring
626 (let ((body (if (stringp (first forms
)) (rest forms
) forms
)))
627 ;; create a gensym for every tuple element - they are going to be symbol macros
629 (mapcar #'(lambda (element-list)
630 (make-gensym-list (length element-list
))) elements
)))
632 (body-expander-fn params types elements gensyms body
))))
635 ;; (arg-expander-fn '(v q) '(vector3d quaternion) '((x y z) (qx qy qz qw)) '("Return the vector + real" (:return (values single-float single-float single-float single-float) (vertex3d-tuple x y z qw))))
636 ;; (arg-expander-fn '(v q n) '(vector3d quaternion single-float) '((x y z) (qx qy qz qw) nil) '("Return the vector + real" (:return vertex3d (vertex3d-tuple x y z qw))))