Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

file 141 lines (117 sloc) 4.319 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
;; For license see LICENSE

(in-package #:rutils.readtable)
(declaim #.+default-opts+)


(eval-when (:compile-toplevel :load-toplevel :execute)

(defun |#v-reader| (stream char arg)
  "Literal syntax for vectors.
Unlike #() evaluates its contents before vector creation

Examples:

CL-USER> #v(1 2 3)
#(1 2 3)

CL-USER> #v((+ 1 2))
#(3)
"
  (declare (ignore char arg))
  (read-char stream)
  (let* ((vals (read-delimited-list #\) stream t)))
    `(make-array ,(length vals) :initial-contents (list ,@vals))))

(defun |#h-reader| (stream char arg)
  "Literal syntax for hash-tables.

Examples:

CL-USER> #h(:a 1 :b 2)
#<HASH-TABLE :TEST EQL :COUNT 2>
;; holding 2 key/value pairs: ((:a . 1) (:b . 2))

CL-USER> #h(equalp \"a\" 1 \"b\" 2)
#<HASH-TABLE :TEST EQUALP :COUNT 2>
;; holding 2 key/value pairs: ((\"a\" . 1) ...)
"
  (declare (ignore char arg))
  (read-char stream)
  (let* ((sexp (read-delimited-list #\) stream t))
         (test (when (oddp (length sexp))
                 (car sexp)))
         (kvs (if test (cdr sexp) sexp))
         (ht (gensym)))
    `(let ((,ht (make-hash-table :test ',(or test 'eql))))
       ,@(loop :for tail :on kvs :by #'cddr :while kvs
            :collect `(setf (gethash ,(car tail) ,ht) ,(cadr tail)))
       ,ht)))

(defun |#{-reader| (stream char arg)
  "Literal syntax for fixed-size hash-tables.

Examples:

CL-USER> #{:a 1 :b 2}
#<HASH-TABLE :TEST EQL :COUNT 2>
;; holding 2 key/value pairs: ((:a . 1) (:b . 2))

CL-USER> #{equalp \"a\" 1 \"b\" 2}
#<HASH-TABLE :TEST EQUALP :COUNT 2>
;; holding 2 key/value pairs: ((\"a\" . 1) ...)
"
  (declare (ignore char arg))
  (let* ((sexp (read-delimited-list #\} stream t))
         (test (when (oddp (length sexp))
                 (car sexp)))
         (kvs (if test (cdr sexp) sexp))
         (ht (gensym)))
    `(let ((,ht (make-hash-table :test ',(or test 'eql)
                                 :size ,(/ (length kvs) 2))))
       ,@(loop :for tail :on kvs :by #'cddr :while kvs
            :collect `(setf (gethash ,(car tail) ,ht) ,(cadr tail)))
       ,ht)))

(defun |#`-reader| (stream char arg)
  "Literal syntax for zero/one/two argument lambdas.
Use % as the function's argument, %% as the second.

Examples:

- #`(+ 2 %) => (lambda (&optional x y) (+ 2 x))
- #`((print %) (1+ %)) => (lambda (&optional x) (print x) (1+ x))
- #`(+ 1 2) => (lambda (&optional x y) (+ 1 2))
- #`(+ % %%) => (lambda (&optional x y) (+ x y))
"
  (declare (ignore char arg))
  (let ((sexp (read stream t nil t)))
    `(trivial-positional-lambda ,(if (and (listp sexp) (listp (car sexp)))
                                     (cons 'progn sexp)
                                     sexp))))

(defmacro trivial-positional-lambda (&environment env body)
  (declare (ignorable env))
  (let ((x (gensym "X"))
        (y (gensym "Y")))
    `(lambda (&optional ,x ,y)
       (declare (ignorable ,x)
                (ignorable ,y))
       #-sbcl
       ,(subst y '%%
               (subst x '%
                      body))
       #+sbcl
       ,(sb-walker:walk-form
         body env
         (lambda (subform context env)
           (declare (ignore context env))
           (case subform
             (% x)
             (%% y)
             (t subform)))))))

(defun |#/-reader| (stream char arg)
  "Literal syntax for raw strings (which don't need escapin of control chars).

Example:

CL-USER> #/This is a \"test\" string/#
\"This is a \\\"test\\\" string\"
;; here \" are actually unescaped, but you can't write it in docstring :)
"
  (declare (ignore char arg))
  (with-output-to-string (str)
    (loop :for char := (read-char stream) :do
         (if (and (char= #\/ char)
                  (char= #\# (peek-char nil stream)))
             (progn (read-char stream)
                    (loop-finish))
             (write-char char str)))))

(defreadtable rutils-readtable
    (:merge :standard)
  (:macro-char #\} (get-macro-character #\)))
  (:dispatch-macro-char #\# #\v #'|#v-reader|)
  (:dispatch-macro-char #\# #\h #'|#h-reader|)
  (:dispatch-macro-char #\# #\{ #'|#{-reader|)
  (:dispatch-macro-char #\# #\` #'|#`-reader|)
  (:dispatch-macro-char #\# #\/ #'|#/-reader|))

)
Something went wrong with that request. Please try again.