A reader-macro way to create non-destructive nicknames within portable Common Lisp
Vous ne pouvez pas sélectionner plus de 25 sujets Les noms de sujets doivent commencer par une lettre ou un nombre, peuvent contenir des tirets ('-') et peuvent comporter jusqu'à 35 caractères.

pseudonyms.lisp 5.3KB

  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 name-pseudonym
  16. plists.")
  17. ;;; ========================================================================
  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. ;;; ========================================================================
  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