Skip to content

Instantly share code, notes, and snippets.

@g000001
Created September 4, 2023 04:08
Show Gist options
  • Save g000001/910326c3c6d148b017f1d4f67de7678d to your computer and use it in GitHub Desktop.
Save g000001/910326c3c6d148b017f1d4f67de7678d to your computer and use it in GitHub Desktop.
tao-here-document-reader.lisp
;;; -*- 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)
||#
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment