symbols.lisp

   1 ;;;; symbols.lisp
   2
   3 (in-package :cl-tuples)
   4
   5 ;; package used to hold tuple type info
   6 (defpackage :tuple-types)
   7
   8 ;; make #{ .. } notation become a short hand for (values ...)
   9 (defun |#{-reader| (stream char arg)
  10   (declare (ignore char arg))
  11   `(values ,@(read-delimited-list #\} stream t)))
  12
  13 (set-dispatch-macro-character #\# #\{ #'|#{-reader|)
  14 (set-macro-character #\} (get-macro-character #\) nil))
  15
  16 (defmacro with-gensyms ((&rest names) &body body)
  17   "Classic macro for creating named unique symbols."
  18   `(let ,(loop for n in names collect `(,n (gensym)))
  19      ,@body))
  20
  21 (defmacro once-only ((&rest names) &body body)
  22   "Evaluate arguments once only in macro form body"
  23   (let ((gensyms (loop for n in names collect (gensym))))
  24     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  25        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  26           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  27              ,@body)))))
  28
  29 ;; define helper functions we will use
  30
  31 (defun gensym-list (n)
  32   "Give us a list of gensyms n elements long"
  33   (loop
  34      for index from 0 below n
  35      collect (gensym)))
  36
  37
  38 (defun symbol-to-string (x)
  39   "If the argument is a symbol or string, return it as a string."
  40   (check-type x (or symbol string))
  41   (cond
  42     ((symbolp x)
  43      (symbol-name x))
  44     ((stringp x)
  45      x)))
  46
  47
  48 (defun make-adorned-symbol (name &key prefix suffix asterisk package)
  49   (check-type name symbol)
  50   (check-type prefix (or symbol string null))
  51   (check-type suffix (or symbol string null))
  52   (intern (concatenate 'string
  53                        (when prefix
  54                          (string prefix))
  55                        (when prefix  "-")
  56                        (string name)
  57                        (when suffix
  58                          "-")
  59                        (when suffix
  60                          (string suffix))
  61                        (when asterisk
  62                          (string "*")))
  63           (if package package *package*)))
  64
  65 (defun make-suffixed-symbol (name suffix)
  66   (make-adorned-symbol name :suffix suffix))
  67
  68 (defun make-prefixed-symbol (name prefix)
  69   (make-adorned-symbol name :prefix prefix))
  70
  71 (defun make-element-names (elements type-name)
  72   "Given a list of element names form a set of symbols of the form
  73      <type-name>-<element-name> as used in struct elements."
  74   (check-type elements symbol)
  75   (check-type type-name symbol)
  76   (mapcar #'(lambda (x)
  77               (find-symbol
  78                (concatenate 'string
  79                             (symbol-name type-name) "-struct-"
  80                             (symbol-name x))))
  81           elements))
  82
  83
  84 (defun make-tuple-symbol (type-name tuple-element-type elements)
  85   "Makes a symbol used to identify a typle type. Information about the tuple type
  86 is stored in the property list of the symbol."
  87   (assert (listp elements))
  88   (let
  89       ((type-name-sym (intern (string  type-name) :tuple-types)))
  90     (progn
  91       ;; deqfine the symbol
  92       ;; store-value the elements
  93       (setf (get type-name-sym 'elements) elements)
  94       ;; store the # of elements ( a bit redundant )
  95       (setf (get  type-name-sym 'tuple-length) (length elements))
  96       ;; store-value the type of the elements
  97       (setf (get type-name-sym 'element-type) tuple-element-type)
  98       ;; store-value a flag us to make sure it's a tuple-type symbol
  99       (setf (get type-name-sym 'is-tuple) t))))
 100
 101
 102 (defun tuple-typep (type-name)
 103   "Test to see if this symbol represents a tuple type"
 104   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  'is-tuple))
 105
 106 (defun tuple-size (type-name)
 107   "Return the size of the type"
 108   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  'tuple-length))
 109
 110
 111 (defun tuple-element-type (type-name)
 112   "Return the size of the type"
 113   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  'element-type))
 114
 115 (defun tuple-elements (type-name)
 116   "Return the size of the type"
 117   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  'elements))
 118
 119 (defun tuple-typespec (type-name)
 120   "Return typespec of tuple."
 121   `(values ,@(loop
 122                for i from 0 to (tuple-size type-name)
 123                 collect (tuple-element-type type-name))))
 124
 125 (defun symbol-macro-expander-fn (n names types elements gensyms body)
 126   "Wrap the body of def tuple op in symbol macros mapped to gensyms to prevent
 127    name capture."
 128   (if (nth n elements)
 129     ``(symbol-macrolet
 130           ,',(loop
 131                 for gensym in (nth n gensyms)
 132                 for element in (nth n elements) collect `(,element  ,gensym))
 133         (declare (ignorable ,@',(nth n gensyms)))
 134         (symbol-macrolet ((,',(nth n names) (,',(make-adorned-symbol (nth n types) :suffix "TUPLE")
 135                                                 ,@',(loop
 136                                                        for gensym in (nth n gensyms)
 137                                                        collect gensym))))
 138                          ,,(if (< (1+ n) (length names))
 139                                (symbol-macro-expander-fn (1+ n) names types elements gensyms body)
 140                                ``(progn ,@',body))))
 141     (if (< (1+ n) (length names))
 142         (symbol-macro-expander-fn (1+ n) names types elements gensyms body)
 143         ``(progn ,@',body))))
 144
 145
 146 (defun arg-expander-fn-aux (n names types elements gensyms body)
 147   (if (nth n types)
 148       ``(,',(make-adorned-symbol (nth n types) :prefix "WITH")
 149           ,,(nth n  names) ,',(nth n  gensyms)
 150           ,,(if (< (1+ n) (length names))
 151                 (arg-expander-fn-aux (1+ n) names types elements gensyms body)
 152                 (symbol-macro-expander-fn 0 names types elements gensyms body)))
 153       ``(symbol-macrolet ((,',(nth n names) ,,(nth n names)))
 154           ,,(if (< (1+ n) (length names))
 155                 (arg-expander-fn-aux (1+ n) names types elements gensyms body)
 156                 (symbol-macro-expander-fn 0 names types elements gensyms body)))))
 157
 158
 159 (defun body-expander-fn (names types elements gensyms body)
 160   (if (eq (caar body) :return)
 161       (let ((ret-type (if (tuple-typep (cadar body))
 162
 163                           (cadar body)))
 164           (real-body (cddar body)))
 165       `(the ,ret-type
 166          ,(arg-expander-fn-aux 0 names types elements gensyms real-body)))
 167     (arg-expander-fn-aux 0 names types elements gensyms body)))
 168
 169 (defun arg-expander-fn (names types elements forms)
 170   "Helper function for def-tuple-op. Expands the arguments into a series of WITH-* forms so that
 171    symbols are bound to tuple elements in the body of the operator."
 172   (assert (= (length names) (length types) (length elements)) ()
 173           "Malformed def-tuple-op argument list.")
 174   (let ((body (if (stringp (first forms)) (rest forms) forms)))
 175     (if (car types)
 176         (let ((gensyms
 177                (mapcar #'(lambda (element-list)
 178                            (gensym-list (length element-list))) elements)))
 179           (body-expander-fn names types elements gensyms body)))))
 180
 181 ; tester
 182 ;; (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))))
 183 ;; (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))))