Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
clojure-like nickname system in Common 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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment