From 8d1ba936237f5da56615b07c3d8a894fe01d9529 Mon Sep 17 00:00:00 2001 From: ethanxxxl Date: Sun, 17 May 2026 02:43:31 -0400 Subject: [PATCH 1/3] fixed autodoc detection of slot reader/writers --- full/locatives/slots.lisp | 4 +- src/autodoc.lisp | 98 +++++++++++++++++++++++++-------------- 2 files changed, 66 insertions(+), 36 deletions(-) diff --git a/full/locatives/slots.lisp b/full/locatives/slots.lisp index 40ae248..70dbd64 100644 --- a/full/locatives/slots.lisp +++ b/full/locatives/slots.lisp @@ -87,7 +87,9 @@ (defun find-writer-slot-definition (accessor-symbol class-symbol) (dolist (slot-def (swank-mop:class-direct-slots (find-class class-symbol))) - (when (find accessor-symbol (swank-mop:slot-definition-writers slot-def)) + (when (find accessor-symbol (swank-mop:slot-definition-writers slot-def) + :key (lambda (w) + (if (listp w) (second w) w))) (return-from find-writer-slot-definition slot-def))) (locate-error "Could not find writer ~S for class ~S." accessor-symbol class-symbol)) diff --git a/src/autodoc.lisp b/src/autodoc.lisp index b4ebba6..9ecde17 100644 --- a/src/autodoc.lisp +++ b/src/autodoc.lisp @@ -24,23 +24,41 @@ (:documentation "This module is not included into asd file because it requires additional dependencies.")) (in-package #:40ants-doc/autodoc) - -(defun class-readers-and-accessors (class-name &key (ignore-symbol-p 'starts-with-percent-p)) - (let* ((class (find-class class-name)) - (slots (class-direct-slots class))) - (loop for slot in slots - for readers = (remove-if ignore-symbol-p - (slot-definition-readers slot)) - for writers = (remove-if ignore-symbol-p - (mapcar #'second - (slot-definition-writers slot))) - append readers into all-readers - append writers into all-writers - finally (return (values (sort all-readers - #'string<) - (sort all-writers - #'string<)))))) - +(defmacro %flatmap-slots ((class-name slot-var) &body body) + "runs `body` on each slot (bound to `slot-var`) in `class-name` body should +return a list. The results from all slots are flattened, sorted, and returned. + +This is meant for use with the class-readers and class-writers functions." + (let ((mapped-vals (gensym))) + `(loop :for ,slot-var :in (class-direct-slots (find-class ,class-name)) + :append (progn ,@body) :into ,mapped-vals + :finally (return (sort ,mapped-vals #'string<))))) + +(defun class-readers (class-name &key (ignore-symbol-p 'starts-with-percent-p)) + "returns list of methods that can read slots of `class-name`" + (%flatmap-slots (class-name slot) + (remove-if ignore-symbol-p (slot-definition-readers slot)))) + +(defun class-writers (class-name &key (ignore-symbol-p 'starts-with-percent-p)) + "returns list of methods that can write to slots of `class-name`." + (%flatmap-slots (class-name slot) + (remove-if ignore-symbol-p + (mapcar (lambda (writer) + (if (typep writer 'list) + (second writer) + writer)) + (slot-definition-writers slot))))) + +(defun class-accessors (class-name &key (ignore-symbol-p 'starts-with-percent-p)) + "returns list of methods that are accessors (ie can read and write) to slots +of `class-name`." + (nintersection (class-readers class-name :ignore-symbol-p ignore-symbol-p) + (class-writers class-name :ignore-symbol-p ignore-symbol-p))) + +(defun class-readers-writers (class-name &key (ignore-symbol-p 'starts-with-percent-p)) + "returns list of all methods that read or write to slots of `class-name`" + (nunion (class-readers class-name :ignore-symbol-p ignore-symbol-p) + (class-writers class-name :ignore-symbol-p ignore-symbol-p))) (defun system-packages (system-name) (loop for package in (list-all-packages) @@ -54,16 +72,13 @@ :key #'package-name)))) -(defun package-accessors-and-writers (package &key (ignore-symbol-p 'starts-with-percent-p)) +(defun package-readers-and-writers (package &key (ignore-symbol-p 'starts-with-percent-p)) (loop with result = nil for symbol being the external-symbols of package when (find-class symbol nil) - do (multiple-value-bind (readers accessors) - (class-readers-and-accessors symbol - :ignore-symbol-p ignore-symbol-p) - (setf result - (nunion result - (nunion readers accessors)))) + do (setf result + (nunion result (class-readers-writers symbol + :ignore-symbol-p ignore-symbol-p))) finally (return result))) @@ -87,10 +102,15 @@ (defun make-class-entry (class-name package-name &key (ignore-symbol-p 'starts-with-percent-p)) (check-type class-name symbol) (check-type package-name string) - - (multiple-value-bind (readers accessors) - (class-readers-and-accessors class-name - :ignore-symbol-p ignore-symbol-p) + + (let ((all-readers (class-readers class-name :ignore-symbol-p ignore-symbol-p)) + readers + (all-writers (class-writers class-name :ignore-symbol-p ignore-symbol-p)) + writers + (accessors (class-accessors class-name :ignore-symbol-p ignore-symbol-p))) + + (setf readers (set-difference all-readers all-writers) + writers (set-difference all-writers all-readers)) (let* ((title (symbol-name class-name)) (section-name (symbolicate @@ -102,14 +122,21 @@ "?CLASS")) (entries (nconc + (when accessors + (list "**Accessors**")) + (loop for accessor in accessors + collect `(,accessor (accessor ,class-name))) + (when readers (list "**Readers**")) (loop for reader in readers collect `(,reader (reader ,class-name))) - (when accessors - (list "**Accessors**")) - (loop for accessor in accessors - collect `(,accessor (accessor ,class-name))))) + + (when writers + (list "**Writers**")) + (loop for writer in writers + collect `(,writer (writer ,class-name))))) + (section-definition `(eval-when (:compile-toplevel :load-toplevel :execute) (defsection ,section-name (:title ,title @@ -130,8 +157,9 @@ (let* ((package-name (package-name package)) (title package-name) - (accessors-and-readers (package-accessors-and-writers package - :ignore-symbol-p #'ignore-symbol-p-wrapper)) + (readers-and-writers (package-readers-and-writers + package + :ignore-symbol-p #'ignore-symbol-p-wrapper)) (entries (loop for symbol being the external-symbols of package for should-be-documented = (not (ignore-symbol-p-wrapper symbol)) ;; Usual functions @@ -145,7 +173,7 @@ when (and (fboundp symbol) should-be-documented (typep (symbol-function symbol) 'generic-function) - (not (member symbol accessors-and-readers + (not (member symbol readers-and-writers :test 'eql))) collect (list symbol 'generic-function) into generics From 7a2c2eda68117b5a86ea3cd78e5ebaf9d5ba79b0 Mon Sep 17 00:00:00 2001 From: Alexander Artemenko Date: Thu, 3 Sep 2026 16:23:57 +0300 Subject: [PATCH 2/3] Add tests for slot writer autodoc --- 40ants-doc-test.asd | 5 ++++- src/changelog.lisp | 3 ++- test/autodoc.lisp | 46 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 52 insertions(+), 2 deletions(-) create mode 100644 test/autodoc.lisp diff --git a/40ants-doc-test.asd b/40ants-doc-test.asd index 89bbb3f..dc313d3 100644 --- a/40ants-doc-test.asd +++ b/40ants-doc-test.asd @@ -4,7 +4,10 @@ :description "Test system for 40ANTS-DOC system." :class :package-inferred-system :pathname "test" - :depends-on ("40ants-doc-test/test-transcribe" + :depends-on ("40ants-doc/autodoc" + "40ants-doc-full" + "40ants-doc-test/test-transcribe" + "40ants-doc-test/autodoc" "40ants-doc-test/test" "40ants-doc-test/xref" "40ants-doc-test/locatives" diff --git a/src/changelog.lisp b/src/changelog.lisp index 1d74502..43e219c 100644 --- a/src/changelog.lisp +++ b/src/changelog.lisp @@ -155,6 +155,8 @@ "CLEAN-URLS" ;; These objects are not documented yet: "40ANTS-DOC/COMMONDOC/XREF:XREF")) + (0.26.1 2026-09-03 + "* Fixed autodoc support for slots declared with `:writer`.") (0.26.0 2026-04-11 "* Supported documentation building for projects cloned as git submodules. * Fixed external dependencies listing in case if some deps use :require.") @@ -400,4 +402,3 @@ - Allowed to reference objects using keywords. - Fixed docstring extraction for compiler macro.")) - diff --git a/test/autodoc.lisp b/test/autodoc.lisp new file mode 100644 index 0000000..229ac3b --- /dev/null +++ b/test/autodoc.lisp @@ -0,0 +1,46 @@ +(uiop:define-package #:40ants-doc-test/autodoc + (:use #:cl) + (:import-from #:40ants-doc/autodoc + #:defautodoc) + (:import-from #:40ants-doc-full/locatives/slots) + (:import-from #:rove + #:deftest + #:ok + #:testing)) +(in-package #:40ants-doc-test/autodoc) + + +(defclass slot-reader-writer-class () + ((accessor-slot :accessor slot-accessor) + (reader-slot :reader slot-reader) + (writer-slot :writer slot-writer))) + + +(deftest test-autodoc-classifies-slot-readers-writers-and-accessors + (testing "A class with all slot interface kinds is classified correctly" + (ok (equal (40ants-doc/autodoc::class-readers + 'slot-reader-writer-class) + '(slot-accessor + slot-reader))) + (ok (equal (40ants-doc/autodoc::class-writers + 'slot-reader-writer-class) + '(slot-accessor + slot-writer))) + (ok (equal (40ants-doc/autodoc::class-accessors + 'slot-reader-writer-class) + '(slot-accessor))) + (let ((readers-and-writers + (40ants-doc/autodoc::class-readers-writers + 'slot-reader-writer-class))) + (ok (= 3 (length readers-and-writers))) + (ok (subsetp '(slot-accessor + slot-reader + slot-writer) + readers-and-writers))))) + + +(deftest test-writer-locative-finds-a-writer-symbol + (testing "A writer locative resolves a slot declared with :writer" + (ok (40ants-doc-full/locatives/slots::find-writer-slot-definition + 'slot-writer + 'slot-reader-writer-class)))) From b54b3a775e34f390a1e0454a9b44e68310a0c51f Mon Sep 17 00:00:00 2001 From: Alexander Artemenko Date: Thu, 3 Sep 2026 16:54:43 +0300 Subject: [PATCH 3/3] Add reader and accessor locative tests --- test/autodoc.lisp | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test/autodoc.lisp b/test/autodoc.lisp index 229ac3b..14f30f9 100644 --- a/test/autodoc.lisp +++ b/test/autodoc.lisp @@ -44,3 +44,17 @@ (ok (40ants-doc-full/locatives/slots::find-writer-slot-definition 'slot-writer 'slot-reader-writer-class)))) + + +(deftest test-reader-locative-finds-a-reader-symbol + (testing "A reader locative resolves a slot declared with :reader" + (ok (40ants-doc-full/locatives/slots::find-reader-slot-definition + 'slot-reader + 'slot-reader-writer-class)))) + + +(deftest test-accessor-locative-finds-an-accessor-symbol + (testing "An accessor locative resolves a slot declared with :accessor" + (ok (40ants-doc-full/locatives/slots::find-accessor-slot-definition + 'slot-accessor + 'slot-reader-writer-class))))