Raymond Toy pushed to branch issue-497-describe-macro-with-arglist at cmucl / cmucl
Commits:
-
a0db1d64
by Raymond Toy at 2026-05-01T11:07:15-07:00
-
105f8c4a
by Raymond Toy at 2026-05-01T11:13:07-07:00
2 changed files:
Changes:
| ... | ... | @@ -331,6 +331,20 @@ |
| 331 | 331 | (:stream (format t "~&~S" name))
|
| 332 | 332 | (:lisp (format t "~&~S" name)))))))))
|
| 333 | 333 | |
| 334 | +;; Common function for printing the function or macro lambda-list.
|
|
| 335 | +(defun print-function/macro-arglist (kind args knownp)
|
|
| 336 | + (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind)
|
|
| 337 | + (cond ((not knownp)
|
|
| 338 | + (format t (intl:gettext " There is no argument information available.")))
|
|
| 339 | + ((or (null args)
|
|
| 340 | + (equal args "()"))
|
|
| 341 | + (write-string (intl:gettext " There are no arguments.")))
|
|
| 342 | + (t
|
|
| 343 | + (write-string " ")
|
|
| 344 | + (indenting-further *standard-output* 2
|
|
| 345 | + (etypecase args
|
|
| 346 | + (string (write-string args))
|
|
| 347 | + (list (prin1 args)))))))
|
|
| 334 | 348 | |
| 335 | 349 | ;;; DESCRIBE-FUNCTION-COMPILED -- Internal
|
| 336 | 350 | ;;;
|
| ... | ... | @@ -339,15 +353,7 @@ |
| 339 | 353 | ;;;
|
| 340 | 354 | (defun describe-function-compiled (x kind name)
|
| 341 | 355 | (let ((args (%function-arglist x)))
|
| 342 | - (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind)
|
|
| 343 | - (cond ((not args)
|
|
| 344 | - (format t (intl:gettext " There is no argument information available.")))
|
|
| 345 | - ((string= args "()")
|
|
| 346 | - (write-string (intl:gettext " There are no arguments.")))
|
|
| 347 | - (t
|
|
| 348 | - (write-string " ")
|
|
| 349 | - (indenting-further *standard-output* 2
|
|
| 350 | - (write-string args)))))
|
|
| 356 | + (print-function/macro-arglist kind args (not (null args))))
|
|
| 351 | 357 | |
| 352 | 358 | (let ((name (or name (%function-name x))))
|
| 353 | 359 | (desc-doc name 'function kind)
|
| ... | ... | @@ -356,25 +362,15 @@ |
| 356 | 362 | |
| 357 | 363 | (print-compiled-from (kernel:function-code-header x)))
|
| 358 | 364 | |
| 359 | - |
|
| 360 | -#+nil
|
|
| 361 | -(defun describe-function-byte-compiled (x kind name)
|
|
| 362 | - |
|
| 363 | - (let ((name (or name (c::byte-function-name x))))
|
|
| 364 | - (desc-doc name 'function kind)
|
|
| 365 | - (unless (eq kind :macro)
|
|
| 366 | - (describe-function-name name 'function)))
|
|
| 367 | - |
|
| 368 | - (print-compiled-from (c::byte-function-component x)))
|
|
| 369 | - |
|
| 365 | +;;; DESCRIBE-FUNCTION-BYTE-COMPILED -- Internal
|
|
| 366 | +;;;
|
|
| 367 | +;;; Describe a byte-compiled function.
|
|
| 370 | 368 | (defun describe-function-byte-compiled (x kind name)
|
| 371 | - |
|
| 372 | 369 | (let ((name (or name (c::byte-function-name x))))
|
| 373 | 370 | (when (eq kind :macro)
|
| 374 | - (let ((args (c::info :function :macro-arglist name)))
|
|
| 375 | - (when args
|
|
| 376 | - (format t (intl:gettext "~&~@(~@[~A ~]arguments:~%~)") kind)
|
|
| 377 | - (format t " ~S" args))))
|
|
| 371 | + (multiple-value-bind (args knownp)
|
|
| 372 | + (c::info :function :macro-arglist name)
|
|
| 373 | + (print-function/macro-arglist kind args knownp)))
|
|
| 378 | 374 | (desc-doc name 'function kind)
|
| 379 | 375 | (unless (eq kind :macro)
|
| 380 | 376 | (describe-function-name name 'function)))
|
| 1 | +;;; Tests for defmacro documention and location info
|
|
| 2 | + |
|
| 3 | +(defpackage :defmacro-tests
|
|
| 4 | + (:use :cl :lisp-unit))
|
|
| 5 | + |
|
| 6 | +(in-package "DEFMACRO-TESTS")
|
|
| 7 | + |
|
| 8 | +(defmacro issue.497.no-args ()
|
|
| 9 | + `(list))
|
|
| 10 | + |
|
| 11 | +(defmacro issue.497.simple (a b)
|
|
| 12 | + `(list ,a ,b))
|
|
| 13 | + |
|
| 14 | +(defmacro issue.497.optional (a &optional (b 0))
|
|
| 15 | + `(* ,a ,b))
|
|
| 16 | + |
|
| 17 | +(defmacro issue.497.body (name &body body)
|
|
| 18 | + `(progn ,name ,@body))
|
|
| 19 | + |
|
| 20 | +(defmacro issue.497.with-doc (a b)
|
|
| 21 | + "Build a list from two args"
|
|
| 22 | + `(list ,a ,b))
|
|
| 23 | + |
|
| 24 | +(define-test issue.497.macro-arglist-no-args
|
|
| 25 | + (:tag :issues)
|
|
| 26 | + (multiple-value-bind (value knownp)
|
|
| 27 | + (c::info :function :macro-arglist 'issue.497.no-args)
|
|
| 28 | + (assert-equal '() value)
|
|
| 29 | + (assert-true knownp)))
|
|
| 30 | + |
|
| 31 | +(define-test issue.497.macro-arglist-simple
|
|
| 32 | + (:tag :issues)
|
|
| 33 | + (assert-equal '(a b)
|
|
| 34 | + (c::info :function :macro-arglist 'issue.497.simple)))
|
|
| 35 | + |
|
| 36 | +(define-test issue.497.macro-arglist-optional
|
|
| 37 | + (:tag :issues)
|
|
| 38 | + (assert-equal '(a &optional (b 0))
|
|
| 39 | + (c::info :function :macro-arglist 'issue.497.optional)))
|
|
| 40 | + |
|
| 41 | +(define-test issue.497.macro-arglist-body
|
|
| 42 | + (:tag :issues)
|
|
| 43 | + (assert-equal '(name &body body)
|
|
| 44 | + (c::info :function :macro-arglist 'issue.497.body)))
|
|
| 45 | + |
|
| 46 | +(define-test issue.497.macro-expands
|
|
| 47 | + (:tag :issues)
|
|
| 48 | + ;; Storing the lambda-list must not have broken the macro-function
|
|
| 49 | + (assert-equal '(list 1 2)
|
|
| 50 | + (macroexpand-1 '(issue.497.simple 1 2))))
|
|
| 51 | + |
|
| 52 | +(define-test issue.497.describe-runs-cleanly
|
|
| 53 | + (:tag :issues)
|
|
| 54 | + ;; describe must not error on these macros.
|
|
| 55 | + (assert-true
|
|
| 56 | + (stringp (with-output-to-string (*standard-output*)
|
|
| 57 | + (describe 'issue.497.simple))))
|
|
| 58 | + (assert-true
|
|
| 59 | + (stringp (with-output-to-string (*standard-output*)
|
|
| 60 | + (describe 'issue.497.no-args))))
|
|
| 61 | + (assert-true
|
|
| 62 | + (stringp (with-output-to-string (*standard-output*)
|
|
| 63 | + (describe 'issue.497.with-doc))))
|
|
| 64 | + ;; And on a byte-compiled macro from the build itself.
|
|
| 65 | + (assert-true
|
|
| 66 | + (stringp (with-output-to-string (*standard-output*)
|
|
| 67 | + (describe 'ext:letf*)))))
|
|
| 68 | + |
|
| 69 | +(define-test issue.497.byte-compiled-macro-has-arglist
|
|
| 70 | + (:tag :issues)
|
|
| 71 | + ;; ext:letf* is byte-compiled (extensions.lisp is :byte-compile t)
|
|
| 72 | + ;; and is the canonical example from the bug report. Its arglist
|
|
| 73 | + ;; should be available now.
|
|
| 74 | + (multiple-value-bind (args winp)
|
|
| 75 | + (c::info :function :macro-arglist 'ext:letf*)
|
|
| 76 | + (assert-true winp)
|
|
| 77 | + (assert-true (consp args))))
|
|
| 78 | + |