changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/readtable.lisp

changeset 387: 8252ee515756
parent: 00d1c8afcdbb
child: d876b572b5b9
author: Richard Westhaver <ellis@rwest.io>
date: Thu, 30 May 2024 18:31:53 -0400
permissions: -rw-r--r--
description: db and readtables 
     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     (declare (ignore sub-char))
    14     (unless numarg (setq numarg 1))
    15     `(lambda ,(loop for i from 1 to numarg
    16                     collect (symb 'a i))
    17        ,(funcall
    18          (get-macro-character #\`) stream nil)))
    19 
    20   (defun |#f-reader| (stream sub-char numarg)
    21     (declare (ignore stream sub-char))
    22     (setq numarg (or numarg 3))
    23     (unless (<= numarg 3)
    24       (error "Bad value for #f: ~a" numarg))
    25     `(declare (optimize (speed ,numarg)
    26                         (safety ,(- 3 numarg)))))
    27 
    28   ;; Nestable suggestion from Daniel Herring
    29   (eval-when (:compile-toplevel :load-toplevel :execute)
    30     (defun |#"-reader| (stream sub-char numarg)
    31       (declare (ignore sub-char numarg))
    32       (let (chars (state 'normal) (depth 1))
    33         (loop do
    34                  (let ((curr (read-char stream)))
    35                    (cond ((eq state 'normal)
    36                           (cond ((char= curr #\#)
    37                                  (push #\# chars)
    38                                  (setq state 'read-sharp))
    39                                 ((char= curr #\")
    40                                  (setq state 'read-quote))
    41                                 (t
    42                                  (push curr chars))))
    43                          ((eq state 'read-sharp)
    44                           (cond ((char= curr #\")
    45                                  (push #\" chars)
    46                                  (incf depth)
    47                                  (setq state 'normal))
    48                                 (t
    49                                  (push curr chars)
    50                                  (setq state 'normal))))
    51                          ((eq state 'read-quote)
    52                           (cond ((char= curr #\#)
    53                                  (decf depth)
    54                                  (if (zerop depth) (return))
    55                                  (push #\" chars)
    56                                  (push #\# chars)
    57                                  (setq state 'normal))
    58                                 (t
    59                                  (push #\" chars)
    60                                  (if (char= curr #\")
    61                                      (setq state 'read-quote)
    62                                      (progn
    63                                        (push curr chars)
    64                                        (setq state 'normal)))))))))
    65         (coerce (nreverse chars) 'string))))
    66 
    67   ;; This version is from Martin Dirichs
    68   (defun |#>-reader| (stream sub-char numarg)
    69     (declare (ignore sub-char numarg))
    70     (let (chars)
    71       (do ((curr (read-char stream)
    72                  (read-char stream)))
    73           ((char= #\newline curr))
    74         (push curr chars))
    75       (let ((pattern (nreverse chars))
    76             output)
    77         (labels ((match (pos chars)
    78                    (if (null chars)
    79                        pos
    80                        (if (char= (nth pos pattern) (car chars))
    81                            (match (1+ pos) (cdr chars))
    82                            (match 0 (cdr (append (subseq pattern 0 pos) chars)))))))
    83           (do (curr
    84                (pos 0))
    85               ((= pos (length pattern)))
    86             (setf curr (read-char stream)
    87                   pos (match pos (list curr)))
    88             (push curr output))
    89           (coerce
    90            (nreverse
    91             (nthcdr (length pattern) output))
    92            'string))))))
    93 
    94 (defun segment-reader (stream ch n)
    95   (if (> n 0)
    96       (let ((chars))
    97         (do ((curr (read-char stream)
    98                    (read-char stream)))
    99             ((char= ch curr))
   100           (push curr chars))
   101         (cons (coerce (nreverse chars) 'string)
   102               (segment-reader stream ch (- n 1))))))
   103 
   104 (defmacro! match-mode-ppcre-lambda-form (o!args o!mods)
   105   ``(lambda (,',g!str)
   106       (cl-ppcre:scan-to-strings
   107        ,(if (zerop (length ,g!mods))
   108             (car ,g!args)
   109             (format nil "(?~a)~a" ,g!mods (car ,g!args)))
   110        ,',g!str)))
   111 
   112 (defmacro! subst-mode-ppcre-lambda-form (o!args)
   113   ``(lambda (,',g!str)
   114       (cl-ppcre:regex-replace-all
   115        ,(car ,g!args)
   116        ,',g!str
   117        ,(cadr ,g!args))))
   118 
   119 (eval-when (:compile-toplevel :load-toplevel :execute)
   120   (defun |#~-reader| (stream sub-char numarg)
   121     (declare (ignore sub-char numarg))
   122     (let ((mode-char (read-char stream)))
   123       (cond
   124         ((char= mode-char #\m)
   125          (match-mode-ppcre-lambda-form
   126           (segment-reader stream
   127                           (read-char stream)
   128                           1)
   129           (coerce (loop for c = (read-char stream)
   130                         while (alpha-char-p c)
   131                         collect c
   132                         finally (unread-char c stream))
   133                   'string)))
   134         ((char= mode-char #\s)
   135          (subst-mode-ppcre-lambda-form
   136           (segment-reader stream
   137                           (read-char stream)
   138                           2)))
   139         (t (error "Unknown #~~ mode character"))))))
   140 
   141 ;; #+cl-ppcre (set-dispatch-macro-character #\# #\~ #'|#~-reader|)
   142 (eval-when (:compile-toplevel :load-toplevel :execute)
   143   (defun lcurly-brace-reader (stream inchar)
   144     (declare (ignore inchar))
   145     (let ((spec (read-delimited-list #\} stream t)))
   146       (if (typep (car spec) '(integer 0))
   147           ;; Number of missing arguments
   148           (let* ((n (pop spec))
   149                  (extra-args (loop repeat n collect (gensym "A"))))
   150             (if (eq (cadr spec) '_)
   151                 (let ((provided-vars (loop repeat (length (cddr spec))
   152                                            collect (gensym "P"))))
   153                   `(let ,(mapcar #'list provided-vars (cddr spec))
   154                      (lambda ,extra-args (funcall (function ,(car spec))
   155                                                   ,@extra-args ,@provided-vars))))
   156                 (let ((provided-vars (loop repeat (length (cdr spec))
   157                                            collect (gensym "P"))))
   158                   `(let ,(mapcar #'list provided-vars (cdr spec))
   159                      (lambda ,extra-args (funcall (function ,(car spec))
   160                                                   ,@provided-vars ,@extra-args))))))
   161           (if (eq (cadr spec) '_)
   162               `(the (values function &optional) (rcurry (function ,(car spec)) ,@(cddr spec)))
   163               `(the (values function &optional) (curry (function ,(car spec)) ,@(cdr spec)))))))
   164 
   165   (defun lsquare-brace-reader (stream inchar)
   166     (declare (ignore inchar))
   167     (list 'the '(values function &optional)
   168           (cons 'compose (read-delimited-list #\] stream t))))
   169 
   170   (defun langle-quotation-reader (stream inchar)
   171     (declare (ignore inchar))
   172     (let ((contents (read-delimited-list #\» stream t))
   173           (args (gensym "langle-quotation-reader")))
   174       `(lambda (&rest ,args)
   175          (,(car contents)                 ; Join function (or macro).
   176           ,@(mapcar (lambda (fun) `(apply ,fun ,args)) (cdr contents))))))
   177 
   178   (defun lsingle-pointing-angle-quotation-mark-reader (stream inchar)
   179     (declare (ignore inchar))
   180     (flet ((function-p (form) (functionp (ignore-errors (eval form)))))
   181       (let ((contents (read-delimited-list #\› stream t))
   182             (arg (gensym "lsingle-pointing-angle-quotation-mark-reader")))
   183         `(lambda (,arg)
   184            (,(car contents)               ; Case form.
   185             ,@(case (car contents)       ; If/when/unless guard.
   186                 ((if when unless)
   187                  `((funcall ,(cadr contents) ,arg)))
   188                 (cond nil)
   189                 (t (list arg)))
   190             ,@(if (member (car contents) '(if when unless)) ; Clauses.
   191                   (mapcar (lambda (clause)
   192                             (if (function-p clause)
   193                                 `(funcall ,clause ,arg)
   194                                 clause))
   195                           (cddr contents))
   196                   (mapcar (lambda (clause)
   197                             `(,(if (function-p (car clause))
   198                                    `(funcall ,(car clause) ,arg)
   199                                    (car clause))
   200                               ,(if (function-p (cadr clause))
   201                                    `(funcall ,(cadr clause) ,arg)
   202                                    (cadr clause))))
   203                           (cdr contents)))))))))
   204 
   205 (defreadtable :std
   206   (:merge :modern)
   207   ;; curry
   208   (:macro-char #\{ #'lcurly-brace-reader)
   209   (:macro-char #\} (get-macro-character #\) ))
   210   (:macro-char #\[ #'lsquare-brace-reader)
   211   (:macro-char #\] (get-macro-character #\) ))
   212   (:macro-char #\« #'langle-quotation-reader)
   213   (:macro-char #\» (get-macro-character #\) ))
   214   (:macro-char #\‹ #'lsingle-pointing-angle-quotation-mark-reader)
   215   (:macro-char #\› (get-macro-character #\) ))
   216   ;; strings
   217   (:dispatch-macro-char #\# #\" #'|#"-reader|)
   218   (:dispatch-macro-char #\# #\> #'|#>-reader|)
   219   ;; regex
   220   (:dispatch-macro-char #\# #\~ #'|#~-reader|)
   221   ;; lambdas
   222   (:dispatch-macro-char #\# #\` #'|#`-reader|)
   223   (:dispatch-macro-char #\# #\f #'|#f-reader|))