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