tuple-expander.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
   2
   3
   4 ;; this was a bad idea
   5 ;; #+cl-tuples-debug (declaim (optimize (speed 0) (safety 3) (debug 3)))
   6 ;; #-cl-tuples-debug (declaim (optimize (speed 3) (safety 1) (debug 0)))
   7
   8 (in-package :cl-tuples)
   9
  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)))
  13
  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))))
  17
  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)
  21          collect
  22            (list e (tuple-initial-element type-name) :type (tuple-element-type type-name))))
  23
  24 (defparameter *tuple-expander-keywords*
  25   '(:def-tuple-values :def-tuple-key-values
  26         :def-tuple-type :def-tuple-array-type
  27         :def-tuple-struct
  28         :def-tuple-getter
  29         :def-tuple-aref
  30         :def-tuple-aref*
  31         :def-nth-tuple
  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*
  42         :def-tuple-array-setf
  43         :def-tuple-map
  44         :def-tuple-reduce))
  45
  46 (defgeneric tuple-symbol (type-name expansion))
  47
  48 (defgeneric tuple-expansion-fn (type-name expansion))
  49
  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 ))
  53
  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))))
  60
  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))
  64
  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)
  68        (&key
  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))))
  75
  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))
  80
  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)))
  85
  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"))
  90
  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) *)))
  95
  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))
  99
 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)))
 104
 105 ;; -- generalised access --
 106
 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))
 110
 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)
 115                 (values
 116                  ,@(loop
 117                           for index from 0 below (tuple-size ',type-name)
 118                           collect
 119                                 (construct-tuple-array-reference ',type-name tuple-array-name index))))))
 120
 121
 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))
 125
 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)))
 128
 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
 134                           ,varlist
 135                         ,tuple-values
 136                   (declare (type ,',(tuple-element-type type-name) ,@varlist))
 137                   (values
 138                    ,@(loop
 139                                 for index from 0 below ,(tuple-size type-name)
 140                                 collect
 141                                   (construct-tuple-set-aref ',type-name tuple-place index varlist)))))))
 142
 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"))
 146
 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))
 150          ,@(loop
 151                   for index from 0 below (tuple-size type-name)
 152                   collect
 153                         `(setf (aref tuple-place ,index) ,(nth index (tuple-elements type-name))))))
 154
 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))
 158
 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)))
 162
 163 ;; -- arrays --
 164
 165 ;; to do -- possibly re-engineer as a macro
 166
 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" ))
 170
 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))))
 179
 180
 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"))
 184
 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))))))
 192
 193
 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))
 197
 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)
 205                  (values ,@(iterate
 206                              (for counter below ,tuple-size)
 207                              (collect `(aref (the ,',(tuple-typespec** type-name) ,tuple-array)
 208                                              (the fixnum (+ ,counter ,array-index-sym))))))))))))
 209
 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"))
 213
 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))))
 217
 218 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref-setter)))
 219   (make-adorned-symbol type-name :suffix "AREF-SETTER"))
 220
 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)))
 227                    tuple)))
 228
 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))
 233
 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)))
 240                   (multiple-value-bind
 241                                 ,varlist
 242                           ,tuple-values
 243                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 244                         (values ,@(let ((counter 0))
 245                                                    (mapcar #'(lambda (x)
 246                                                                            (prog1
 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))
 250                                                                                  (incf counter)))
 251                                                                    varlist))))))))
 252
 253 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-setf)))
 254   (make-adorned-symbol type-name :suffix "AREF" ))
 255
 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)))
 260
 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))
 264
 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*)))
 269
 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"))
 273
 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))))))
 278
 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"))
 282
 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))))))
 287
 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"))
 291
 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)))))
 300
 301 ;; --- vectors --
 302
 303 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push)))
 304   (make-adorned-symbol type-name :suffix "VECTOR-PUSH"))
 305
 306 ;; tuple-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))
 311          (loop
 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))))))
 315
 316 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend)))
 317   (make-adorned-symbol type-name :suffix "VECTOR-PUSH-EXTEND"))
 318
 319 ;; tuple-vector-push
 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))
 324          (loop
 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))))))
 328
 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))
 332
 333 ;; tuple-vector-push
 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))))
 338            `(progn
 339                   (multiple-value-bind
 340                                 ,varlist
 341                           ,tuple-values
 342                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 343                         ,@(loop
 344                                  for index from 0 below ,(tuple-size type-name)
 345                                  collect
 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))))))))
 348
 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))
 352
 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))))
 357            `(progn
 358                   (multiple-value-bind
 359                           ,varlist
 360                         ,tuple-values
 361                   (declare (type ,',(tuple-element-type type-name) ,@varlist))
 362                   ,@(loop
 363                            for index from 0 below ,(tuple-size type-name)
 364                            collect
 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))))))))
 367
 368 ;; -- bindings --
 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"))
 372
 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
 378                          ,element-syms
 379                    (values ,@(let ((counter 0))
 380                                                   (mapcar #'(lambda (x)
 381                                                                           (declare (ignore x))
 382                                                                           (prog1
 383                                                                                   `(aref (the ,',(tuple-typespec** type-name) ,tuple-place) ,counter)
 384                                                                                 (incf counter)))
 385                                                                   element-syms)))
 386                  (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name) ,@element-syms))
 387                  (progn ,@forms))))
 388
 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))
 392
 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
 398                         ,element-syms
 399                   ,tuple
 400                 (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name) ,@element-syms))
 401                 (progn ,@forms))))
 402
 403
 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" ))
 407
 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)))
 414                   (multiple-value-bind
 415                                 ,element-syms
 416                           ;; this is the bit we need to generate
 417                           (values ,@(let ((counter 0))
 418                                                          (mapcar #'(lambda (x)
 419                                                                                  (declare (ignore x))
 420                                                                                  (prog1
 421                                                                                          `(aref (the ,',(tuple-typespec** type-name) ,array-name) (+ ,counter ,array-index-sym))
 422                                                                                    (incf counter)))
 423                                                                          element-syms)))
 424                         (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name)))
 425                         (progn ,@forms))))))
 426
 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)))
 430
 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" ))
 434
 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))))
 440
 441
 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"))
 445
 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)))
 451            `(let ((,tuple-sym
 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))
 455                   ,tuple-sym))))
 456
 457
 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))
 461
 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)))
 466                    (tuple-sym (gensym))
 467                    (counter-sym 0))
 468            (declare (type fixnum counter-sym))
 469            `(let  ((,tuple-sym
 470                                 ,(construct-tuple-array-maker ',type-name)))
 471                   (declare (type ,',(tuple-typespec* type-name) ,tuple-sym))
 472                   (multiple-value-bind
 473                                 ,varlist
 474                           ,tuple-values
 475                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 476                         (progn ,@(mapcar #'(lambda (x)
 477                                                                  (prog1
 478                                                                          `(setf (aref ,tuple-sym (the fixnum ,counter-sym)) ,x)
 479                                                                    (incf counter-sym)))
 480                                                          varlist)
 481                                    ,tuple-sym))))))
 482
 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))
 488
 489 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-map)))
 490   `(defmacro ,(tuple-symbol type-name expansion) (operator &rest args)
 491      (let* ((symbols
 492               (mapcar (lambda (arg)
 493                         (declare (ignore arg))
 494                         (make-gensym-list ,(tuple-size type-name)))
 495                       args))
 496             (values
 497               `(,',(tuple-symbol type-name :def-tuple-values)
 498                 ,@(iterate
 499                     (for index below ,(tuple-size type-name))
 500                     (collect `(,@operator ,@(mapcar (lambda (gensyms)
 501                                                       (nth index gensyms))
 502                                                     symbols)))))))
 503        (iterate
 504          (for arg in (reverse args))
 505          (for gensyms in (reverse symbols))
 506          (setf values `(,',(tuple-symbol type-name :def-with-tuple*)
 507                         ,arg ,gensyms
 508                         ,values)))
 509        values)))
 510
 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))
 514
 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*)
 519          ,tuple ,symbols
 520          (,@operator ,@symbols)))))
 521
 522
 523 ;; -- def-tuple-op expanders begin here ------------------------------------
 524
 525 ;; (in-package :tuple-types)
 526
 527 ;; (defclass %tuple-fun ()
 528 ;;   ((name :intiarg :fun-name)
 529 ;;    (params :initarg :params)
 530 ;;    (types :initarg :types)
 531 ;;    (elements :initarg :elements)))
 532
 533 ;; (in-package :cl-tuples)
 534
 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
 537    name capture."
 538   ;; if this is a tuple type with elements, we expand using with-tuple
 539   (if (tuple-typep (nth n types))
 540           (progn
 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))
 544                 ``(symbol-macrolet
 545                           ,',(loop
 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)
 550                                                                                                         ,@',(loop
 551                                                                                                                    for gensym in (nth n gensyms)
 552                                                                                                                    collect gensym))))
 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)
 556                                         ;; or bottom out
 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))))
 563
 564
 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 "
 567   (if (nth n types)
 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)))
 580
 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."
 584   (if (nth n types)
 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)))
 598
 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)
 603           (let ((ret-type
 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
 609                                  (cadar body)))
 610                         ;; the rest of the body is the actual body
 611                         (real-body (cddar body)))
 612                 ;; when we have a parameter list, expand it
 613                 ``(the ,',ret-type
 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)))
 620
 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
 629         (let ((gensyms
 630                    (mapcar #'(lambda (element-list)
 631                                            (make-gensym-list (length element-list))) elements)))
 632           ;; epand the body
 633           (body-expander-fn params types elements gensyms body))))
 634
 635                                                                                 ; tester
 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))))
 638