tuple-expander.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
   2
   3
   4 #+cl-tuples-debug (declaim (optimize (speed 0) (safety 3) (debug 3)))
   5 #-cl-tuples-debug (declaim (optimize (speed 3) (safety 1) (debug 0)))
   6
   7 (in-package :cl-tuples)
   8
   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)))
  12
  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))))
  16
  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)
  20          collect
  21            (list e (tuple-initial-element type-name) :type (tuple-element-type type-name))))
  22
  23 (defparameter *tuple-expander-keywords*
  24   '(:def-tuple-values
  25         :def-tuple-type :def-tuple-array-type
  26         :def-tuple-struct
  27         :def-tuple-getter
  28         :def-tuple-aref
  29         :def-tuple-aref*
  30         :def-nth-tuple
  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*
  41         :def-tuple-array-setf))
  42
  43 (defgeneric tuple-symbol (type-name expansion))
  44
  45 (defgeneric tuple-expansion-fn (type-name expansion))
  46
  47 ;; eg. (vector3d-values* 1 2 3) => #{ 1 2 3 }
  48 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-values)))
  49   (make-adorned-symbol type-name :suffix "VALUES" :asterisk t ))
  50
  51 ;; eg (vector3d-values* 1.2 3.0 1.2) => #{ 1.2 3.0 1.2 }
  52 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-values)))
  53   "Expand to a macro that will create a values form representing our tuple type."
  54   `(defmacro ,(tuple-symbol type-name expansion) (&rest elements)
  55          `(the ,',(construct-tuple-value-type type-name)
  56                 (values  ,@elements))))
  57
  58 ;; deftype form for the multiple value equivalent of the struct
  59 ;; eg. (deftype vector3d* () `(values single-float single-float single-float))
  60 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-type)))
  61   (make-adorned-symbol type-name :asterisk t))
  62
  63 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-type)))
  64   "Expand the tuple multiple value deftype form."
  65   `(deftype ,(tuple-symbol type-name expansion) ()
  66          ,(construct-tuple-value-type type-name)))
  67
  68 ;; deftype form for the array equivalent of the struct
  69 ;; eg (deftype vector3d-array () (vector single-float *))
  70 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-type)))
  71   (make-adorned-symbol type-name :suffix "ARRAY"))
  72
  73 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-type)))
  74   "Expand the deftype form for an array of tuples"
  75   `(deftype ,(tuple-symbol type-name expansion) ()
  76          (vector ,(tuple-element-type type-name) *)))
  77
  78 ;; deftype form to generate the structure definition eg (defstruct vector3d ..)
  79 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-struct)))
  80   (make-adorned-symbol type-name))
  81
  82 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-struct)))
  83   "Defines a structure that will hold the tuple based on a vector."
  84   `(defstruct (,(tuple-symbol type-name expansion) (:type vector) (:constructor nil))
  85          ,@(construct-tuple-slots type-name)))
  86
  87 ;; -- generalised access --
  88
  89 ;; return macro that will convert an array to a values form (vector3d* v) => #{ x y z }
  90 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-getter)))
  91   (make-adorned-symbol type-name :asterisk t))
  92
  93 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-getter)))
  94   "Create a macro that will return the contents of a place representing our tuple as a value form"
  95   `(defmacro ,(tuple-symbol type-name :def-tuple-getter) (tuple-array-name)
  96          `(the ,(construct-tuple-value-type ',type-name)
  97                 (values
  98                  ,@(loop
  99                           for index from 0 below (tuple-size ',type-name)
 100                           collect
 101                                 (construct-tuple-array-reference ',type-name tuple-array-name index))))))
 102
 103
 104 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
 105 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-setter)))
 106   (make-adorned-symbol type-name :suffix "SETTER" :asterisk t))
 107
 108 (defun construct-tuple-set-aref (type-name tuple-place index varlist)
 109   `(setf (aref (the ,(tuple-typespec* type-name) ,tuple-place) ,index) ,(nth index varlist)))
 110
 111 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-setter)))
 112   "Create a macro that will set an tuple place form to the values of a tuple value form"
 113   `(defmacro ,(tuple-symbol type-name :def-tuple-setter) (tuple-place tuple-values)
 114          (let* ((varlist (make-gensym-list ,(tuple-size type-name))))
 115            `(multiple-value-bind
 116                           ,varlist
 117                         ,tuple-values
 118                   (declare (type ,',(tuple-element-type type-name) ,@varlist))
 119                   (values
 120                    ,@(loop
 121                                 for index from 0 below ,(tuple-size type-name)
 122                                 collect
 123                                   (construct-tuple-set-aref ',type-name tuple-place index varlist)))))))
 124
 125 ;; generate a setter for use with setf that takes values and places them into an array eg (vector3d-setter v #{ 1 2 3 })
 126 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-set)))
 127   (make-adorned-symbol type-name :prefix "SET"))
 128
 129 ;; to do -- this needs type declarations
 130 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-set)))
 131   `(defun ,(tuple-symbol type-name :def-tuple-set) (tuple-place ,@(tuple-elements type-name))
 132          ,@(loop
 133                   for index from 0 below (tuple-size type-name)
 134                   collect
 135                         `(setf (aref tuple-place ,index) ,(nth index (tuple-elements type-name))))))
 136
 137 ;; generalised reference to a tuple place
 138 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-setf*)))
 139  (make-adorned-symbol type-name :suffix "SETTER" :asterisk t))
 140
 141 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-setf*)))
 142   "Expand form that creates generalized reference to a tuple place"
 143   `(defsetf ,(tuple-symbol type-name :def-tuple-getter) ,(tuple-symbol type-name :def-tuple-setter)))
 144
 145 ;; -- arrays --
 146
 147 ;; to do -- possibly re-engineer as a macro
 148
 149 ;; create a flat array dimensioned to hold n tuples eg. (make-vector3d-array 3 :adjustable t)
 150 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-maker)))
 151   (make-adorned-symbol type-name :prefix "MAKE" :suffix "ARRAY" ))
 152
 153 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-maker)))
 154   "Create macro that creates a array of tuple array places."
 155   `(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))
 156          (make-array (* ,(tuple-size type-name) dimensions)
 157                                  :adjustable adjustable
 158                                  :initial-element initial-element
 159                                  :fill-pointer (when fill-pointer-p (* ,(tuple-size type-name) fill-pointer))
 160                                  :element-type ',(tuple-element-type type-name))))
 161
 162
 163 ;; create an array accessor that will pick an individual tuple out of an array of tuples
 164 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref)))
 165   (make-adorned-symbol type-name :suffix "AREF"))
 166
 167 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref)))
 168   "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
 169   `(defun  ,(tuple-symbol type-name :def-tuple-aref) (tuple-array tuple-index)
 170          (the ,(tuple-typespec* type-name)
 171                   (subseq (the ,(tuple-typespec** type-name) tuple-array)
 172                                   (* ,(tuple-size type-name) tuple-index)
 173                                   (* ,(tuple-size type-name) (1+ tuple-index))))))
 174
 175
 176 ;; 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 }
 177 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref*)))
 178   (make-adorned-symbol type-name :suffix "AREF" :asterisk t))
 179
 180 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref*)))
 181   "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"
 182   `(defmacro ,(tuple-symbol type-name :def-tuple-aref*) (tuple-array array-index)
 183          (let* ((varlist (make-gensym-list ,(tuple-size type-name)))
 184                         (array-index-sym (gensym))
 185                         (counter-sym (gensym)))
 186            `(let ((,array-index-sym (* ,',(tuple-size type-name) ,array-index)))
 187                   (the ,',(tuple-typespec type-name)
 188                         (let ((,counter-sym 0))
 189                           (values ,@(mapcar #'(lambda (x)
 190                                                                         (declare (ignore x))
 191                                                                         (prog1
 192                                                                                    `(aref (the ,',(tuple-typespec** type-name) ,tuple-array)
 193                                                                                                   (the fixnum (+  ,counter-sym ,array-index-sym)))
 194                                                                           `(incf (the fixnum ,counter-sym))))
 195                                                                 varlist))))))))
 196
 197 ;; decided not to use this one..
 198 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-nth-tuple)))
 199   (make-adorned-symbol type-name :prefix "NTH"))
 200
 201 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-nth-tuple)))
 202   `(defun ,(tuple-symbol type-name :def-tuple-setter) (index tuple-place)
 203          (make-array ,(tuple-size type-name) :displaced-to tuple-place :displaced-index-offset (* ,(tuple-size type-name) index))))
 204
 205 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref-setter)))
 206   (make-adorned-symbol type-name :suffix "AREF-SETTER"))
 207
 208 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-aref-setter)))
 209   "Create a macro that will set an indexed array of tuple places to the values of a tuple struct form"
 210   `(defun ,(tuple-symbol type-name :def-tuple-aref-setter) (array-name tuple-index tuple)
 211          (setf (subseq array-name
 212                                    (* ,(tuple-size type-name) tuple-index)
 213                                    (* ,(tuple-size type-name) (1+ tuple-index)))
 214                    tuple)))
 215
 216 ;; create a setter macro (for generalised setf places) that will set a tuple value form into an indexed array
 217 ;; eg (vector3d-aref-setter vecs 2 #{ 2.3 2.3 4.2 })
 218 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-aref-setter*)))
 219   (make-adorned-symbol type-name :suffix "AREF-SETTER" :asterisk t))
 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 value form"
 223   `(defmacro ,(tuple-symbol type-name :def-tuple-aref-setter*) (array-name array-index tuple-values)
 224          (let* ((varlist (make-gensym-list ,(tuple-size type-name)))
 225                         (array-index-sym (gensym)))
 226            `(let ((,array-index-sym (* ,',(tuple-size type-name) ,array-index)))
 227                   (multiple-value-bind
 228                                 ,varlist
 229                           ,tuple-values
 230                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 231                         (values ,@(let ((counter 0))
 232                                                    (mapcar #'(lambda (x)
 233                                                                            (prog1
 234                                                                                    `(setf (aref (the ,',(tuple-typespec** type-name) ,array-name)
 235                                                                                                                 (the fixnum (+ (the fixnum ,counter) (the fixnum ,array-index-sym))))
 236                                                                                                   (the ,',(tuple-element-type type-name) ,x))
 237                                                                                  (incf counter)))
 238                                                                    varlist))))))))
 239
 240 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-setf)))
 241   (make-adorned-symbol type-name :suffix "AREF" ))
 242
 243 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-setf)))
 244   "Expand form that creates generalized reference to tuple-arrays"
 245   `(defsetf ,(tuple-symbol type-name :def-tuple-aref)
 246            ,(tuple-symbol type-name :def-tuple-aref-setter)))
 247
 248 ;; generalised reference to an array of tuples via value forms
 249 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-setf*)))
 250   (make-adorned-symbol type-name :suffix "AREF" :asterisk t))
 251
 252 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-setf*)))
 253   "Expand form that creates generalized reference to tuple-arrays"
 254   `(defsetf ,(tuple-symbol type-name :def-tuple-aref*)
 255            ,(tuple-symbol type-name :def-tuple-aref-setter*)))
 256
 257 ;; create a function that returns the dimensions of an array scaled down to tuple units
 258 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-array-dimensions)))
 259   (make-adorned-symbol type-name :suffix "ARRAY-DIMENSIONS"))
 260
 261 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-array-dimensions)))
 262   "Create macro that returns the number of tuples in an array of tuple places."
 263   `(defun ,(tuple-symbol  type-name :def-tuple-array-dimensions) (tuple-array)
 264          (the fixnum (/ (the fixnum (length tuple-array)) (the fixnum ,(tuple-size type-name))))))
 265
 266 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
 267 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-fill-pointer)))
 268   (make-adorned-symbol type-name :suffix "FILL-POINTER"))
 269
 270 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-fill-pointer)))
 271   "Create macro that returns the number of tuples in an array of tuple places."
 272   `(defun ,(tuple-symbol  type-name :def-tuple-fill-pointer) (tuple-array)
 273          (the fixnum (/ (the fixnum (fill-pointer tuple-array)) (the fixnum ,(tuple-size type-name))))))
 274
 275 ;; create a function that returns the fillpoiinter of an array scaled down to tuple units
 276 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-setf-fill-pointer)))
 277   (make-adorned-symbol type-name :suffix "FILL-POINTER"))
 278
 279 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-setf-fill-pointer)))
 280   "Create macro that returns the number of tuples in an array of tuple places."
 281   (with-gensyms (actual-fill-ptr)
 282         `(defun (setf ,(tuple-symbol  type-name :def-tuple-fill-pointer)) (value tuple-array)
 283            (declare (type fixnum value))
 284            (let ((,actual-fill-ptr
 285                           (the fixnum (* value (the fixnum ,(tuple-size type-name))))))
 286                  (setf (fill-pointer tuple-array) ,actual-fill-ptr)))))
 287
 288 ;; --- vectors --
 289
 290 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push)))
 291   (make-adorned-symbol type-name :suffix "VECTOR-PUSH"))
 292
 293 ;; tuple-vector-push
 294 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push)))
 295   "Create a macro that will push a tuple value form into an array of existing tuple places."
 296   `(defun ,(tuple-symbol type-name :def-tuple-vector-push) (tuple array-name)
 297          (declare (type ,(tuple-typespec* type-name) tuple) (type ,(tuple-typespec** type-name) array-name))
 298          (loop
 299                 for index from 0 below ,(tuple-size type-name)
 300                 do (vector-push (the ,(tuple-element-type type-name) (aref tuple index)) array-name))
 301          (the fixnum (/  (the fixnum (fill-pointer array-name)) (the fixnum ,(tuple-size type-name))))))
 302
 303 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend)))
 304   (make-adorned-symbol type-name :suffix "VECTOR-PUSH-EXTEND"))
 305
 306 ;; tuple-vector-push
 307 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend)))
 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-extend) (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 (the fixnum ,(tuple-size type-name))
 313                 do (vector-push-extend (aref tuple (the fixnum index)) array-name))
 314          (the fixnum (/  (the fixnum (fill-pointer array-name)) (the fixnum ,(tuple-size type-name))))))
 315
 316 ;; eg. (vector3d-push* vecs #{ 0.0 1.0 3.0 })
 317 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push*)))
 318   (make-adorned-symbol type-name :suffix "VECTOR-PUSH" :asterisk t))
 319
 320 ;; tuple-vector-push
 321 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push*)))
 322   "Create a macro that will push a tuple value form into an array of existing tuple places."
 323   `(defmacro ,(tuple-symbol type-name :def-tuple-vector-push*) (tuple-values array-name)
 324          (let* ((varlist (make-gensym-list ,(tuple-size type-name))))
 325            `(progn
 326                   (multiple-value-bind
 327                                 ,varlist
 328                           ,tuple-values
 329                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 330                         ,@(loop
 331                                  for index from 0 below ,(tuple-size type-name)
 332                                  collect
 333                                    `(vector-push (the fixnum,(nth index varlist)) (the ,',(tuple-typespec** type-name) ,array-name))))
 334                   (the fixnum (/  (the fixnum (fill-pointer ,array-name)) (the fixnum ,',(tuple-size type-name))))))))
 335
 336 ;; eg. (vector3d-push-extend* vecs #{ 0.0 1.0 3.0 })
 337 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend*)))
 338   (make-adorned-symbol type-name :suffix "VECTOR-PUSH-EXTEND" :asterisk t))
 339
 340 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-vector-push-extend*)))
 341   "Create a macro that will push a tuple value form into an array of existing tuple places, extending if adjustable."
 342   `(defmacro ,(tuple-symbol type-name :def-tuple-vector-push-extend*) (tuple-values array-name)
 343          (let* ((varlist (make-gensym-list ,(tuple-size type-name))))
 344            `(progn
 345                   (multiple-value-bind
 346                           ,varlist
 347                         ,tuple-values
 348                   (declare (type ,',(tuple-element-type type-name) ,@varlist))
 349                   ,@(loop
 350                            for index from 0 below ,(tuple-size type-name)
 351                            collect
 352                                  `(vector-push-extend (the fixnum ,(nth index varlist)) (the ,',(tuple-typespec** type-name) ,array-name) ,',(tuple-size type-name))))
 353                   (the fixnum (/  (the fixnum (fill-pointer ,array-name)) (the fixnum ,',(tuple-size type-name))))))))
 354
 355 ;; -- bindings --
 356 ;; 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)))
 357 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-with-tuple)))
 358   (make-adorned-symbol type-name :prefix "WITH"))
 359
 360 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql  :def-with-tuple)))
 361   "Create a wrapper that will bind a tuple place  to symbols during evaluation of the body."
 362   `(defmacro ,(tuple-symbol type-name :def-with-tuple) (tuple-place element-syms &body forms)
 363          (assert (= (length element-syms) ,(tuple-size type-name)) nil "Incorrect length element-syms supplied to with-tuple*")
 364          ` (multiple-value-bind
 365                          ,element-syms
 366                    (values ,@(let ((counter 0))
 367                                                   (mapcar #'(lambda (x)
 368                                                                           (declare (ignore x))
 369                                                                           (prog1
 370                                                                                   `(aref (the ,',(tuple-typespec** type-name) ,tuple-place) ,counter)
 371                                                                                 (incf counter)))
 372                                                                   element-syms)))
 373                  (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name) ,@element-syms))
 374                  (progn ,@forms))))
 375
 376 ;; 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)))
 377 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-with-tuple*)))
 378   (make-adorned-symbol type-name :prefix "WITH" :asterisk t))
 379
 380 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-with-tuple*)))
 381   "Create a wrapper that will bind a tuple value form to symbols during evaluation of the body."
 382   `(defmacro ,(tuple-symbol type-name :def-with-tuple*)  (tuple element-syms &body forms)
 383          (assert (= (length element-syms) ,(tuple-size type-name)) nil "Incorrect length element-syms supplied to with-tuple")
 384          `(multiple-value-bind
 385                         ,element-syms
 386                   ,tuple
 387                 (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name) ,@element-syms))
 388                 (progn ,@forms))))
 389
 390
 391 ;; 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)))
 392 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-with-tuple-aref)))
 393   (make-adorned-symbol type-name :prefix "WITH" :suffix "AREF" ))
 394
 395 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-with-tuple-aref)))
 396   "Create a wrapper macro that will bind an indexed tuple form in an array to symbols turing evaluation of the body."
 397   `(defmacro ,(tuple-symbol type-name :def-with-tuple-aref)  ((array-name index element-syms) &body forms)
 398          (assert (= (length element-syms) ,(tuple-size type-name)) nil "Incorrect length element-syms supplied to with-tuple-aref")
 399          (let* ((array-index-sym (gensym)))
 400            `(let ((,array-index-sym (* ,',(tuple-size type-name) ,index)))
 401                   (multiple-value-bind
 402                                 ,element-syms
 403                           ;; this is the bit we need to generate
 404                           (values ,@(let ((counter 0))
 405                                                          (mapcar #'(lambda (x)
 406                                                                                  (declare (ignore x))
 407                                                                                  (prog1
 408                                                                                          `(aref (the ,',(tuple-typespec** type-name) ,array-name) (+ ,counter ,array-index-sym))
 409                                                                                    (incf counter)))
 410                                                                          element-syms)))
 411                         (declare (ignorable ,@element-syms) (type ,',(tuple-element-type type-name)))
 412                         (progn ,@forms))))))
 413
 414 ;; -- constructors --
 415 (defun construct-tuple-array-maker (type-name)
 416   `(make-array  ,(tuple-size type-name) :initial-element ,(tuple-initial-element type-name) :element-type ',(tuple-element-type type-name)))
 417
 418 ;; create a new tuple, freshly initialised eg (new-vector3d) => #( 0.0 0.0 0.0 )
 419 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-new-tuple)))
 420   (make-adorned-symbol type-name :prefix "NEW" ))
 421
 422 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-new-tuple)))
 423   "Create a macro that creates a new tuple."
 424   `(defmacro ,(tuple-symbol type-name :def-new-tuple) ()
 425          `(the ,',(tuple-typespec* type-name)
 426                 ,(construct-tuple-array-maker ',type-name))))
 427
 428
 429 ;; create and initalise a tupe eg (make-vector3d 0.0 1.0 2.0) => #( 0.0 1.0 2.0 )
 430 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-maker)))
 431   (make-adorned-symbol type-name :prefix "MAKE"))
 432
 433 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-maker)))
 434   "Create a macro that creates new tuple place and initialize it from a list of elements"
 435   `(defmacro ,(tuple-symbol type-name :def-tuple-maker) (&rest elements)
 436          (assert (= (length elements) ,(tuple-size type-name)))
 437          (let ((tuple-sym (gensym)))
 438            `(let ((,tuple-sym
 439                            ,(construct-tuple-array-maker ',type-name)))
 440                   (declare (type ,',(tuple-typespec* type-name) ,tuple-sym))
 441                   (,',(tuple-symbol type-name :def-tuple-setter) ,tuple-sym (values  ,@elements))
 442                   ,tuple-sym))))
 443
 444
 445 ;; --- create and initialise from multiple values eg (make-vector3d* #{ 12.0 3.0 6.0 })
 446 (defmethod tuple-symbol ((type-name symbol) (expansion (eql :def-tuple-maker*)))
 447   (make-adorned-symbol type-name :prefix "MAKE" :asterisk t))
 448
 449 (defmethod tuple-expansion-fn ((type-name symbol) (expansion (eql :def-tuple-maker*)))
 450   "Create a macro that creates new tuple place, form and initialize it with values"
 451   `(defmacro ,(tuple-symbol type-name :def-tuple-maker*) (tuple-values)
 452          (let ((varlist (make-gensym-list ,(tuple-size type-name)))
 453                    (tuple-sym (gensym))
 454                    (counter-sym 0))
 455            (declare (type fixnum counter-sym))
 456            `(let  ((,tuple-sym
 457                                 ,(construct-tuple-array-maker ',type-name)))
 458                   (declare (type ,',(tuple-typespec* type-name) ,tuple-sym))
 459                   (multiple-value-bind
 460                                 ,varlist
 461                           ,tuple-values
 462                         (declare (type ,',(tuple-element-type type-name) ,@varlist))
 463                         (progn ,@(mapcar #'(lambda (x)
 464                                                                  (prog1
 465                                                                          `(setf (aref ,tuple-sym (the fixnum ,counter-sym)) ,x)
 466                                                                    (incf counter-sym)))
 467                                                          varlist)
 468                                    ,tuple-sym))))))
 469
 470
 471 ;; -- def-tuple-op expanders begin here ------------------------------------
 472
 473 ;; (in-package :tuple-types)
 474
 475 ;; (defclass %tuple-fun ()
 476 ;;   ((name :intiarg :fun-name)
 477 ;;    (params :initarg :params)
 478 ;;    (types :initarg :types)
 479 ;;    (elements :initarg :elements)))
 480
 481 ;; (in-package :cl-tuples)
 482
 483 (defun symbol-macro-expander-fn (n names types elements gensyms body)
 484   "Wrap the body of def tuple op in symbol macros mapped to gensyms to prevent
 485    name capture."
 486   ;; if this is a tuple type with elements, we expand using with-tuple
 487   (if (tuple-typep (nth n types))
 488           (progn
 489                 (assert (= (length (nth n gensyms))
 490                                    (length (nth n elements)))
 491                                 nil "~A contains too few elements for a ~A" (nth n elements) (nth n types))
 492                 ``(symbol-macrolet
 493                           ,',(loop
 494                                         for gensym in (nth n gensyms)
 495                                         for element in (nth n elements) collect `(,element  ,gensym))
 496 ;;                      (declare (ignorable ,@',(nth n gensyms)))
 497                         (symbol-macrolet ((,',(nth n names) (,',(make-adorned-symbol (nth n types) :suffix "VALUES" :asterisk t)
 498                                                                                                         ,@',(loop
 499                                                                                                                    for gensym in (nth n gensyms)
 500                                                                                                                    collect gensym))))
 501                           ;; recurs down to the next parameter
 502                           ,,(if (< (1+ n) (length names))
 503                                         (symbol-macro-expander-fn (1+ n) names types elements gensyms body)
 504                                         ;; or bottom out
 505                                         ``(progn ,@',body)))))
 506           ;; if this is not a tuple type, and theres more to come, recurse down
 507           (if (< (1+ n) (length names))
 508                   (symbol-macro-expander-fn (1+ n) names types elements gensyms body)
 509                   ;; otherwise, bottom out
 510                   ``(progn ,@',body))))
 511
 512
 513 (defun arg-expander-fn-aux (n names types elements gensyms body)
 514   "Handle the expansion of the n-th parameter in a def-tuple-op call list. Names are the "
 515   (if (nth n types)
 516           ;; if it's a tuple type, bind to gensyms using the apropiate with-tuple macro
 517           (if (tuple-typep (nth n types))
 518                   ``(,',(make-adorned-symbol (nth n types) :prefix "WITH" :asterisk t)
 519                                 ,,(nth n  names) ,',(nth n  gensyms)
 520                                 ,,(if (< (1+ n) (length names))
 521                                           (arg-expander-fn-aux (1+ n) names types elements gensyms body)
 522                                           (symbol-macro-expander-fn 0 names types elements gensyms body)))
 523                   ;; otherwise just use a straight symbol
 524                   ``(symbol-macrolet ((,',(nth n names) (the ,',(nth n types)  ,,(nth n names))))
 525                           ,,(if (< (1+ n) (length names))
 526                                         (arg-expander-fn-aux (1+ n) names types elements gensyms body)
 527                                         (symbol-macro-expander-fn 0 names types elements gensyms body))))
 528           ;; if there are no associated parameters with this op, just expand the body
 529           (symbol-macro-expander-fn 0 nil nil nil nil body)))
 530
 531
 532 (defun body-expander-fn (names types elements gensyms body)
 533   "Expand the declarations and return type wrapper round a def-tuple-op. form"
 534   ;; have we specifed a return type?
 535   (if (eq (caar body) :return)
 536           (let ((ret-type
 537                          ;; is it a tuple type?
 538                          (if (tuple-typep (cadar body))
 539                                  ;; yes, expand into type spec
 540                                  (tuple-typespec (cadar body))
 541                                  ;; no, just use literal expansion
 542                                  (cadar body)))
 543                         ;; the rest of the body is the actual body
 544                         (real-body (cddar body)))
 545                 ;; when we have a parameter list, expand it
 546                 ``(the ,',ret-type
 547                         ,,(arg-expander-fn-aux 0 names types elements gensyms real-body)))
 548           ;;         ;; otherwise splice in the quoted body
 549           ;;         ``(the ,',ret-type
 550           ;;             (progn ,@',real-body)))
 551           ;; no we havent specified a return type, just fall in
 552           (arg-expander-fn-aux 0 names types elements gensyms body)))
 553
 554 (defun def-tuple-expander-fn (params types elements forms)
 555   "Helper function for def-tuple-op. Expands the arguments into a series of WITH-* forms so that
 556    symbols are bound to tuple elements in the body of the operator."
 557   (assert (= (length params) (length types) (length elements)) ()
 558                   "Malformed def-tuple-op argument list.")
 559   ;; if the first of the forms is a string then it's a docstring
 560   (let ((body (if (stringp (first forms)) (rest forms) forms)))
 561         ;; create a gensym for every tuple element - they are going to be symbol macros
 562         (let ((gensyms
 563                    (mapcar #'(lambda (element-list)
 564                                            (make-gensym-list (length element-list))) elements)))
 565           ;; epand the body
 566           (body-expander-fn params types elements gensyms body))))
 567
 568                                                                                 ; tester
 569 ;; (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))))
 570 ;; (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))))
 571