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 6.4KB

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