clojure-like nickname system in Common Lisp

alias-package.lisp

(defpackage alias-package
  (:use :common-lisp)
  (:export :import-as
     :init-readtable
	   :register-nickname))

(in-package :alias-package)

(defparameter *prev-readtable* (copy-readtable nil))

(defparameter *match-tree* (make-hash-table :test #'eql))

(defparameter *buffer* nil)

(defun force-symbol-string (s)
  (typecase s
    (string (map 'string #'char-upcase #'force-symbol-char s))
    (symbol (symbol-name s))))

(defmacro init-readtable ()
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (setf *prev-readtable* (copy-readtable *readtable*))
     (setf *match-tree* (make-hash-table :test #'eql))
     (loop :for c :across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890!$%&*+-./<=>?:"
	:do (set-macro-character c #'read-nickname))))


(defun search-nickname (stream tree)
  (let* ((c    (read-char stream))
	 (next (gethash (force-symbol-char c) tree)))
    (push c *buffer*)
    (if next
	(typecase next
	  (hash-table (search-nickname stream next))
	  (string     next))
	nil)))

(defun register-nickname% (name i package tree)
  (cond ((= (length name) i)
	 (setf (gethash #\: tree) package))
	((gethash (force-symbol-char (char name i)) tree) 
	 (register-nickname% name (1+ i) package (gethash (force-symbol-char (char name i)) tree)))
	(t
	 (setf (gethash (force-symbol-char (char name i)) tree) (make-hash-table :test #'eql))
	 (register-nickname% name (1+ i) package (gethash (force-symbol-char (char name i)) tree)))))

(defun register-nickname (name package)
  (register-nickname% (force-symbol-string name) 0 (force-symbol-string package) *match-tree*))

(defun white-space-p (c)
  (member c '(#\Space #\Tab #\Newline #\Linefeed #\Page #\Return)))

(defun read-token (stream)
  (coerce 
   (loop :for c := (peek-char nil stream nil #\Space)
      :until   (or (white-space-p c) (char= c #\)))
      :do      (read-char stream)
      :collect c)
   'string))

(defun read-nickname (stream char)
  (unread-char char stream)
  (setq *buffer* nil)
  (let ((truename (search-nickname stream *match-tree*))
	(*readtable* *prev-readtable*))
    (if truename
	(read-from-string (concatenate 'string truename ":" (force-symbol-string (read-token stream))))
	(read-from-string (concatenate 'string (reverse *buffer*) (read-token stream))))))



(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun expand-specs (args lst)
    (if (null args)
	lst
	(expand-specs (cddr args) (cons `(register-nickname ,(cadr args) ,(car args)) lst)))))

(defmacro import-as (&rest specs)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (init-readtable)
     ,@(expand-specs specs nil)))