1. (defgeneric consify (obj)
  2. (:documentation "Return a consy representation of something"))
  4. (defmacro define-transparent-consify (type)
  5. (with-gensyms (obj)
  6. `(defmethod consify ((,obj ,type))
  7. ,obj)))
  9. (define-transparent-consify number)
  10. (define-transparent-consify character)
  11. (define-transparent-consify string)
  12. (define-transparent-consify symbol)
  13. (define-transparent-consify pathname)
  15. (defvar *unconsify-keywords* nil)
  17. (defmethod consify ((obj list))
  18. ;; a more flexible implementation might do (keywordp (car obj)), but this makes the output uglier
  19. (if (member (car obj) *unconsify-keywords*)
  20. (cons :quote (mapcar #'consify obj))
  21. (mapcar #'consify obj)))
  23. (defgeneric consify-initargs (obj)
  24. (:documentation "Return a list of initargs that would recreate this class."))
  26. (defmethod consify ((obj standard-object))
  27. `(:make-instance ,(class-name (class-of obj)) ,@(consify-initargs obj)))
  29. (defun consify-initargs-from-slots (obj &rest slot-names)
  30. (let* ((class (class-of obj))
  31. (slots (remove-if-not
  32. (lambda (slot)
  33. (and (c2mop:slot-definition-initargs slot)
  34. (or (null slot-names)
  35. (member (c2mop:slot-definition-name slot) slot-names))))
  36. (c2mop:class-slots class))))
  37. (loop for slot in slots
  38. when (and
  39. (slot-boundp obj (c2mop:slot-definition-name slot))
  40. (c2mop:slot-definition-initargs slot))
  41. append (list (car (c2mop:slot-definition-initargs slot))
  42. (consify (slot-value obj (c2mop:slot-definition-name slot)))))))
  44. (defmethod consify-initargs ((obj standard-object))
  45. (consify-initargs-from-slots obj))
  47. (defgeneric unconsify-list (car cdr)
  48. (:documentation "A list with a keyword in the car was found during unconsify! The first element
  49. was car, the rest were cdr."))
  51. (defun unconsify (obj)
  52. "Rehydrate the output of consify."
  53. (etypecase obj
  54. ((or string number character symbol pathname) obj)
  55. (list (if (keywordp (car obj))
  56. (unconsify-list (car obj) (cdr obj))
  57. (mapcar #'unconsify obj)))))
  60. (defmethod unconsify-list (car cdr)
  61. (mapcar #'unconsify (cons car cdr)))
  63. (defmacro defunconsify (keyword car-var cdr-var &body body)
  64. (declare (symbol keyword car-var cdr-var))
  65. `(progn
  66. (push ,keyword *unconsify-keywords*)
  67. (defmethod unconsify-list ((,car-var (eql ,keyword)) ,cdr-var)
  68. ,@body)))
  70. (defunconsify :quote car cdr
  71. (mapcar #'unconsify cdr))
  73. (defunconsify :make-instance car cdr
  74. ;; Verify the format of the list as we go along, for good measure
  75. (check-type (car cdr) symbol)
  76. (apply #'make-instance (car cdr)
  77. (loop for it in (cdr cdr)
  78. for argname-p = t then (not argname-p)
  79. when argname-p
  80. collect (progn
  81. (check-type it keyword)
  82. it)
  83. else
  84. collect (unconsify it)
  85. finally (assert (not argname-p) () "Odd number of initargs while unconsifying!"))))
  87. (defun consify-copy (orig)
  88. "Copy any consifiable object by value."
  89. (unconsify (consify orig)))