|
|
@@ -8,14 +8,14 @@ |
|
|
|
;;;; |
|
|
|
;;;; pseudonyms.lisp |
|
|
|
|
|
|
|
(in-package #:pseudonyms) |
|
|
|
(in-package :pseudonyms) |
|
|
|
|
|
|
|
;;; ======================================================================== |
|
|
|
;;; GLOBAL VARIABLES |
|
|
|
|
|
|
|
(defparameter *pseudonym-table* |
|
|
|
(make-weak-hash-table :test #'equal :weakness :key) |
|
|
|
"This is a global package-name-indexed hashtable holding name-pseudonym plists.") |
|
|
|
"This is a global package-name-indexed hashtable holding package-name-and-pseudonym plists.") |
|
|
|
|
|
|
|
;;; ======================================================================== |
|
|
|
;;; HELPER FUNCTIONS AND TYPES |
|
|
@@ -41,7 +41,7 @@ returns a key." |
|
|
|
;;; ======================================================================== |
|
|
|
;;; DEFINE/UNDEFINE FUNCTIONS |
|
|
|
|
|
|
|
(defun defpseudonym (raw-name raw-pseudonym &key (package (package-name *package*))) |
|
|
|
(defun defpseudonym (package pseudonym &key (inside-package (package-name *package*))) |
|
|
|
"This, given a package name and a pseudonym for it, allows you to use a local pseudonym in |
|
|
|
form $pseudonym:symbol instead of name:symbol within your code. This pseudonym is local to the |
|
|
|
package you called defpseudonym in (as shown by the global variable *PACKAGE*). |
|
|
@@ -52,61 +52,58 @@ An optional argument allows you to set a pseudonym for a different package. |
|
|
|
Pseudonyms are always converted to lowercase. |
|
|
|
|
|
|
|
This will signal an error whenever a nickname or pseudonym is already taken." |
|
|
|
(check-type raw-name string-designator) |
|
|
|
(check-type raw-pseudonym string-designator) |
|
|
|
(let* ((table (gethash (string-downcase package) *pseudonym-table*)) |
|
|
|
(name (string-downcase raw-name)) |
|
|
|
(pseudonym (string-downcase raw-pseudonym)) |
|
|
|
(first (car table))) |
|
|
|
(assert (not (member "" (list name pseudonym) :test #'string=)) |
|
|
|
(name pseudonym) |
|
|
|
"Name and pseudonym may not be empty.") |
|
|
|
(assert (not (string= name pseudonym)) |
|
|
|
(name pseudonym) |
|
|
|
"Pseudonyming ~S to itself is not a good idea." name) |
|
|
|
(assert (not (string=-getf table name)) |
|
|
|
(name) |
|
|
|
"This name is already taken by pseudonym ~S." |
|
|
|
(string=-getf table name)) |
|
|
|
(check-type package string-designator) |
|
|
|
(check-type pseudonym string) |
|
|
|
(check-type inside-package string-designator) |
|
|
|
(assert (not (member "" (list package pseudonym inside-package) :test #'string=)) |
|
|
|
(package pseudonym inside-package) |
|
|
|
"Arguments may not be empty strings.") |
|
|
|
(let* ((table (gethash inside-package *pseudonym-table*)) |
|
|
|
(first (car table)) |
|
|
|
(package (string package)) |
|
|
|
(inside-package (string inside-package))) |
|
|
|
(assert (not (string=-getf-key table pseudonym)) |
|
|
|
(pseudonym) |
|
|
|
"This pseudonym is already taken by name ~S." |
|
|
|
"This package is already taken by pseudonym ~S." |
|
|
|
(string=-getf table package)) |
|
|
|
(assert (not (string=-getf table package)) |
|
|
|
(package) |
|
|
|
"This pseudonym is already taken by package ~S." |
|
|
|
(string=-getf-key table pseudonym)) |
|
|
|
(if (null table) |
|
|
|
(setf (gethash (string-downcase package) *pseudonym-table*) |
|
|
|
(cons name (cons pseudonym nil))) |
|
|
|
(setf (car table) name |
|
|
|
(setf (gethash inside-package *pseudonym-table*) |
|
|
|
(cons package (cons pseudonym nil))) |
|
|
|
(setf (car table) package |
|
|
|
(cdr table) (cons pseudonym (cons first (cdr table))))) |
|
|
|
(format nil "~A => ~A" pseudonym name))) |
|
|
|
(format nil "~A => ~A" pseudonym package))) |
|
|
|
|
|
|
|
(defun pmakunbound (datum &key (package (package-name *package*))) |
|
|
|
(defun pmakunbound (datum &key (inside-package (package-name *package*))) |
|
|
|
"This, given either a nickname-bound package name or a package name-bound nickname, clears |
|
|
|
any name-nickname pair bound to it. |
|
|
|
|
|
|
|
Argument must be a string designator. |
|
|
|
An optional argument allows you to clear a pseudonym from a different package." |
|
|
|
(check-type datum string-designator) |
|
|
|
(let ((table (gethash (string-downcase package) *pseudonym-table*))) |
|
|
|
(setf datum (string-downcase datum) |
|
|
|
table |
|
|
|
(let ((table (gethash inside-package *pseudonym-table*)) |
|
|
|
(datum (string datum))) |
|
|
|
(setf (gethash inside-package *pseudonym-table*) |
|
|
|
(loop for (key value) on table by #'cddr |
|
|
|
unless (or (equal key datum) (equal value datum)) |
|
|
|
collect key and collect value))) |
|
|
|
(string-downcase datum)) |
|
|
|
datum) |
|
|
|
|
|
|
|
;;; ======================================================================== |
|
|
|
;;; UTILITIES |
|
|
|
|
|
|
|
(defun print-pseudonyms (&key (package (package-name *package*))) |
|
|
|
(defun print-pseudonyms (&key (inside-package (package-name *package*))) |
|
|
|
"This prints all pseudonyms in a fancy manner. |
|
|
|
Optional argument designates the package name, from inside which pseudonyms should be printed." |
|
|
|
(check-type package string-designator) |
|
|
|
(let* ((string (string-downcase package)) |
|
|
|
(table (gethash string *pseudonym-table*))) |
|
|
|
(check-type inside-package string) |
|
|
|
(let* ((table (gethash inside-package *pseudonym-table*))) |
|
|
|
(if (null table) |
|
|
|
(format t "No pseudonyms defined for package ~:@(~A~).~%" package) |
|
|
|
(format t "No pseudonyms defined for package ~:@(~A~).~%" inside-package) |
|
|
|
(progn |
|
|
|
(format t "pseudonym => name (package ~:@(~A~)):~%" package) |
|
|
|
(format t "pseudonym => name (inside package ~:@(~A~)):~%" inside-package) |
|
|
|
(list-length |
|
|
|
(loop for (key value) on table by #'cddr collecting key |
|
|
|
do (format t "~S => ~S~%" value key))))))) |
|
|
@@ -119,19 +116,32 @@ Optional argument designates the package name, from inside which pseudonyms shou |
|
|
|
(defun pseudonym-reader (stream char) |
|
|
|
"This is the reader macro for local pseudonyms." |
|
|
|
(declare (ignore char)) |
|
|
|
(let* ((table (gethash (string-downcase (package-name *package*)) *pseudonym-table*)) |
|
|
|
(pseudlist (loop for char = (read-char stream) |
|
|
|
collect char |
|
|
|
until (equal (peek-char nil stream) #\:))) |
|
|
|
(pseudonym (string-downcase (concatenate 'string pseudlist))) |
|
|
|
(name (string=-getf-key table pseudonym)) |
|
|
|
(symbol (read stream))) |
|
|
|
;;(format t "debug: ~A ~A ~A ~A ~A ~A~%" |
|
|
|
;;(string-downcase (package-name *package*)) |
|
|
|
;;pseudlist pseudonym table name symbol) |
|
|
|
(assert (not (null name)) () |
|
|
|
"Pseudonym ~S was not set. Check your spelling or use defpseudonym." |
|
|
|
pseudonym) |
|
|
|
(read-from-string (format nil "~A:~A" name symbol)))) |
|
|
|
(labels ((valid (char) |
|
|
|
(when (equal char (or #\Space #\Tab #\Return #\Newline)) |
|
|
|
(error "Whitespace encountered when processing nickname.")))) |
|
|
|
(let* ((table (gethash (package-name *package*) *pseudonym-table*)) |
|
|
|
(pseudlist (loop for char = (read-char stream) |
|
|
|
collect char |
|
|
|
do (when (valid char)) |
|
|
|
until (equal (peek-char nil stream) #\:))) |
|
|
|
(pseudonym (concatenate 'string pseudlist)) |
|
|
|
(name (string=-getf-key table pseudonym)) |
|
|
|
(intern-p (eq 2 (list-length (loop for char = (peek-char nil stream) |
|
|
|
while (equal char #\:) |
|
|
|
do (read-char stream) |
|
|
|
collect char)))) |
|
|
|
(symbol (read stream))) |
|
|
|
;;(format t "debug: ~S ~S ~S ~S ~S ~S ~S~%" |
|
|
|
;;(package-name *package*) pseudlist table name pseudonym symbol intern-p) |
|
|
|
;;(format t "debug: ~S ~S ~S~%" symbol name intern-p) |
|
|
|
(assert (not (null name)) () |
|
|
|
"Pseudonym ~S was not set. Check your spelling or use defpseudonym." |
|
|
|
pseudonym) |
|
|
|
(if (or intern-p (find-symbol (string symbol) name)) |
|
|
|
(intern (string symbol) name) |
|
|
|
(error "Symbol ~S not found in the ~A package." |
|
|
|
(string symbol) (string name)))))) |
|
|
|
|
|
|
|
;; todo: named readtables |
|
|
|
;; todo: customizable macro character? |
|
|
|
;; DONE: fix : / :: issue |