Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
219 lines (188 sloc) 7.65 KB
(in-package #:advanced-readtable)
;;;; Advanced-readtable
;;;;
;;;; per-package aliases for packages
;;;; per-package shortcuts for package hierarchies
;;;; extendable find-package and find-symbol
;;;; local use package in form package:(here form where package used)
;;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern
;;;; package::symbol1 and package::symbol2
;;;
;;; Prepare readtables
;;;
(defvar *colon-readtable* (copy-readtable nil)
"Support readtable with colon as whitespace")
(set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
;;;
;;; Readtable handlers
;;;
(cl:defpackage #:advanced-readtable.junk)
(defvar *enable-symbol-readmacro* t
"Enables processing of symbol-readmacro.")
(declaim (type boolean *enable-symbol-readmacro*))
(declaim (ftype macro-symbol-handler process-symbol-readmacro))
(defun process-symbol-readmacro (stream symbol)
(let ((func (gethash symbol *symbol-readmacros*)))
(if (and func *enable-symbol-readmacro*)
(funcall func stream symbol) symbol)))
;; Internal special variable. Do not export
(defvar *car-list* nil "Boolean: iff reader in list and car is not read")
(defun collect-dots (stream)
(do ((n 0 (1+ n))
(c (read-char stream nil) (read-char stream nil)))
((or (null c) (char/= c #\.))
(when c
(unread-char c stream))
(if (and (plusp n) (member c '(nil #\Space #\) #\( #\Tab #\Newline #\:)))
(intern (make-string n :initial-element #\.))
(dotimes (foo n) (unread-char #\. stream))))))
(defun read-token (stream)
"
DO: Reads from STREAM a symbol or number up to whitespace or colon
RETURN: symbols name or numbers value"
(let ((*readtable* *colon-readtable*)
(*package* (|CL|:find-package '#:advanced-readtable.junk)))
(or (collect-dots stream)
(read-preserving-whitespace stream nil))))
(defun count-colons (stream)
"
DO: Reads colons from STREAM
RETURN: number of the colons"
(do ((n 0 (1+ n))
(c (read-char stream nil) (read-char stream nil)))
((or (null c) (char/= c #\:))
(when c (unread-char c stream)) n)))
(defun read-after-colon (stream maybe-package colons)
"Read symbol package:sym or list package:(...)"
(declare (type stream stream)
(type integer colons))
(check-type colons (integer 0 2))
(when (= colons 0) ; no colon: this is a symbol or an atom
(return-from read-after-colon
(if (symbolp maybe-package)
(prog1
(let ((name (symbol-name maybe-package)))
(or (find-symbol name) (intern name)))
(unintern maybe-package))
maybe-package)))
(let ((package (find-package maybe-package)))
(assert package (package) "No package ~a" maybe-package)
(unintern maybe-package)
(when (eql (peek-char t stream) #\()
;; package:(...) or package::(...)
(ecase colons
(1 (let ((*local-packages* (cons package *local-packages*)))
(return-from read-after-colon
(read stream nil))))
(2 (let ((*package* package))
(return-from read-after-colon
(read stream nil))))))
(let ((token (read-token stream)))
(check-type token symbol)
(multiple-value-bind (symbol status)
(find-symbol (symbol-name token) package)
(unless status
(if (= colons 1) (error "No external symbol ~S in ~S"
(symbol-name token) package)
(progn
(warn "No such symbol ~S in package ~S. Interning..."
(symbol-name token) package)
(setf symbol (intern (symbol-name token) package)))))
(unintern token)
(when (and (= colons 1) (not (eq status :external)))
(cerror "Use anyway"
"Symbol ~A not external" symbol))
symbol))))
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun read-token-with-colons (stream char)
"Reads token, then analize package part if needed"
(unread-char char stream)
(let* ((token (read-token stream))
;; We have read something.
;; It may represent either symbol or package designator.
;; Looking after it: do we have a colon?
(colons (count-colons stream))
(object (read-after-colon stream token colons)))
(when (or (not (symbolp object))
(eql char #\|))
(return-from read-token-with-colons (and (not *read-suppress*) object)))
(let ((object (process-symbol-readmacro stream object)))
(when *car-list*
(setf *car-list* nil
*current-extra-finders*
(append (extra-finders object) *current-extra-finders*)))
(and (not *read-suppress*) object))))
(let ((default-open-paren-reader
(get-macro-character #\( (copy-readtable nil))))
(defun open-paren-reader (stream char)
(let ((*car-list* t) (*current-extra-finders* *current-extra-finders*))
(funcall default-open-paren-reader stream char)))))
;;;
;;; Readtable analysis and change
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-case (case &body body)
(let ((save (gensym)))
`(let ((,save (readtable-case *readtable*)))
(setf (readtable-case *readtable*) ,case)
(unwind-protect
(progn ,@body)
(setf (readtable-case *readtable*) ,save)))))
(defun does-not-terminate-token-p (c)
(ignore-errors
(let ((str (format nil "a~Ab" c)))
(string= str (symbol-name
(with-case :preserve
(read-from-string (format nil "#:~A" str))))))))
(defun whitespace-p (c)
(ignore-errors
(= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
(defun multiple-escape-p (c)
(ignore-errors
(string= "qQ" (symbol-name
(with-case :upcase
(read-from-string (format nil "#:~AqQ~A" c c)))))))
(defun single-escape-p (c)
(ignore-errors
(string= (symbol-name '#:\ ) (symbol-name
(read-from-string
(format nil "#:~A'" c))))))
(defun macro-char-p (c)
"If C is macro-char, return GET-MACRO-CHARACTER"
#+allegro (unless
(eql (get-macro-character c) #'excl::read-token)
(get-macro-character c))
#-allegro (get-macro-character c))
(defun to-process (c)
(cond
((eql c #\:) nil)
((macro-char-p c) nil)
((does-not-terminate-token-p c) t)
((whitespace-p c) nil)
((multiple-escape-p c) t)
((single-escape-p c) t)
(t nil)))
(defparameter +additional-chars+ ""
"Fill this, if you need extra characters for packages to begin with")
(defun chars-to-process ()
(let ((*readtable* (copy-readtable nil)))
(nconc
(loop :for i :from 0 :to 127
:for c = (code-char i)
:when (to-process c) :collect c)
(loop :for c :across +additional-chars+
:when (to-process c) :collect c)))))
(macrolet ((def-advanced-readtable ()
`(defreadtable :advanced
(:merge :standard)
,@(mapcar (lambda (c)
(list :macro-char c
'(function read-token-with-colons) t))
(chars-to-process))
(:macro-char #\( #'open-paren-reader nil))))
(def-advanced-readtable))
(defun activate ()
(dolist (c (chars-to-process))
(set-macro-character c #'read-token-with-colons t))
(set-macro-character #\( #'open-paren-reader nil))
(defun ! () (in-readtable :advanced))