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

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142
  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. ;;; ========================================================================
  12. ;;; GLOBAL VARIABLES
  13. (defparameter *pseudonym-table*
  14. (make-weak-hash-table :test #'equal :weakness :key)
  15. "This is a global package-name-indexed hashtable holding name-pseudonym
  16. plists.")
  17. ;;; ========================================================================
  18. ;;; HELPER FUNCTIONS AND TYPES
  19. (deftype string-designator () '(or string symbol character))
  20. (defun string=-getf (plist indicator)
  21. "This is a version of getf utilizing string= for comparison.
  22. Given a plist and a key, returns a value."
  23. (loop for key in plist by #'cddr
  24. for value in (rest plist) by #'cddr
  25. when (string= key indicator)
  26. return value))
  27. (defun string=-getf-key (plist indicator)
  28. "This is a version of getf utilizing string= for comparison.
  29. Given a plist and a value, returns a key."
  30. (loop for key in plist by #'cddr
  31. for value in (rest plist) by #'cddr
  32. when (string= value indicator)
  33. return (values key)))
  34. ;;; ========================================================================
  35. ;;; DEFINE/UNDEFINE FUNCTIONS
  36. (defun defpseudonym (raw-name raw-pseudonym &key (pkgname (package-name *package*)))
  37. "This, given a package name and a pseudonym for it, allows you
  38. to use a local pseudonym in form $pseudonym:symbol instead of
  39. name:symbol within your code. This pseudonym is local to the package
  40. you called defpseudonym in (as shown by the global variable
  41. *PACKAGE*).
  42. Arguments must be a pair of non-empty non-equal string designators.
  43. An optional argument allows you to set a pseudonym for a different package.
  44. Pseudonyms are always converted to lowercase.
  45. This will signal an error whenever a nickname or pseudonym is
  46. already taken."
  47. (check-type raw-name string-designator)
  48. (check-type raw-pseudonym string-designator)
  49. (let* ((table (gethash (string-downcase pkgname) *pseudonym-table*))
  50. (name (string-downcase raw-name))
  51. (pseudonym (string-downcase raw-pseudonym))
  52. (first (car table)))
  53. (assert (not (member "" (list name pseudonym) :test #'string=))
  54. (name pseudonym)
  55. "Name and pseudonym may not be empty.")
  56. (assert (not (string= name pseudonym))
  57. (name pseudonym)
  58. "Pseudonyming ~S to itself is not a good idea." name)
  59. (assert (not (string=-getf table name))
  60. (name)
  61. "This name is already taken by pseudonym ~S."
  62. (string=-getf table name))
  63. (assert (not (string=-getf-key table pseudonym))
  64. (pseudonym)
  65. "This pseudonym is already taken by name ~S."
  66. (string=-getf-key table pseudonym))
  67. (if (null table)
  68. (setf (gethash (string-downcase pkgname) *pseudonym-table*)
  69. (cons name (cons pseudonym nil)))
  70. (setf (car table) name
  71. (cdr table) (cons pseudonym (cons first (cdr table)))))
  72. (format nil "~A => ~A" pseudonym name)))
  73. (defun pmakunbound (datum &key (pkgname (package-name *package*)))
  74. "This, given either a nickname-bound package name or a
  75. package name-bound nickname, clears any name-nickname pair bound to it.
  76. Argument must be a string designator.
  77. An optional argument allows you to clear a pseudonym from a different
  78. package."
  79. (check-type datum string-designator)
  80. (let ((table (gethash (string-downcase pkgname) *pseudonym-table*)))
  81. (setf datum (string-downcase datum)
  82. table
  83. (loop for (key value) on table by #'cddr
  84. unless (or (equal key datum) (equal value datum))
  85. collect key and collect value)))
  86. datum)
  87. ;;; ========================================================================
  88. ;;; UTILITIES
  89. (defun print-pseudonyms (&key (pkgname (package-name *package*)))
  90. "This prints all pseudonyms in a fancy manner.
  91. Optional argument designates the package name, from inside which
  92. pseudonyms should be printed."
  93. (check-type pkgname string-designator)
  94. (let* ((string (string-downcase pkgname))
  95. (table (gethash string *pseudonym-table*)))
  96. (if (null table)
  97. (format t "No pseudonyms defined for package ~:@(~A~).~%" pkgname)
  98. (progn
  99. (format t "pseudonym => name (package ~:@(~A~)):~%" pkgname)
  100. (list-length
  101. (loop for (key value) on table by #'cddr collecting key
  102. do (format t "~S => ~S~%" value key)))))))
  103. ;;; ========================================================================
  104. ;;; READER MACRO
  105. (set-macro-character #\$ 'pseudonym-reader)
  106. (defun pseudonym-reader (stream char)
  107. "This is the reader macro for local pseudonyms."
  108. (declare (ignore char))
  109. (let* ((table (gethash (package-name *package*) *pseudonym-table*))
  110. (pseudlist (loop for char = (read-char stream)
  111. collect char
  112. until (equal (peek-char nil stream) #\:)))
  113. (pseudonym (string-downcase (concatenate 'string pseudlist)))
  114. (name (string=-getf-key table pseudonym))
  115. (symbol (read stream)))
  116. (assert (not (null name)) ()
  117. "Pseudonym ~S was not set. Check your spelling or use defpseudonym."
  118. pseudonym)
  119. ;;(format t "debug: ~A ~A ~A ~A ~A~%"
  120. ;;(package-name *package*) pseudlist pseudonym name symbol)
  121. (read-from-string (format nil "~A:~A" name symbol))))
  122. ;; todo: named readtables