浏览代码

general update

master
Michał Herda 4 年前
父节点
当前提交
5440d52789
共有 1 个文件被更改,包括 59 次插入49 次删除
  1. 59
    49
      pseudonyms.lisp

+ 59
- 49
pseudonyms.lisp 查看文件

@@ -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

正在加载...
取消
保存