tao-here-document-reader.lisp

gistfile1.txt

;;; -*- mode: Lisp; coding: utf-8  -*-

(cl:in-package "CL-USER")


(defvar *standard-readtable* (copy-readtable nil))


(defvar *nest-level* 0)


(defun make-marker/next-form-alist (markers next-forms)
  (let ((marker/next-form-alist '()))
    (dolist (next next-forms)
      (push (cons (find (named-paren-name next) markers
                        :key #'next-form-marker-name)
                  next)
            marker/next-form-alist))
    marker/next-form-alist))


(defun replace-mark (marker/next-form-alist form)
  (dolist (m/nf marker/next-form-alist)
    (destructuring-bind (m . nf)
                        m/nf
      (setq form
            (if (next-form-marker-named-paren? m)
                (if (next-form-marker-splicing? m)
                    (subst/splicing (named-paren-form nf) m form)
                    (subst (named-paren-form nf) m form))
                (subst (named-paren-form nf) m form)))))
  form)


(defun read-\( (srm chr)
  (let* ((form (let ((*nest-level* (1+ *nest-level*)))
                 (funcall (get-macro-character #\( *standard-readtable*)
                          srm chr)))
         (flat-form (alexandria:flatten form)))
    (if (and (zerop *nest-level*)
             (find-if (lambda (form)
                        (typep form 'next-form-marker))
                      flat-form))
        (flet ((make-canonicalized-next-form (mark)
                 (let ((next (read srm T nil T)))
                   (typecase next
                     (named-paren next)
                     (next-form-marker
                      (make-named-paren :name (next-form-marker-name next)
                                        :form (read srm T nil T)))
                     (T (make-named-paren :name (next-form-marker-name mark)
                                          :form next))))))
          (let* ((markers (remove-if-not #'next-form-marker-p flat-form))
                 (next-forms (mapcar #'make-canonicalized-next-form markers)))
            (replace-mark (make-marker/next-form-alist markers next-forms)
                          form)))
        form)))


(defun terminating-char-p (char)
  (multiple-value-bind (macro? terminating?)
                       (get-macro-character char)
    (and macro? (not terminating?))))


(defstruct next-form-marker name splicing? named-paren?)


(defun subst/splicing (new old list)
  (cond ((null list) '())
        ((atom list) list)
        ((eql old (car list))
         (append new
                 (subst/splicing new old (cdr list))))
        (T (cons (subst/splicing new old (car list))
                 (subst/splicing new old (cdr list))))))


(defun read-\#_ (srm chr arg)
  (declare (ignore chr arg))
  (let ((next-char (peek-char nil srm T nil T)))
    (make-next-form-marker :name (if (or (terminating-char-p next-char)
                                         (find next-char '(#\Space #\Tab #\Newline)))
                                     '||
                                     (read srm T nil T)))))


(defstruct named-paren name form)


(defun named-paren-reader (srm chr arg)
  (declare (ignore arg chr))
  (let ((mark (read srm T nil T)))
    (if (zerop *nest-level*)
        (let* ((end-mark (intern (concatenate 'string "END-OF-" (string mark)))))
          (make-named-paren :name mark
                            :form (loop :for form := (read srm T nil T)
                                        :until (eq end-mark form)
                                        :collect form)))
        (make-next-form-marker :name mark
                               :splicing? T
                               :named-paren? T))))


(progn
  (set-macro-character #\( #'read-\()
  (set-dispatch-macro-character #\# #\_ #'read-\#_)
  (set-dispatch-macro-character #\# #\. #'named-paren-reader))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#||
(aaa
 bbb
 ccc
 #_d
 #_g)
#_g (ggg hhh iii)
#_d (ddd eee fff)

==> (AAA BBB CCC (DDD EEE FFF) (GGG HHH III))

(aaa
 bbb
 #_
 ccc)
(ddd eee #_)
(ggg hhh iii)

==> (AAA BBB (DDD EEE (GGG HHH III)) CCC)

(aaa bbb #_kkk ccc)
#_kkk (ddd eee fff)

==> (AAA BBB (DDD EEE FFF) CCC)

(defclass foo ()
  (#_a #_b #_c))

(a :initform 0)
(b :initform 1)
(c :initform 2)

==> (DEFCLASS FOO () ((A :INITFORM 0) (B :INITFORM 1) (C :INITFORM 2)))

(aa bb #.kk cc)
#.kk
foo
bar
baz
end-of-kk

==> (AA BB FOO BAR BAZ CC)

(!aSpaceShip
   (obj-let ((x 0) (y 0))
#.methods
#.mmh
@ ))

#.mmh
mmh0
mmh1
mmh2
end-of-mmh

#.methods
method0
method1
method2
end-of-methods
==>
(!ASPACESHIP
 (OBJ-LET ((X 0) (Y 0))
   METHOD0
   METHOD1
   METHOD2
   MMH0
   MMH1
   MMH2
   @))

(aa bb #.kk cc)
#.kk
(dd)
ee
(fff ggg)
end-of-kk
==> (AA BB (DD) EE (FFF GGG) CC)

||#