1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
5 ;; #+cl-tuples-debug (declaim (optimize (speed 0) (safety 3) (debug 3)))
6 ;; #-cl-tuples-debug (declaim (optimize (speed 3) (safety 1) (debug 0)))
8 (in-package :cl-tuples
)
10 (defun construct-tuple-array-reference (type-name tuple-array-name index
)
11 "Given a tuple type and an array index, return a form for returnign the array index"
12 `(the ,(tuple-element-type type-name
) (aref (the ,(tuple-typespec* type-name
) ,tuple-array-name
) ,index
)))
14 (defun construct-tuple-value-type (type-name)
15 "Given a tuple name construct the for of a value typespec for it eg (values single-float single-float)"
16 `(values ,@(loop for i from
0 below
(tuple-size type-name
) collect
(tuple-element-type type-name
))))
18 (defun construct-tuple-slots (type-name)
19 "Given a tuple type return a list of slots sutable for the body of a defstruct body eg: ((A 0.0f0 :TYPE SINGLE-FLOAT) (B 0.0f0 :TYPE SINGLE-FLOAT))"
20 (loop for e in
(tuple-elements type-name
)
22 (list e
(tuple-initial-element type-name
) :type
(tuple-element-type type-name
))))
24 (defparameter *tuple-expander-keywords
*
25 '(:def-tuple-values
:def-tuple-key-values
26 :def-tuple-type
:def-tuple-array-type
32 :def-with-tuple
:def-with-tuple
* :def-with-tuple-aref
33 :def-tuple-set
:def-tuple-setter
:def-tuple-aref-setter
*
34 :def-tuple-aref-setter
35 :def-tuple-vector-push
:def-tuple-vector-push-extend
36 :def-tuple-vector-push
* :def-tuple-vector-push-extend
*
37 :def-new-tuple
:def-tuple-maker
38 :def-tuple-maker
* :def-tuple-array-maker
39 :def-tuple-array-dimensions
40 :def-tuple-fill-pointer
:def-tuple-setf-fill-pointer
41 :def-tuple-setf
* :def-tuple-array-setf
*
46 (defgeneric tuple-symbol
(type-name expansion
))
48 (defgeneric tuple-expansion-fn
(type-name expansion
))
50 ;; eg. (vector3d-values* 1 2 3) => #{ 1 2 3 }
51 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-values
)))
52 (make-adorned-symbol type-name
:suffix
"VALUES" :asterisk t
))
54 ;; eg (vector3d-values* 1.2 3.0 1.2) => #{ 1.2 3.0 1.2 }
55 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-values
)))
56 "Expand to a macro that will create a values form representing our tuple type."
57 `(defmacro ,(tuple-symbol type-name expansion
) (&rest elements
)
58 `(the ,',(construct-tuple-value-type type-name
)
59 (values ,@elements
))))
61 ;; eg. (vector3d-key-values z 1.0 x 2.0) => #{ 2.0 0.0 1.0 }
62 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-key-values
)))
63 (make-adorned-symbol type-name
:suffix
"KEY-VALUES" :asterisk NIL
))
65 ;; create freshly initialised multiple values e.g. (vector3d-key-values z 1.0 x 2.0) => #{ 2.0 0.0 1.0 }
66 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-key-values
)))
67 `(defmacro ,(tuple-symbol type-name expansion
)
69 (initial-element ,(tuple-initial-element type-name
))
70 ,@(mapcar (lambda (element)
71 `((,element
,element
) initial-element
))
72 (tuple-elements type-name
)))
73 `(,',(tuple-symbol type-name
:def-tuple-values
)
74 ,,@(tuple-elements type-name
))))
76 ;; deftype form for the multiple value equivalent of the struct
77 ;; eg. (deftype vector3d* () `(values single-float single-float single-float))
78 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-type
)))
79 (make-adorned-symbol type-name
:asterisk t
))
81 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-type
)))
82 "Expand the tuple multiple value deftype form."
83 `(deftype ,(tuple-symbol type-name expansion
) ()
84 ,(construct-tuple-value-type type-name
)))
86 ;; deftype form for the array equivalent of the struct
87 ;; eg (deftype vector3d-array () (vector single-float *))
88 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-type
)))
89 (make-adorned-symbol type-name
:suffix
"ARRAY"))
91 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-type
)))
92 "Expand the deftype form for an array of tuples"
93 `(deftype ,(tuple-symbol type-name expansion
) ()
94 (vector ,(tuple-element-type type-name
) *)))
96 ;; deftype form to generate the structure definition eg (defstruct vector3d ..)
97 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-struct
)))
98 (make-adorned-symbol type-name
))
100 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-struct
)))
101 "Defines a structure that will hold the tuple based on a vector."
102 `(defstruct (,(tuple-symbol type-name expansion
) (:type vector
) (:constructor nil
))
103 ,@(construct-tuple-slots type-name
)))
105 ;; -- generalised access --
107 ;; return macro that will convert an array to a values form (vector3d* v) => #{ x y z }
108 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-getter
)))
109 (make-adorned-symbol type-name
:asterisk t
))
111 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-getter
)))
112 "Create a macro that will return the contents of a place representing our tuple as a value form"
113 `(defmacro ,(tuple-symbol type-name
:def-tuple-getter
) (tuple-array-name)
114 `(the ,(construct-tuple-value-type ',type-name
)
117 for index from
0 below
(tuple-size ',type-name
)
119 (construct-tuple-array-reference ',type-name tuple-array-name index
))))))
122 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
123 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-setter
)))
124 (make-adorned-symbol type-name
:suffix
"SETTER" :asterisk t
))
126 (defun construct-tuple-set-aref (type-name tuple-place index varlist
)
127 `(setf (aref (the ,(tuple-typespec* type-name
) ,tuple-place
) ,index
) ,(nth index varlist
)))
129 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-setter
)))
130 "Create a macro that will set an tuple place form to the values of a tuple value form"
131 `(defmacro ,(tuple-symbol type-name
:def-tuple-setter
) (tuple-place tuple-values
)
132 (let* ((varlist (make-gensym-list ,(tuple-size type-name
))))
133 `(multiple-value-bind
136 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
139 for index from
0 below
,(tuple-size type-name
)
141 (construct-tuple-set-aref ',type-name tuple-place index varlist
)))))))
143 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
144 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-set
)))
145 (make-adorned-symbol type-name
:prefix
"SET"))
147 ;; to do -- this needs type declarations
148 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-set
)))
149 `(defun ,(tuple-symbol type-name
:def-tuple-set
) (tuple-place ,@(tuple-elements type-name
))
151 for index from
0 below
(tuple-size type-name
)
153 `(setf (aref tuple-place
,index
) ,(nth index
(tuple-elements type-name
))))))
155 ;; generalised reference to a tuple place
156 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-setf
*)))
157 (make-adorned-symbol type-name
:suffix
"SETTER" :asterisk t
))
159 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-setf
*)))
160 "Expand form that creates generalized reference to a tuple place"
161 `(defsetf ,(tuple-symbol type-name
:def-tuple-getter
) ,(tuple-symbol type-name
:def-tuple-setter
)))
165 ;; to do -- possibly re-engineer as a macro
167 ;; create a flat array dimensioned to hold n tuples eg. (make-vector3d-array 3 :adjustable t)
168 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-maker
)))
169 (make-adorned-symbol type-name
:prefix
"MAKE" :suffix
"ARRAY" ))
171 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-maker
)))
172 "Create macro that creates a array of tuple array places."
173 `(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
))
174 (make-array (* ,(tuple-size type-name
) dimensions
)
175 :adjustable adjustable
176 :initial-element initial-element
177 :fill-pointer
(when fill-pointer-p
(* ,(tuple-size type-name
) fill-pointer
))
178 :element-type
',(tuple-element-type type-name
))))
181 ;; create an array accessor that will pick an individual tuple out of an array of tuples
182 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref
)))
183 (make-adorned-symbol type-name
:suffix
"AREF"))
185 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref
)))
186 "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
187 `(defun ,(tuple-symbol type-name
:def-tuple-aref
) (tuple-array tuple-index
)
188 (the ,(tuple-typespec* type-name
)
189 (subseq (the ,(tuple-typespec** type-name
) tuple-array
)
190 (* ,(tuple-size type-name
) tuple-index
)
191 (* ,(tuple-size type-name
) (1+ tuple-index
))))))
194 ;; 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 }
195 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref
*)))
196 (make-adorned-symbol type-name
:suffix
"AREF" :asterisk t
))
198 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref
*)))
199 "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"
200 (let ((tuple-size (tuple-size type-name
)))
201 `(defmacro ,(tuple-symbol type-name
:def-tuple-aref
*) (tuple-array array-index
)
202 (let ((array-index-sym (gensym)))
203 `(let ((,array-index-sym
(* ,',tuple-size
,array-index
)))
204 (the ,',(tuple-typespec type-name
)
206 (for counter below
,tuple-size
)
207 (collect `(aref (the ,',(tuple-typespec** type-name
) ,tuple-array
)
208 (the fixnum
(+ ,counter
,array-index-sym
))))))))))))
210 ;; decided not to use this one..
211 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-nth-tuple
)))
212 (make-adorned-symbol type-name
:prefix
"NTH"))
214 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-nth-tuple
)))
215 `(defun ,(tuple-symbol type-name
:def-tuple-setter
) (index tuple-place
)
216 (make-array ,(tuple-size type-name
) :displaced-to tuple-place
:displaced-index-offset
(* ,(tuple-size type-name
) index
))))
218 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
)))
219 (make-adorned-symbol type-name
:suffix
"AREF-SETTER"))
221 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
)))
222 "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
223 `(defun ,(tuple-symbol type-name
:def-tuple-aref-setter
) (array-name tuple-index tuple
)
224 (setf (subseq array-name
225 (* ,(tuple-size type-name
) tuple-index
)
226 (* ,(tuple-size type-name
) (1+ tuple-index
)))
229 ;; create a setter macro (for generalised setf places) that will set a tuple value form into an indexed array
230 ;; eg (vector3d-aref-setter vecs 2 #{ 2.3 2.3 4.2 })
231 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
*)))
232 (make-adorned-symbol type-name
:suffix
"AREF-SETTER" :asterisk t
))
234 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-aref-setter
*)))
235 "Create a macro that will set an indexed array of tuple places to the values of a tuple value form"
236 `(defmacro ,(tuple-symbol type-name
:def-tuple-aref-setter
*) (array-name array-index tuple-values
)
237 (let* ((varlist (make-gensym-list ,(tuple-size type-name
)))
238 (array-index-sym (gensym)))
239 `(let ((,array-index-sym
(* ,',(tuple-size type-name
) ,array-index
)))
243 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
244 (values ,@(let ((counter 0))
245 (mapcar #'(lambda (x)
247 `(setf (aref (the ,',(tuple-typespec** type-name
) ,array-name
)
248 (the fixnum
(+ (the fixnum
,counter
) (the fixnum
,array-index-sym
))))
249 (the ,',(tuple-element-type type-name
) ,x
))
253 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-setf
)))
254 (make-adorned-symbol type-name
:suffix
"AREF" ))
256 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-setf
)))
257 "Expand form that creates generalized reference to tuple-arrays"
258 `(defsetf ,(tuple-symbol type-name
:def-tuple-aref
)
259 ,(tuple-symbol type-name
:def-tuple-aref-setter
)))
261 ;; generalised reference to an array of tuples via value forms
262 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-setf
*)))
263 (make-adorned-symbol type-name
:suffix
"AREF" :asterisk t
))
265 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-setf
*)))
266 "Expand form that creates generalized reference to tuple-arrays"
267 `(defsetf ,(tuple-symbol type-name
:def-tuple-aref
*)
268 ,(tuple-symbol type-name
:def-tuple-aref-setter
*)))
270 ;; create a function that returns the dimensions of an array scaled down to tuple units
271 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-array-dimensions
)))
272 (make-adorned-symbol type-name
:suffix
"ARRAY-DIMENSIONS"))
274 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-array-dimensions
)))
275 "Create macro that returns the number of tuples in an array of tuple places."
276 `(defun ,(tuple-symbol type-name
:def-tuple-array-dimensions
) (tuple-array)
277 (the fixnum
(/ (the fixnum
(length tuple-array
)) (the fixnum
,(tuple-size type-name
))))))
279 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
280 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-fill-pointer
)))
281 (make-adorned-symbol type-name
:suffix
"FILL-POINTER"))
283 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-fill-pointer
)))
284 "Create macro that returns the number of tuples in an array of tuple places."
285 `(defun ,(tuple-symbol type-name
:def-tuple-fill-pointer
) (tuple-array)
286 (the fixnum
(/ (the fixnum
(fill-pointer tuple-array
)) (the fixnum
,(tuple-size type-name
))))))
288 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
289 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-setf-fill-pointer
)))
290 (make-adorned-symbol type-name
:suffix
"FILL-POINTER"))
292 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-setf-fill-pointer
)))
293 "Create macro that returns the number of tuples in an array of tuple places."
294 (with-gensyms (actual-fill-ptr)
295 `(defun (setf ,(tuple-symbol type-name
:def-tuple-fill-pointer
)) (value tuple-array
)
296 (declare (type fixnum value
))
297 (let ((,actual-fill-ptr
298 (the fixnum
(* value
(the fixnum
,(tuple-size type-name
))))))
299 (setf (fill-pointer tuple-array
) ,actual-fill-ptr
)))))
303 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push
)))
304 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH"))
307 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push
)))
308 "Create a macro that will push a tuple value form into an array of existing tuple places."
309 `(defun ,(tuple-symbol type-name
:def-tuple-vector-push
) (tuple array-name
)
310 (declare (type ,(tuple-typespec* type-name
) tuple
) (type ,(tuple-typespec** type-name
) array-name
))
312 for index from
0 below
,(tuple-size type-name
)
313 do
(vector-push (the ,(tuple-element-type type-name
) (aref tuple index
)) array-name
))
314 (the fixnum
(/ (the fixnum
(fill-pointer array-name
)) (the fixnum
,(tuple-size type-name
))))))
316 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
)))
317 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH-EXTEND"))
320 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
)))
321 "Create a macro that will push a tuple value form into an array of existing tuple places."
322 `(defun ,(tuple-symbol type-name
:def-tuple-vector-push-extend
) (tuple array-name
)
323 (declare (type ,(tuple-typespec* type-name
) tuple
) (type ,(tuple-typespec** type-name
) array-name
))
325 for index from
0 below
(the fixnum
,(tuple-size type-name
))
326 do
(vector-push-extend (aref tuple
(the fixnum index
)) array-name
))
327 (the fixnum
(/ (the fixnum
(fill-pointer array-name
)) (the fixnum
,(tuple-size type-name
))))))
329 ;; eg. (vector3d-push* vecs #{ 0.0 1.0 3.0 })
330 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push
*)))
331 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH" :asterisk t
))
334 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push
*)))
335 "Create a macro that will push a tuple value form into an array of existing tuple places."
336 `(defmacro ,(tuple-symbol type-name
:def-tuple-vector-push
*) (tuple-values array-name
)
337 (let* ((varlist (make-gensym-list ,(tuple-size type-name
))))
342 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
344 for index from
0 below
,(tuple-size type-name
)
346 `(vector-push (the fixnum
,(nth index varlist
)) (the ,',(tuple-typespec** type-name
) ,array-name
))))
347 (the fixnum
(/ (the fixnum
(fill-pointer ,array-name
)) (the fixnum
,',(tuple-size type-name
))))))))
349 ;; eg. (vector3d-push-extend* vecs #{ 0.0 1.0 3.0 })
350 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
*)))
351 (make-adorned-symbol type-name
:suffix
"VECTOR-PUSH-EXTEND" :asterisk t
))
353 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-vector-push-extend
*)))
354 "Create a macro that will push a tuple value form into an array of existing tuple places, extending if adjustable."
355 `(defmacro ,(tuple-symbol type-name
:def-tuple-vector-push-extend
*) (tuple-values array-name
)
356 (let* ((varlist (make-gensym-list ,(tuple-size type-name
))))
361 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
363 for index from
0 below
,(tuple-size type-name
)
365 `(vector-push-extend (the fixnum
,(nth index varlist
)) (the ,',(tuple-typespec** type-name
) ,array-name
) ,',(tuple-size type-name
))))
366 (the fixnum
(/ (the fixnum
(fill-pointer ,array-name
)) (the fixnum
,',(tuple-size type-name
))))))))
369 ;; bind tuple vector to symbols during evaluation of the form eg (with-vector3d #( 1.0 2.0 3.0 ) (x y z) (format t "~A" (list x y z)))
370 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-with-tuple
)))
371 (make-adorned-symbol type-name
:prefix
"WITH"))
373 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-with-tuple
)))
374 "Create a wrapper that will bind a tuple place to symbols during evaluation of the body."
375 `(defmacro ,(tuple-symbol type-name
:def-with-tuple
) (tuple-place element-syms
&body forms
)
376 (assert (= (length element-syms
) ,(tuple-size type-name
)) nil
"Incorrect length element-syms supplied to with-tuple*")
377 ` (multiple-value-bind
379 (values ,@(let ((counter 0))
380 (mapcar #'(lambda (x)
383 `(aref (the ,',(tuple-typespec** type-name
) ,tuple-place
) ,counter
)
386 (declare (ignorable ,@element-syms
) (type ,',(tuple-element-type type-name
) ,@element-syms
))
389 ;; bind tuple values to symbols during evaluation of the form eg (with-vector3d* #{ 1.0 2.0 3.0 } (x y z) (format t "~A" (list x y z)))
390 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-with-tuple
*)))
391 (make-adorned-symbol type-name
:prefix
"WITH" :asterisk t
))
393 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-with-tuple
*)))
394 "Create a wrapper that will bind a tuple value form to symbols during evaluation of the body."
395 `(defmacro ,(tuple-symbol type-name
:def-with-tuple
*) (tuple element-syms
&body forms
)
396 (assert (= (length element-syms
) ,(tuple-size type-name
)) nil
"Incorrect length element-syms supplied to with-tuple")
397 `(multiple-value-bind
400 (declare (ignorable ,@element-syms
) (type ,',(tuple-element-type type-name
) ,@element-syms
))
404 ;; bind tuple array elements to symbols during evaluation of the form eg (with-vector3d-aref (vecs 2 (x y z)) (format t "~A" (list x y z)))
405 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-with-tuple-aref
)))
406 (make-adorned-symbol type-name
:prefix
"WITH" :suffix
"AREF" ))
408 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-with-tuple-aref
)))
409 "Create a wrapper macro that will bind an indexed tuple form in an array to symbols turing evaluation of the body."
410 `(defmacro ,(tuple-symbol type-name
:def-with-tuple-aref
) ((array-name index element-syms
) &body forms
)
411 (assert (= (length element-syms
) ,(tuple-size type-name
)) nil
"Incorrect length element-syms supplied to with-tuple-aref")
412 (let* ((array-index-sym (gensym)))
413 `(let ((,array-index-sym
(* ,',(tuple-size type-name
) ,index
)))
416 ;; this is the bit we need to generate
417 (values ,@(let ((counter 0))
418 (mapcar #'(lambda (x)
421 `(aref (the ,',(tuple-typespec** type-name
) ,array-name
) (+ ,counter
,array-index-sym
))
424 (declare (ignorable ,@element-syms
) (type ,',(tuple-element-type type-name
)))
427 ;; -- constructors --
428 (defun construct-tuple-array-maker (type-name)
429 `(make-array ,(tuple-size type-name
) :initial-element
,(tuple-initial-element type-name
) :element-type
',(tuple-element-type type-name
)))
431 ;; create a new tuple, freshly initialised eg (new-vector3d) => #( 0.0 0.0 0.0 )
432 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-new-tuple
)))
433 (make-adorned-symbol type-name
:prefix
"NEW" ))
435 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-new-tuple
)))
436 "Create a macro that creates a new tuple."
437 `(defmacro ,(tuple-symbol type-name
:def-new-tuple
) ()
438 `(the ,',(tuple-typespec* type-name
)
439 ,(construct-tuple-array-maker ',type-name
))))
442 ;; create and initalise a tupe eg (make-vector3d 0.0 1.0 2.0) => #( 0.0 1.0 2.0 )
443 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-maker
)))
444 (make-adorned-symbol type-name
:prefix
"MAKE"))
446 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-maker
)))
447 "Create a macro that creates new tuple place and initialize it from a list of elements"
448 `(defmacro ,(tuple-symbol type-name
:def-tuple-maker
) (&rest elements
)
449 (assert (= (length elements
) ,(tuple-size type-name
)))
450 (let ((tuple-sym (gensym)))
452 ,(construct-tuple-array-maker ',type-name
)))
453 (declare (type ,',(tuple-typespec* type-name
) ,tuple-sym
))
454 (,',(tuple-symbol type-name
:def-tuple-setter
) ,tuple-sym
(values ,@elements
))
458 ;; --- create and initialise from multiple values eg (make-vector3d* #{ 12.0 3.0 6.0 })
459 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-maker
*)))
460 (make-adorned-symbol type-name
:prefix
"MAKE" :asterisk t
))
462 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-maker
*)))
463 "Create a macro that creates new tuple place, form and initialize it with values"
464 `(defmacro ,(tuple-symbol type-name
:def-tuple-maker
*) (tuple-values)
465 (let ((varlist (make-gensym-list ,(tuple-size type-name
)))
468 (declare (type fixnum counter-sym
))
470 ,(construct-tuple-array-maker ',type-name
)))
471 (declare (type ,',(tuple-typespec* type-name
) ,tuple-sym
))
475 (declare (type ,',(tuple-element-type type-name
) ,@varlist
))
476 (progn ,@(mapcar #'(lambda (x)
478 `(setf (aref ,tuple-sym
(the fixnum
,counter-sym
)) ,x
)
483 ;; eg. (vector2d-map* (+) #{1.0 2.0} #{4.0 5.0}) => #{5.0 7.0}
484 ;; or even (vector2d-map* (and) #{1.0 2.0} #{3.0 4.0}) => #{3.0 4.0}
485 ;; and (vector2d-map* ((lambda (a b) (funcall #'+ a b))) #{1.0 2.0} #{4.0 5.0}) => #{5.0 7.0}
486 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-map
)))
487 (make-adorned-symbol type-name
:suffix
"MAP*" :asterisk NIL
))
489 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-map
)))
490 `(defmacro ,(tuple-symbol type-name expansion
) (operator &rest args
)
492 (mapcar (lambda (arg)
493 (declare (ignore arg
))
494 (make-gensym-list ,(tuple-size type-name
)))
497 `(,',(tuple-symbol type-name
:def-tuple-values
)
499 (for index below
,(tuple-size type-name
))
500 (collect `(,@operator
,@(mapcar (lambda (gensyms)
504 (for arg in
(reverse args
))
505 (for gensyms in
(reverse symbols
))
506 (setf values
`(,',(tuple-symbol type-name
:def-with-tuple
*)
511 ;; eg. (vector3d-reduce* '+ #{1.0 2.0 3.0}) => 6.0
512 (defmethod tuple-symbol ((type-name symbol
) (expansion (eql :def-tuple-reduce
)))
513 (make-adorned-symbol type-name
:suffix
"REDUCE*" :asterisk NIL
))
515 (defmethod tuple-expansion-fn ((type-name symbol
) (expansion (eql :def-tuple-reduce
)))
516 `(defmacro ,(tuple-symbol type-name expansion
) (operator tuple
)
517 (let ((symbols (make-gensym-list ,(tuple-size type-name
))))
518 `(,',(tuple-symbol type-name
:def-with-tuple
*)
520 (,@operator
,@symbols
)))))
523 ;; -- def-tuple-op expanders begin here ------------------------------------
525 ;; (in-package :tuple-types)
527 ;; (defclass %tuple-fun ()
528 ;; ((name :intiarg :fun-name)
529 ;; (params :initarg :params)
530 ;; (types :initarg :types)
531 ;; (elements :initarg :elements)))
533 ;; (in-package :cl-tuples)
535 (defun symbol-macro-expander-fn (n names types elements gensyms body
)
536 "Wrap the body of def tuple op in symbol macros mapped to gensyms to prevent
538 ;; if this is a tuple type with elements, we expand using with-tuple
539 (if (tuple-typep (nth n types
))
541 (assert (= (length (nth n gensyms
))
542 (length (nth n elements
)))
543 nil
"~A contains too few elements for a ~A" (nth n elements
) (nth n types
))
546 for gensym in
(nth n gensyms
)
547 for element in
(nth n elements
) collect
`(,element
,gensym
))
548 ;; (declare (ignorable ,@',(nth n gensyms)))
549 (symbol-macrolet ((,',(nth n names
) (,',(make-adorned-symbol (nth n types
) :suffix
"VALUES" :asterisk t
)
551 for gensym in
(nth n gensyms
)
553 ;; recurs down to the next parameter
554 ,,(if (< (1+ n
) (length names
))
555 (symbol-macro-expander-fn (1+ n
) names types elements gensyms body
)
557 ``(progn ,@',body
)))))
558 ;; if this is not a tuple type, and theres more to come, recurse down
559 (if (< (1+ n
) (length names
))
560 (symbol-macro-expander-fn (1+ n
) names types elements gensyms body
)
561 ;; otherwise, bottom out
562 ``(progn ,@',body
))))
565 (defun arg-expander-fn-aux (n names types elements gensyms body
)
566 "Handle the expansion of the n-th parameter in a def-tuple-op call list. Names are the "
568 ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
569 (if (tuple-typep (nth n types
))
570 (if (< (1+ n
) (length names
))
571 (arg-expander-fn-aux (1+ n
) names types elements gensyms body
)
572 (symbol-macro-expander-fn 0 names types elements gensyms body
))
573 ;; otherwise just use a straight symbol
574 ``(let ((,',(nth n names
) (the ,',(nth n types
) ,,(nth n names
))))
575 ,,(if (< (1+ n
) (length names
))
576 (arg-expander-fn-aux (1+ n
) names types elements gensyms body
)
577 (symbol-macro-expander-fn 0 names types elements gensyms body
))))
578 ;; if there are no associated parameters with this op, just expand the body
579 (symbol-macro-expander-fn 0 nil nil nil nil body
)))
581 (defun arg-expander-fn-aux-with (n names types elements gensyms body
)
582 "Handle the tuple type case, expanding into -WITH macros. The rest is
583 handled by ARG-EXPANDER-FN-AUX in a separate step."
585 ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
586 (if (tuple-typep (nth n types
))
587 ``(,',(make-adorned-symbol (nth n types
) :prefix
"WITH" :asterisk t
)
588 ,,(nth n names
) ,',(nth n gensyms
)
589 ,,(if (< (1+ n
) (length names
))
590 (arg-expander-fn-aux-with (1+ n
) names types elements gensyms body
)
591 (arg-expander-fn-aux 0 names types elements gensyms body
)))
592 ;; otherwise just use a straight symbol
593 (if (< (1+ n
) (length names
))
594 (arg-expander-fn-aux-with (1+ n
) names types elements gensyms body
)
595 (arg-expander-fn-aux 0 names types elements gensyms body
)))
596 ;; if there are no associated parameters with this op, just expand the body
597 (symbol-macro-expander-fn 0 nil nil nil nil body
)))
599 (defun body-expander-fn (names types elements gensyms body
)
600 "Expand the declarations and return type wrapper round a def-tuple-op. form"
601 ;; have we specifed a return type?
602 (if (eq (caar body
) :return
)
604 ;; is it a tuple type?
605 (if (tuple-typep (cadar body
))
606 ;; yes, expand into type spec
607 (tuple-typespec (cadar body
))
608 ;; no, just use literal expansion
610 ;; the rest of the body is the actual body
611 (real-body (cddar body
)))
612 ;; when we have a parameter list, expand it
614 ,,(arg-expander-fn-aux-with 0 names types elements gensyms real-body
)))
615 ;; ;; otherwise splice in the quoted body
616 ;; ``(the ,',ret-type
617 ;; (progn ,@',real-body)))
618 ;; no we havent specified a return type, just fall in
619 (arg-expander-fn-aux-with 0 names types elements gensyms body
)))
621 (defun def-tuple-expander-fn (params types elements forms
)
622 "Helper function for def-tuple-op. Expands the arguments into a series of WITH-* forms so that
623 symbols are bound to tuple elements in the body of the operator."
624 (assert (= (length params
) (length types
) (length elements
)) ()
625 "Malformed def-tuple-op argument list.")
626 ;; if the first of the forms is a string then it's a docstring
627 (let ((body (if (stringp (first forms
)) (rest forms
) forms
)))
628 ;; create a gensym for every tuple element - they are going to be symbol macros
630 (mapcar #'(lambda (element-list)
631 (make-gensym-list (length element-list
))) elements
)))
633 (body-expander-fn params types elements gensyms body
))))
636 ;; (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))))
637 ;; (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))))