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 (defun make-tuple-symbol (type-name tuple-element-type tuple-initial-element elements)
   9   "Makes a symbol used to identify a tuple type and interns it in the
  10 package used for holding metadata about the tuple types. Information
  11 about the tuple type is stored in the property list of the symbol."
  12   (assert (listp elements))
  13   (let*
  14       ((type-string (string-upcase (string  type-name)))
  15            (type-name-sym (intern  type-string :tuple-types))
  16            (value-name-sym (intern (concatenate 'string type-string "*") :tuple-types)))
  17     (progn
  18       ;; deqfine the symbol
  19       ;; store-value the elements
  20       (setf (get type-name-sym :elements) elements)
  21       (setf (get value-name-sym :elements) elements)
  22       ;; store the # of elements ( a bit redundant )
  23       (setf (get  type-name-sym :tuple-length) (length elements))
  24       (setf (get  value-name-sym :tuple-length) (length elements))
  25           ;; store-value to use as inital array element
  26           (setf (get type-name-sym :initial-element) tuple-initial-element)
  27           (setf (get value-name-sym :initial-element) tuple-initial-element)
  28       ;; store-value the type of the elements
  29       (setf (get type-name-sym :element-type) tuple-element-type)
  30       (setf (get value-name-sym :element-type) tuple-element-type)
  31       ;; store-value a flag us to make sure it's a tuple-type symbol
  32       (setf (get type-name-sym :is-tuple) t)
  33       (setf (get value-name-sym :is-tuple) t))))
  34
  35
  36 (defun tuple-typep (type-name)
  37   "Test to see if this symbol represents a tuple type"
  38   (when (or (symbolp type-name) (stringp type-name))
  39     (get (find-symbol (string-upcase (string type-name)) :tuple-types)  :is-tuple)))
  40
  41 (defun tuple-size (type-name)
  42   "Return the size of the type"
  43   (assert (or (symbolp type-name) (stringp type-name)))
  44   (the  fixnum
  45                 (get (find-symbol (string-upcase (string type-name)) :tuple-types)  :tuple-length)))
  46
  47 (defun tuple-initial-element (type-name)
  48   "Return the inital element type of a tuple array"
  49   (assert (or (symbolp type-name) (stringp type-name)))
  50   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  :initial-element))
  51
  52 (defun tuple-element-type (type-name)
  53   "Return the size of the type"
  54   (assert (or (symbolp type-name) (stringp type-name)))
  55   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  :element-type))
  56
  57 (defun tuple-elements (type-name)
  58   "Return a list of element names"
  59   (assert (or (symbolp type-name) (stringp type-name)))
  60   (get (find-symbol (string-upcase (string type-name)) :tuple-types)  :elements))
  61
  62 (defun tuple-gensyms (type-name)
  63   "Return a list of gensyms, one for each element of the tuple"
  64   (assert (or (symbolp type-name) (stringp type-name)))
  65   (loop
  66      for i from 0 below (tuple-size type-name)
  67      collect (gensym)))
  68
  69 (defun tuple-typespec (type-name)
  70   "Return typespec of tuple as multiple value."
  71   `(values ,@(loop
  72                for i from 0 below (tuple-size type-name)
  73                 collect (tuple-element-type type-name))))
  74
  75 (defun tuple-typespec* (type-name)
  76   "Return typespec of tuple as bounded array"
  77   `(vector ,(tuple-element-type type-name) ,(tuple-size type-name)))
  78
  79 (defun tuple-typespec** (type-name)
  80   "Return typespec of tuple as unbounded array"
  81   `(vector ,(tuple-element-type type-name) *))
  82
  83 (defun simple-tuple-typespec* (type-name)
  84   "Return typespec of tuple as bounded array"
  85   `(simple-vector  ,(tuple-size type-name)))
  86
  87 (defun tuple-places (type-name array-name)
  88   "Return a list of (aref *) forms to turn at tuple represeted and array into individual places."
  89   (loop
  90      for i from 0 below (tuple-size type-name)
  91      collect `(aref ,array-name ,i)))
  92
  93 ;; make #{ .. } notation become a short hand for (values ...)
  94 (defun |#{-reader| (stream char arg)
  95   (declare (ignore char arg))
  96   `(values ,@(read-delimited-list #\} stream t)))
  97
  98 (set-dispatch-macro-character #\# #\{ #'|#{-reader|)
  99 (set-macro-character #\} (get-macro-character #\) nil))
 100
 101 (defun |#[-reader| (stream char arg)
 102   (declare (ignore char arg))
 103   (let ((form (read-delimited-list #\] stream t)))
 104         (if (tuple-typep (car form))
 105                 (if (is-asterisk-symbol (car form))
 106                         (let* ((form-str (symbol-name (car form)))
 107                                    (tuple-str (subseq form-str 0 (- (length form-str) 1))))
 108                           `(,(make-adorned-symbol tuple-str :asterisk t :suffix "VALUES") ,@(cdr form)))
 109                         `(,(make-adorned-symbol (car form) :prefix "MAKE") ,@(cdr form)))
 110                 (error "~A does not define a tuple type" (car form)))))
 111
 112
 113
 114
 115 (set-dispatch-macro-character #\# #\[ #'|#[-reader|)
 116 (set-macro-character #\] (get-macro-character #\) nil))