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.5KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;; pseudonyms
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;;; thanks to:
  5. ;;;; #lisp@freenode: pjb, blubjr, sid_cypher, PuercoPop
  6. ;;;; for testing and ideas
  7. ;;;; license: FreeBSD (BSD 2-clause)
  8. ;;;;
  9. ;;;; pseudonyms.lisp
  10. #|
  11. ============================ PSEUDONYMS ===================================
  12. I found that Lisp nicknames, as defined in CLHS, have a few problems that I
  13. will count here.
  14. 1) They are not changeable without internal side-effects. RENAME-PACKAGE
  15. is destructive, as it kills off any previous names the package.
  16. 2) They collide. Nickname GL is used by at least three different Lisp
  17. packages.
  18. The solution I provide here is a different approach to nicknames that does
  19. not use any of the original nickname code, as defined in CLHS.
  20. Pseudonyms, in opposition to nicknames, can be defined by the user inside
  21. one's code, like this:
  22. > (defpseudonym "longpackagename" "lpn")
  23. And removed like this:
  24. > (pmakunbound "lpn") ;; OR (pmakunbound "longpackagename")
  25. From within the code, one can refer to a pseudonymized package this way:
  26. > $lpn:something
  27. A reader macro will automatically translate it to its normal version of
  28. longpackagename:something. This is usable both within the REPL and within
  29. usual code.
  30. All pseudonyms are local to the current package: for instance, pseudonyms
  31. defined within CL-USER are not usable anywhere outside the CL-USER package.
  32. An utility function print-pseudonyms will print all pseudonyms for a given
  33. package. If not supplied a package name as an argument, it will print all
  34. pseudonyms for current package (as shown by the *package* global variable.
  35. |#
  36. (in-package #:pseudonyms)
  37. ;;; ========================================================================
  38. ;;; GLOBAL VARIABLES
  39. (defparameter *pseudonym-table*
  40. (make-weak-hash-table :test #'equal :weakness :key)
  41. "This is a global package-name-indexed hashtable holdingname-pseudonym
  42. plists.")
  43. ;;; ========================================================================
  44. ;;; HELPER FUNCTIONS AND TYPES
  45. (deftype string-designator () '(or string symbol character))
  46. (defun string=-getf (plist indicator)
  47. "This is a version of getf utilizing string= for comparison.
  48. Given a plist and a key, returns a value."
  49. (loop for key in plist by #'cddr
  50. for value in (rest plist) by #'cddr
  51. when (string= key indicator)
  52. return value))
  53. (defun string=-getf-key (plist indicator)
  54. "This is a version of getf utilizing string= for comparison.
  55. Given a plist and a value, returns a key."
  56. (loop for key in plist by #'cddr
  57. for value in (rest plist) by #'cddr
  58. when (string= value indicator)
  59. return (values key)))
  60. ;;; ========================================================================
  61. ;;; DEFINE/UNDEFINE FUNCTIONS
  62. (defun defpseudonym (name pseudonym)
  63. "This, given a package name and a pseudonym for it, allows you
  64. to use a local pseudonym in form $pseudonym:symbol instead of
  65. name:symbol within your code. This pseudonym is local to the package
  66. you called defpseudonym in (as shown by the global variable
  67. *PACKAGE*).
  68. Arguments must be a pair of non-empty non-equal string designators.
  69. Pseudonyms are always converted to lowercase.
  70. This will signal an error whenever a nickname or pseudonym is
  71. already taken."
  72. (check-type name string-designator)
  73. (check-type pseudonym string-designator)
  74. (setf name (string-downcase (string name))
  75. pseudonym (string-downcase (string pseudonym)))
  76. (assert (not (member "" (list name pseudonym) :test #'string=))
  77. (name pseudonym)
  78. "Name and pseudonym may not be empty.")
  79. (assert (not (string= name pseudonym))
  80. (name pseudonym)
  81. "Pseudonyming ~S to itself is not a good idea." name)
  82. (let* ((pkgname (package-name *package*))
  83. (name-test (string=-getf
  84. (gethash pkgname *pseudonym-table*) name))
  85. (pseudonym-test (string=-getf-key
  86. (gethash pkgname *pseudonym-table*) pseudonym)))
  87. (assert (not name-test) ()
  88. "This name is already taken by pseudonym ~S.
  89. Use pmakunbound first if you are sure what you're doing."
  90. name-test)
  91. (assert (not pseudonym-test) ()
  92. "This pseudonym is already taken by name ~S.
  93. Use pmakunbound first if you are sure what you're doing."
  94. pseudonym-test)
  95. (push pseudonym (gethash pkgname *pseudonym-table*))
  96. (push name (gethash pkgname *pseudonym-table*))
  97. (format nil "~A => ~A" pseudonym name)))
  98. (defun pmakunbound (datum)
  99. "This, given either a nickname-bound package name or a
  100. package name-bound nickname, clears any name-nickname pair bound to it.
  101. Argument must be a string designator."
  102. (check-type datum string-designator)
  103. (setf datum (string-downcase (string datum))
  104. (gethash (package-name *package*) *pseudonym-table*)
  105. (loop for (key value)
  106. on (gethash (package-name *package*) *pseudonym-table*)
  107. by #'cddr
  108. unless (or (equal key datum) (equal value datum))
  109. collect key and collect value))
  110. datum)
  111. ;;; ========================================================================
  112. ;;; UTILITIES
  113. (defun print-pseudonyms (&optional (pkgname (package-name *package*)))
  114. "This prints all pseudonyms in a fancy manner.
  115. Optional argument designates the package name, from inside which
  116. pseudonyms should be printed."
  117. (check-type pkgname string)
  118. (cond
  119. ((null (gethash pkgname *pseudonym-table*))
  120. (format t "No pseudonyms defined for package ~:@(~A~).~%" pkgname)
  121. nil)
  122. (t
  123. (format t "pseudonym => name (package ~:@(~A~)):
  124. ==============================~%" pkgname)
  125. (list-length
  126. (loop for (key value)
  127. on (gethash pkgname *pseudonym-table*)
  128. by #'cddr collecting key
  129. do (format t "~S => ~S~%" value key))))))
  130. ;;; ========================================================================
  131. ;;; READER MACRO
  132. (set-macro-character #\$ 'pseudonym-reader)
  133. (defun pseudonym-reader (stream char)
  134. "This is the reader macro for local pseudonyms."
  135. (declare (ignore char))
  136. (let* ((pseudlist (loop for char = (read-char stream)
  137. collect char
  138. until (equal (peek-char nil stream) #\:)))
  139. (pseudonym (string-downcase (concatenate 'string pseudlist)))
  140. (name (string=-getf-key (gethash (package-name *package*)
  141. *pseudonym-table*)
  142. pseudonym))
  143. (symbol (read stream)))
  144. (assert (not (null name)) ()
  145. "Pseudonym ~S was not set. Check your spelling or use defpseudonym."
  146. pseudonym)
  147. ;;(format t "debug: ~A ~A ~A ~A ~A~%"
  148. ;;(package-name *package*) pseudlist pseudonym name symbol)
  149. (read-from-string (format nil "~A:~A" name symbol))))
  150. ;; todo: named readtables