master: sb-manual: make GENERATE-TEXINFO unaffected by SWITCH-TO-PAX
melisgl via Sbcl-commits <[email protected]> Mon, 29 Jun 2026 12:19:52 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via f319e996d1025a426eea1591ece8314b3ed6d6fd (commit)
from 7c2785fe2ae788c2fe21e9cf437c89a037caf6eb (commit)
- Log -----------------------------------------------------------------
commit f319e996d1025a426eea1591ece8314b3ed6d6fd
Author: Gabor Melis <[email protected]>
Date: Mon Jun 8 13:54:50 2026 +0200
sb-manual: make GENERATE-TEXINFO unaffected by SWITCH-TO-PAX
---
contrib/Makefile | 7 +--
contrib/sb-manual/markdown.lisp | 57 +++++++++++++----------
contrib/sb-manual/pax.lisp | 100 ++++++----------------------------------
contrib/sb-manual/texinfo.lisp | 94 +++++++++++++++++++++++++++++++++----
4 files changed, 136 insertions(+), 122 deletions(-)
diff --git a/contrib/Makefile b/contrib/Makefile
index 264d46198..0098154e7 100644
--- a/contrib/Makefile
+++ b/contrib/Makefile
@@ -20,9 +20,10 @@ sb-mpfr.fasl: sb-gmp.fasl
sb-queue.fasl: sb-concurrency.fasl
sb-simple-streams.fasl: sb-posix.fasl sb-bsd-sockets.fasl
sb-grovel.fasl: asdf.fasl # for building the module, not for our build
-sb-manual.fasl: sb-introspect.fasl sb-bsd-sockets.fasl sb-sprof.fasl \
- sb-aclrepl.fasl sb-concurrency.fasl sb-cover.fasl sb-grovel.fasl \
- sb-posix.fasl sb-rotate-byte.fasl sb-cltl2.fasl
+sb-manual.fasl: sb-aclrepl.fasl sb-bsd-sockets.fasl sb-cltl2.fasl \
+ sb-concurrency.fasl sb-cover.fasl sb-grovel.fasl sb-introspect.fasl \
+ sb-md5.fasl sb-posix.fasl sb-rotate-byte.fasl sb-queue.fasl \
+ sb-sprof.fasl
# Notes:
# 1. Invoking $(MAKE) for nested make eliminates a warning about jobserver mode.
diff --git a/contrib/sb-manual/markdown.lisp b/contrib/sb-manual/markdown.lisp
index e97b45d34..0779d6c90 100644
--- a/contrib/sb-manual/markdown.lisp
+++ b/contrib/sb-manual/markdown.lisp
@@ -391,22 +391,25 @@
;; Not reading a symbol, not at potential start of symbol
(setf maybe-begin nil)))))))
-(progn
- (defsection @test-section ())
- (defsection @test5 ())
- (assert (equal (locate-symbols "PRINT") '((0 5))))
- (assert (equal (locate-symbols "CL:PRINT") '((0 8))))
- (assert (equal (locate-symbols "*FEATURES*") '((0 10))))
- (assert (equal (locate-symbols "SETFable") '((0 4))))
- (assert (equal (locate-symbols "SETF-able") '((0 4))))
- (assert (equal (locate-symbols "nonREADable") '((3 7))))
- (assert (equal (locate-symbols "NOSUCHSYMBOL-able") '()))
- (assert (equal (locate-symbols "ASDF-like") '()))
- (assert (equal (locate-symbols "@TEST-SECTION") '((0 13))))
- (assert (equal (locate-symbols "SB-MANUAL:@TEST-SECTION") '((0 23))))
- (assert (equal (locate-symbols "@NOSUCHSECTION") '()))
- (assert (equal (locate-symbols "@TEST5") '((0 6))))
- (assert (equal (locate-symbols ":IR1-CONVERT") '((0 12)))))
+(unwind-protect
+ (progn
+ (defsection @test-section ())
+ (defsection @test5 ())
+ (assert (equal (locate-symbols "PRINT") '((0 5))))
+ (assert (equal (locate-symbols "CL:PRINT") '((0 8))))
+ (assert (equal (locate-symbols "*FEATURES*") '((0 10))))
+ (assert (equal (locate-symbols "SETFable") '((0 4))))
+ (assert (equal (locate-symbols "SETF-able") '((0 4))))
+ (assert (equal (locate-symbols "nonREADable") '((3 7))))
+ (assert (equal (locate-symbols "NOSUCHSYMBOL-able") '()))
+ (assert (equal (locate-symbols "ASDF-like") '()))
+ (assert (equal (locate-symbols "@TEST-SECTION") '((0 13))))
+ (assert (equal (locate-symbols "SB-MANUAL:@TEST-SECTION") '((0 23))))
+ (assert (equal (locate-symbols "@NOSUCHSECTION") '()))
+ (assert (equal (locate-symbols "@TEST5") '((0 6))))
+ (assert (equal (locate-symbols ":IR1-CONVERT") '((0 12)))))
+ (makunbound '@test-section)
+ (makunbound '@test5))
;;;; Processing Markdown inline elements
@@ -450,17 +453,23 @@
(defun section-name-p (symbol)
(when (boundp symbol)
- (let ((value (symbol-value symbol)))
- (and (listp value)
- (eq (first value) 'defsection)))))
+ (if *use-pax*
+ (typep (symbol-value symbol) (dummy 'section))
+ (let ((value (symbol-value symbol)))
+ (and (listp value)
+ (eq (first value) 'defsection))))))
(when (and (not *use-pax*)
*downcase-uppercase-code*)
- (assert (equal (codify-and-link "@TEST-SECTION") "@ref{test section}"))
- (assert (equal (codify-and-link "@NOSUCHSECTION") "@@NOSUCHSECTION"))
- (assert (equal (codify-and-link ":START") "@code{:start}"))
- (assert (equal (codify-and-link "[:START") "[@code{:start}"))
- (assert (equal (codify-and-link "{:START") "@{@code{:start}")))
+ (defsection @test-section ())
+ (unwind-protect
+ (progn
+ (assert (equal (codify-and-link "@TEST-SECTION") "@ref{test section}"))
+ (assert (equal (codify-and-link "@NOSUCHSECTION") "@@NOSUCHSECTION"))
+ (assert (equal (codify-and-link ":START") "@code{:start}"))
+ (assert (equal (codify-and-link "[:START") "[@code{:start}"))
+ (assert (equal (codify-and-link "{:START") "@{@code{:start}")))
+ (makunbound '@test-section)))
;;; Translate backticks, emphasis and codification escapes, while
;;; delegating normal text to CODIFY-AND-LINK.
diff --git a/contrib/sb-manual/pax.lisp b/contrib/sb-manual/pax.lisp
index fd0b6175b..6b5425492 100644
--- a/contrib/sb-manual/pax.lisp
+++ b/contrib/sb-manual/pax.lisp
@@ -23,16 +23,18 @@
(defvar *dummies* ()))
(defmacro defun-dummy ((name package) lambda-list &body body)
- (unless *use-pax*
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (pushnew '(,name ,package) *dummies* :test #'equal)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (pushnew '(,name ,package) *dummies* :test #'equal)
+ (declaim (notinline ,name))
+ (unless *use-pax*
(defun ,name ,lambda-list ,@body))))
(defmacro defmacro-dummy ((name package) lambda-list &body body)
(unless *use-pax*
`(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew '(,name ,package) *dummies* :test #'equal)
- (defmacro ,name ,lambda-list ,@body))))
+ (unless *use-pax*
+ (defmacro ,name ,lambda-list ,@body)))))
(defparameter *extra-dummies*
'((argument :pax)
@@ -54,10 +56,13 @@
(unless *use-pax*
(require 'mgl-pax)
;; Replace dummies with the real symbols.
- (let ((dummies (loop for (name package) in (append *dummies*
- *extra-dummies*)
- collect (format nil "~A:~A" package name))))
- (shadowing-import (mapcar #'read-from-string dummies) :sb-manual))
+ (loop for (name package) in (append *dummies* *extra-dummies*)
+ do (let ((new-symbol (read-from-string
+ (format nil "~A:~A" package name))))
+ (when (and (fboundp new-symbol)
+ (null (macro-function new-symbol)))
+ (setf (fdefinition name) (fdefinition new-symbol)))
+ (shadowing-import new-symbol :sb-manual)))
;; Arrange for that only SECTIONs will be exported by
;; PAX:DEFSECTION.
(eval-string
@@ -92,6 +97,8 @@
"(setf (dref-ext:definition-property (dref:dref '~S '~S) 'docstring)
(list nil (find-package ~S)))"
name (subst-extras locative) package))
+ (setq *definition-to-docstring-package*
+ (subst-extras *definition-to-docstring-package*))
(loop for (from-package to-package) in *package-to-docstring-package*
do (eval-format
"(setf (dref-ext:definition-property `(:package ,(find-package ~S))
@@ -154,80 +161,3 @@
(defun-dummy (xref-locative-type :dref) (xref)
(first (sb-c::ensure-list (second xref))))
-
-(defun-dummy (resolve :dref) (xref)
- (cond ((eq (xref-locative-type xref) 'section)
- (or (ignore-errors (symbol-value (xref-name xref)))
- (assert nil () "Undefined SECTION ~S." (xref-name xref))))
- (t
- (assert nil () "Unexpected locative type in ~S." xref))))
-
-(defun-dummy (arglist :dref) (xref)
- (let ((name (xref-name xref))
- (locative-type (xref-locative-type xref)))
- (lambda-list* name locative-type)))
-
-(defun-dummy (docstring :dref) (xref)
- (values (let ((name (xref-name xref))
- (locative-type (xref-locative-type xref)))
- (case locative-type
- ((function variable declaration)
- (documentation name locative-type))
- ((generic-function)
- (documentation name 'function))
- ((type class structure condition declaration)
- (documentation name 'type))
- (t
- (cond ((eq locative-type (dummy 'macro))
- (documentation (macro-function name) t))
- ((eq locative-type (dummy 'setf-function))
- (documentation (fdefinition name) t))
- ((eq locative-type (dummy 'setf-generic-function))
- (documentation (fdefinition name) t))
- (t
- (assert nil () "Unexpected locative type in ~S."
- xref))))))
- ;; To be compatible with PAX::@PACKAGE-AND-READTABLE, we
- ;; always return a non-NIL package.
- (docstring-package xref)))
-
-
-(defun lambda-list* (name kind)
- (case kind
- ((package constant variable type structure class condition method
- declaration nil)
- nil)
- (t
- ;; KLUDGE: Eugh.
- ;;
- ;; believe it or not, the above comment was written before CSR
- ;; came along and obfuscated this. (2005-07-04)
- (when (symbolp name)
- (labels ((clean (x &key optional key)
- (typecase x
- (atom x)
- ((cons (member &optional))
- (cons (car x) (clean (cdr x) :optional t)))
- ((cons (member &key))
- (cons (car x) (clean (cdr x) :key t)))
- ((cons (member &whole &environment))
- ;; Skip these
- (clean (cdr x) :optional optional :key key))
- ((cons cons)
- (cons
- (cond (key (if (consp (caar x))
- (caaar x)
- (caar x)))
- (optional (caar x))
- (t (clean (car x))))
- (clean (cdr x) :key key :optional optional)))
- (cons
- (cons
- (cond ((or key optional) (car x))
- (t (clean (car x))))
- (clean (cdr x) :key key :optional optional))))))
- (multiple-value-bind (ll unknown)
- (sb-introspect:function-lambda-list name)
- (if unknown
- (values nil t)
- (clean ll))))))))
diff --git a/contrib/sb-manual/texinfo.lisp b/contrib/sb-manual/texinfo.lisp
index 2e75a1602..fa362184d 100644
--- a/contrib/sb-manual/texinfo.lisp
+++ b/contrib/sb-manual/texinfo.lisp
@@ -1,5 +1,79 @@
(in-package :sb-manual)
+;;; We don't DEFINE-DUMMY DREF:ARGLIST and DREF:DOCSTRING because we
+;;; don't want SWITCH-TO-PAX affect Texinfo output, which it would
+;;; because DREF:ARGLIST differs from the {incom,re}prehensible
+;;; LAMBDA-LIST*.
+(defun %arglist (xref)
+ (let ((name (xref-name xref))
+ (locative-type (xref-locative-type xref)))
+ (lambda-list* name locative-type)))
+
+(defun %docstring (xref)
+ (values (let ((name (xref-name xref))
+ (locative-type (xref-locative-type xref)))
+ (case locative-type
+ ((function variable declaration)
+ (documentation name locative-type))
+ ((generic-function)
+ (documentation name 'function))
+ ((type class structure condition)
+ (documentation name 'type))
+ (t
+ (cond ((eq locative-type (dummy 'macro))
+ (documentation (macro-function name) t))
+ ((eq locative-type (dummy 'setf-function))
+ (documentation (fdefinition name) t))
+ ((eq locative-type (dummy 'setf-generic-function))
+ (documentation (fdefinition name) t))
+ (t
+ (assert nil () "Unexpected locative type in ~S."
+ xref))))))
+ ;; To be compatible with PAX::@PACKAGE-AND-READTABLE, we
+ ;; always return a non-NIL package.
+ (docstring-package xref)))
+
+(defun lambda-list* (name kind)
+ (case kind
+ ((package constant variable type structure class condition method
+ declaration nil)
+ nil)
+ (t
+ ;; KLUDGE: Eugh.
+ ;;
+ ;; believe it or not, the above comment was written before CSR
+ ;; came along and obfuscated this. (2005-07-04)
+ (when (symbolp name)
+ (labels ((clean (x &key optional key)
+ (typecase x
+ (atom x)
+ ((cons (member &optional))
+ (cons (car x) (clean (cdr x) :optional t)))
+ ((cons (member &key))
+ (cons (car x) (clean (cdr x) :key t)))
+ ((cons (member &whole &environment))
+ ;; Skip these
+ (clean (cdr x) :optional optional :key key))
+ ((cons cons)
+ (cons
+ (cond (key (if (consp (caar x))
+ (caaar x)
+ (caar x)))
+ (optional (caar x))
+ (t (clean (car x))))
+ (clean (cdr x) :key key :optional optional)))
+ (cons
+ (cons
+ (cond ((or key optional) (car x))
+ (t (clean (car x))))
+ (clean (cdr x) :key key :optional optional))))))
+ (multiple-value-bind (ll unknown)
+ (sb-introspect:function-lambda-list name)
+ (if unknown
+ (values nil t)
+ (clean ll))))))))
+
+
(defun locative-type-to-texinfo (locative-type)
(case locative-type
(function
@@ -63,8 +137,8 @@
(let ((child-sections
(loop for entry in entries
when (and (not (stringp entry))
- (eq (xref-locative-type entry) 'section))
- collect (resolve entry))))
+ (eq (xref-locative-type entry) (dummy 'section)))
+ collect (symbol-value (xref-name entry)))))
(when child-sections
(unless top-level-menus-to-file
(format t "@menu~%"))
@@ -86,19 +160,20 @@
(emit-texinfo-for-docstring entry)
(format t "~%")))
(t
- (if (not (eq (xref-locative-type entry) 'section))
+ (if (not (eq (xref-locative-type entry) (dummy 'section)))
(emit-texinfo-for-definition entry)
(let ((page (find (xref-name entry) pages
:key #'first)))
(when page
(format t "@include ~A~%" (second page)))
(with-texinfo-to-file (second page)
- (emit-texinfo-for-section (resolve entry)
- :pages pages
- :depth (1+ depth))))))))))))
+ (emit-texinfo-for-section
+ (symbol-value (xref-name entry))
+ :pages pages
+ :depth (1+ depth))))))))))))
(defun emit-texinfo-for-definition (xref)
- (multiple-value-bind (docstring *package*) (docstring xref)
+ (multiple-value-bind (docstring *package*) (%docstring xref)
(multiple-value-bind (type index)
(locative-type-to-texinfo (xref-locative-type xref))
(let* ((name (xref-name xref))
@@ -128,9 +203,9 @@
type
(let ((*package* (find-package :cl)))
(prin1-to-string name))
- (arglist xref))
+ (%arglist xref))
(when docstring
- (emit-texinfo-for-docstring docstring (arglist xref)))
+ (emit-texinfo-for-docstring docstring (%arglist xref)))
(format t "@end deffn~%")))))
;;; Remove leading non-alphanumeric characters. They are not important
@@ -185,7 +260,6 @@
(format nil "~D-~2,'0D" year month))))
(defun generate-texinfo ()
- (assert (not *use-pax*))
(let ((*default-pathname-defaults*
(truename (merge-pathnames
"../../doc/manual/"
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL