A reader-macro way to create non-destructive nicknames within portable Common Lisp
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

pseudonyms.lisp 5.8KB

  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;; pseudonyms
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;;; thanks to:
  5. ;;;; #lisp@freenode: pjb, blubjr, sid_cypher, PuercoPop, shka
  6. ;;;; for testing and ideas
  7. ;;;; license: FreeBSD (BSD 2-clause)
  8. ;;;;
  9. ;;;; pseudonyms.lisp
  10. (in-package :pseudonyms)
  11. ;;; ========================================================================
  13. (defparameter *pseudonym-table*
  14. (make-weak-hash-table :test #'equal :weakness :key)
  15. "This is a global package-name-indexed hashtable holding package-name-and-pseudonym plists.")
  16. ;;; ========================================================================
  18. (deftype string-designator () '(or string symbol character))
  19. (defun string=-getf (plist indicator)
  20. "This is a version of getf utilizing string= for comparison. Given a plist and a key, returns
  21. a value."
  22. (loop for key in plist by #'cddr
  23. for value in (rest plist) by #'cddr
  24. when (string= key indicator)
  25. return value))
  26. (defun string=-getf-key (plist indicator)
  27. "This is a version of getf utilizing string= for comparison. Given a plist and a value,
  28. returns a key."
  29. (loop for key in plist by #'cddr
  30. for value in (rest plist) by #'cddr
  31. when (string= value indicator)
  32. return (values key)))
  33. ;;; ========================================================================
  35. (defun defpseudonym (package pseudonym &key (inside-package (package-name *package*)))
  36. "This, given a package name and a pseudonym for it, allows you to use a local pseudonym in
  37. form $pseudonym:symbol instead of name:symbol within your code. This pseudonym is local to the
  38. package you called defpseudonym in (as shown by the global variable *PACKAGE*).
  39. Arguments must be a pair of non-empty non-equal string designators.
  40. An optional argument allows you to set a pseudonym for a different package.
  41. Pseudonyms are always converted to lowercase.
  42. This will signal an error whenever a nickname or pseudonym is already taken."
  43. (check-type package string-designator)
  44. (check-type pseudonym string)
  45. (check-type inside-package string-designator)
  46. (assert (not (member "" (list package pseudonym inside-package) :test #'string=))
  47. (package pseudonym inside-package)
  48. "Arguments may not be empty strings.")
  49. (let* ((table (gethash inside-package *pseudonym-table*))
  50. (first (car table))
  51. (package (string package))
  52. (inside-package (string inside-package)))
  53. (assert (not (string=-getf-key table pseudonym))
  54. (pseudonym)
  55. "This package is already taken by pseudonym ~S."
  56. (string=-getf table package))
  57. (assert (not (string=-getf table package))
  58. (package)
  59. "This pseudonym is already taken by package ~S."
  60. (string=-getf-key table pseudonym))
  61. (if (null table)
  62. (setf (gethash inside-package *pseudonym-table*)
  63. (cons package (cons pseudonym nil)))
  64. (setf (car table) package
  65. (cdr table) (cons pseudonym (cons first (cdr table)))))
  66. (format nil "~A => ~A" pseudonym package)))
  67. (defun pmakunbound (datum &key (inside-package (package-name *package*)))
  68. "This, given either a nickname-bound package name or a package name-bound nickname, clears
  69. any name-nickname pair bound to it.
  70. Argument must be a string designator.
  71. An optional argument allows you to clear a pseudonym from a different package."
  72. (check-type datum string-designator)
  73. (let ((table (gethash inside-package *pseudonym-table*))
  74. (datum (string datum)))
  75. (setf (gethash inside-package *pseudonym-table*)
  76. (loop for (key value) on table by #'cddr
  77. unless (or (equal key datum) (equal value datum))
  78. collect key and collect value)))
  79. datum)
  80. ;;; ========================================================================
  81. ;;; UTILITIES
  82. (defun print-pseudonyms (&key (inside-package (package-name *package*)))
  83. "This prints all pseudonyms in a fancy manner.
  84. Optional argument designates the package name, from inside which pseudonyms should be printed."
  85. (check-type inside-package string)
  86. (let* ((table (gethash inside-package *pseudonym-table*)))
  87. (if (null table)
  88. (format t "No pseudonyms defined for package ~:@(~A~).~%" inside-package)
  89. (progn
  90. (format t "pseudonym => name (inside package ~:@(~A~)):~%" inside-package)
  91. (list-length
  92. (loop for (key value) on table by #'cddr collecting key
  93. do (format t "~S => ~S~%" value key)))))))
  94. ;;; ========================================================================
  95. ;;; READER MACRO
  96. (set-macro-character #\$ 'pseudonym-reader)
  97. (defun pseudonym-reader (stream char)
  98. "This is the reader macro for local pseudonyms."
  99. (declare (ignore char))
  100. (labels ((valid (char)
  101. (when (equal char (or #\Space #\Tab #\Return #\Newline))
  102. (error "Whitespace encountered when processing nickname."))))
  103. (let* ((table (gethash (package-name *package*) *pseudonym-table*))
  104. (pseudlist (loop for char = (read-char stream)
  105. collect char
  106. do (when (valid char))
  107. until (equal (peek-char nil stream) #\:)))
  108. (pseudonym (concatenate 'string pseudlist))
  109. (name (string=-getf-key table pseudonym))
  110. (intern-p (eq 2 (list-length (loop for char = (peek-char nil stream)
  111. while (equal char #\:)
  112. do (read-char stream)
  113. collect char))))
  114. (symbol (read stream)))
  115. ;;(format t "debug: ~S ~S ~S ~S ~S ~S ~S~%"
  116. ;;(package-name *package*) pseudlist table name pseudonym symbol intern-p)
  117. ;;(format t "debug: ~S ~S ~S~%" symbol name intern-p)
  118. (assert (not (null name)) ()
  119. "Pseudonym ~S was not set. Check your spelling or use defpseudonym."
  120. pseudonym)
  121. (if (or intern-p (find-symbol (string symbol) name))
  122. (intern (string symbol) name)
  123. (error "Symbol ~S not found in the ~A package."
  124. (string symbol) (string name))))))
  125. ;; todo: named readtables
  126. ;; todo: customizable macro character?
  127. ;; DONE: fix : / :: issue