Coverage report: /home/ellis/comp/core/std/readtable.lisp

KindCoveredAll%
expression49237 20.7
branch1130 36.7
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/readtable.lisp --- The Standard Readtable
2
 
3
 ;; This readtable is accessible to systems which depend on the STD
4
 ;; package.
5
 
6
 ;;; Usage: (in-readtable :std)
7
 
8
 ;;; Code:
9
 (in-package :std/readtable)
10
 
11
 (eval-when (:compile-toplevel :execute :load-toplevel)
12
   (defun |#`-reader| (stream sub-char numarg)
13
     "Sharp Backquote (#`) reader - quoted lambda shorthand.
14
 
15
 Defines a lambda with the arg count determined by the numeric reader arg.
16
 
17
 (funcall #2`(,a1 ,@a2) 0 '(1 2 3 4)) ;= (0 1 2 3 4)"
18
     (declare (ignore sub-char))
19
     (unless numarg (setq numarg 1))
20
     `(lambda ,(loop for i from 1 to numarg
21
                     collect (symb 'a i))
22
        ,(funcall
23
          (get-macro-character #\`) stream nil)))
24
 
25
   (defun |#l-reader| (stream sub num)
26
     "Sharp L reader - logical pathname translation."
27
     (declare (ignore sub num))
28
     `(translate-logical-pathname (pathname ,(read stream))))
29
 
30
   ;; Nestable suggestion from Daniel Herring
31
   (defun |#"-reader| (stream sub-char numarg)
32
     "Sharp Double-quote reader - nestable strings.
33
 
34
 Output is quoted appropriated - simply wrap outer-most double-quotes in
35
 sharps."
36
     (declare (ignore sub-char numarg))
37
     (let (chars (state 'normal) (depth 1))
38
       (loop do
39
                (let ((curr (read-char stream)))
40
                  (cond ((eq state 'normal)
41
                         (cond ((char= curr #\#)
42
                                (push #\# chars)
43
                                (setq state 'read-sharp))
44
                               ((char= curr #\")
45
                                (setq state 'read-quote))
46
                               (t
47
                                (push curr chars))))
48
                        ((eq state 'read-sharp)
49
                         (cond ((char= curr #\")
50
                                (push #\" chars)
51
                                (incf depth)
52
                                (setq state 'normal))
53
                               (t
54
                                (push curr chars)
55
                                (setq state 'normal))))
56
                        ((eq state 'read-quote)
57
                         (cond ((char= curr #\#)
58
                                (decf depth)
59
                                (if (zerop depth) (return))
60
                                (push #\" chars)
61
                                (push #\# chars)
62
                                (setq state 'normal))
63
                               (t
64
                                (push #\" chars)
65
                                (if (char= curr #\")
66
                                    (setq state 'read-quote)
67
                                    (progn
68
                                      (push curr chars)
69
                                      (setq state 'normal)))))))))
70
       (coerce (nreverse chars) 'string))))
71
 
72
 (defun segment-reader (stream ch n)
73
   "Recursively read a CH delimited sequence of strings from STREAM. N is a
74
 recursion count. Used internally by the CL-PPCRE reader (#~)."
75
   (if (> n 0)
76
       (let ((chars))
77
         (do ((curr (read-char stream)
78
                    (read-char stream)))
79
             ((char= ch curr))
80
           (push curr chars))
81
         (cons (coerce (nreverse chars) 'string)
82
               (segment-reader stream ch (- n 1))))))
83
 
84
 (defmacro! scan-mode-ppcre-lambda-form (o!args)
85
   ``(lambda (,',g!str)
86
       (cl-ppcre:scan
87
        ,(car ,g!args)
88
        ,',g!str)))
89
 
90
 (defmacro! match-mode-ppcre-lambda-form (o!args o!mods)
91
   ``(lambda (,',g!str)
92
       (cl-ppcre:scan-to-strings
93
        ,(if (zerop (length ,g!mods))
94
             (car ,g!args)
95
             (format nil "(?~a)~a" ,g!mods (car ,g!args)))
96
        ,',g!str)))
97
 
98
 (defmacro! subst-mode-ppcre-lambda-form (o!args)
99
   ``(lambda (,',g!str)
100
       (cl-ppcre:regex-replace-all
101
        ,(car ,g!args)
102
        ,',g!str
103
        ,(cadr ,g!args))))
104
 
105
 (eval-when (:compile-toplevel :load-toplevel :execute)
106
   (defun |#~-reader| (stream sub-char numarg)
107
     "Sharp-tilde reader - Perl-like Regexp shorthand.
108
 
109
 NUMARG is the mode to use:
110
 0 : scan-mode
111
 1 : match-mode
112
 2 : replace-mode
113
 
114
 #1~/abc/ ;= #<function>
115
 (funcall * \"123abc\") ;= \"abc\" #()
116
 
117
 (funcall #2~/abc// \"abcdef\") ;= \"def\" T
118
 (funcall #0~/abc/ \"abcdef\") ;= 0 3 #() #()"
119
     (declare (ignore sub-char))
120
     (ecase numarg
121
       (0 (scan-mode-ppcre-lambda-form
122
           (segment-reader 
123
            stream
124
            (read-char stream)
125
            1)))
126
       (1 (match-mode-ppcre-lambda-form
127
           (segment-reader stream
128
                           (read-char stream)
129
                           1)
130
           (coerce (loop for c = (read-char stream)
131
                         while (alpha-char-p c)
132
                         collect c
133
                         finally (unread-char c stream))
134
                   'string)))
135
       (2 (subst-mode-ppcre-lambda-form
136
           (segment-reader stream
137
                           (read-char stream)
138
                           2))))))
139
 
140
 (eval-when (:compile-toplevel :load-toplevel :execute)
141
   (defun |{-reader| (stream inchar)
142
     "Curly-brace reader - curry shorthand.
143
 
144
 The car of the 'curly-form' is a function which is curried with the cdr. The
145
 cdr may contain the special symbol '_' which will be bound to the function and
146
 indicates a recursive call (RCURRY instead of CURRY).
147
 
148
 '{car _} ;= (THE (VALUES FUNCTION &OPTIONAL) (RCURRY #'CAR))
149
 
150
 (funcall {car (list 1 2 3)}) ;= 1"
151
     (declare (ignore inchar))
152
     (let ((spec (read-delimited-list #\} stream t)))
153
       (if (typep (car spec) '(integer 0))
154
           ;; Number of missing arguments
155
           (let* ((n (pop spec))
156
                  (extra-args (loop repeat n collect (gensym "A"))))
157
             (if (eq (cadr spec) '_)
158
                 (let ((provided-vars (loop repeat (length (cddr spec))
159
                                            collect (gensym "P"))))
160
                   `(let ,(mapcar #'list provided-vars (cddr spec))
161
                      (lambda ,extra-args (funcall (function ,(car spec))
162
                                                   ,@extra-args ,@provided-vars))))
163
                 (let ((provided-vars (loop repeat (length (cdr spec))
164
                                            collect (gensym "P"))))
165
                   `(let ,(mapcar #'list provided-vars (cdr spec))
166
                      (lambda ,extra-args (funcall (function ,(car spec))
167
                                                   ,@provided-vars ,@extra-args))))))
168
           (if (eq (cadr spec) '_)
169
               `(the (values function &optional) (rcurry (function ,(car spec)) ,@(cddr spec)))
170
               `(the (values function &optional) (curry (function ,(car spec)) ,@(cdr spec)))))))
171
 
172
   (defun |[-reader| (stream inchar)
173
     "Square-bracket reader - compose shorthand.
174
 
175
 '[#'car #'cdr] ;= (THE (VALUES FUNCTION &OPTIONAL) (COMPOSE #'CAR #'CDR))
176
 
177
 (funcall ['car 'cdr] (list 1 2 3)) ;= 2"
178
     (declare (ignore inchar))
179
     (list 'the '(values function &optional)
180
           (cons 'compose (read-delimited-list #\] stream t)))))
181
 
182
 ;; f-strings
183
 ;; ref: https://realpython.com/python-f-strings/
184
 (eval-when (:compile-toplevel :load-toplevel :execute)
185
   ;; TODO 2025-06-23: 
186
   (defun |#f-reader| (stream subchar num)
187
     "Sharp-f reader - Python-like f-strings.
188
 
189
 #f\"foo: {foo}, bar: {bar}~%\" ;= (format nil \"foo: ~A, bar: ~A~%\" foo bar)"
190
     (declare (ignore subchar))
191
     (format (case num
192
               (1 t)
193
               (2 *debug-io*)
194
               (t nil))
195
             (read stream))))
196
 
197
 ;; Define the standard readtable with built-in functionality. We overwrite the
198
 ;; braces [] and {} but ! and ? are free for now.
199
 (defreadtable :std
200
   "The standard readtable, available for use internally in core source code or
201
 externally by users. Don't modify this readtable directly - create your own
202
 copy if necessary."
203
   (:merge :modern)
204
   ;; curry
205
   (:macro-char #\{ #'|{-reader|)
206
   (:macro-char #\} (get-macro-character #\) ))
207
   (:macro-char #\[ #'|[-reader|)
208
   (:macro-char #\] (get-macro-character #\) ))
209
   ;; strings
210
   (:dispatch-macro-char #\# #\" #'|#"-reader|)
211
   (:dispatch-macro-char #\# #\f #'|#f-reader|)
212
   ;; regex
213
   (:dispatch-macro-char #\# #\~ #'|#~-reader|)
214
   ;; lambdas
215
   (:dispatch-macro-char #\# #\` #'|#`-reader|)
216
   ;; logical paths
217
   (:dispatch-macro-char #\# #\l #'|#l-reader|))