Menu
▾
▴
sbcl-commits — Automatic notification of CVS activity.
You can subscribe to this list here.
| 2002 |
Jan
|
Feb
|
Mar
(23) |
Apr
(68) |
May
(99) |
Jun
(109) |
Jul
(112) |
Aug
(104) |
Sep
(177) |
Oct
(211) |
Nov
(162) |
Dec
(135) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2003 |
Jan
(126) |
Feb
(228) |
Mar
(238) |
Apr
(299) |
May
(257) |
Jun
(283) |
Jul
(192) |
Aug
(227) |
Sep
(295) |
Oct
(202) |
Nov
(180) |
Dec
(70) |
| 2004 |
Jan
(88) |
Feb
(73) |
Mar
(133) |
Apr
(141) |
May
(205) |
Jun
(130) |
Jul
(148) |
Aug
(247) |
Sep
(228) |
Oct
(175) |
Nov
(158) |
Dec
(222) |
| 2005 |
Jan
(159) |
Feb
(96) |
Mar
(145) |
Apr
(192) |
May
(132) |
Jun
(190) |
Jul
(194) |
Aug
(280) |
Sep
(195) |
Oct
(207) |
Nov
(154) |
Dec
(101) |
| 2006 |
Jan
(156) |
Feb
(110) |
Mar
(261) |
Apr
(183) |
May
(148) |
Jun
(133) |
Jul
(94) |
Aug
(141) |
Sep
(137) |
Oct
(111) |
Nov
(172) |
Dec
(124) |
| 2007 |
Jan
(111) |
Feb
(72) |
Mar
(155) |
Apr
(286) |
May
(138) |
Jun
(170) |
Jul
(129) |
Aug
(156) |
Sep
(170) |
Oct
(90) |
Nov
(119) |
Dec
(112) |
| 2008 |
Jan
(135) |
Feb
(102) |
Mar
(115) |
Apr
(42) |
May
(132) |
Jun
(106) |
Jul
(94) |
Aug
(67) |
Sep
(33) |
Oct
(123) |
Nov
(54) |
Dec
(219) |
| 2009 |
Jan
(143) |
Feb
(168) |
Mar
(68) |
Apr
(142) |
May
(224) |
Jun
(202) |
Jul
(83) |
Aug
(86) |
Sep
(68) |
Oct
(37) |
Nov
(93) |
Dec
(80) |
| 2010 |
Jan
(39) |
Feb
(76) |
Mar
(144) |
Apr
(141) |
May
(27) |
Jun
(70) |
Jul
(23) |
Aug
(155) |
Sep
(152) |
Oct
(167) |
Nov
(87) |
Dec
(12) |
| 2011 |
Jan
(18) |
Feb
(39) |
Mar
(18) |
Apr
(27) |
May
(45) |
Jun
(135) |
Jul
(31) |
Aug
(82) |
Sep
(14) |
Oct
(60) |
Nov
(112) |
Dec
(117) |
| 2012 |
Jan
(15) |
Feb
(4) |
Mar
(30) |
Apr
(62) |
May
(45) |
Jun
(30) |
Jul
(9) |
Aug
(23) |
Sep
(41) |
Oct
(56) |
Nov
(35) |
Dec
(43) |
| 2013 |
Jan
(19) |
Feb
(41) |
Mar
(31) |
Apr
(28) |
May
(109) |
Jun
(90) |
Jul
(24) |
Aug
(37) |
Sep
(52) |
Oct
(45) |
Nov
(58) |
Dec
(35) |
| 2014 |
Jan
(24) |
Feb
(48) |
Mar
(93) |
Apr
(100) |
May
(204) |
Jun
(107) |
Jul
(85) |
Aug
(89) |
Sep
(79) |
Oct
(70) |
Nov
(92) |
Dec
(54) |
| 2015 |
Jan
(100) |
Feb
(103) |
Mar
(94) |
Apr
(77) |
May
(96) |
Jun
(63) |
Jul
(116) |
Aug
(76) |
Sep
(81) |
Oct
(269) |
Nov
(253) |
Dec
(143) |
| 2016 |
Jan
(78) |
Feb
(150) |
Mar
(151) |
Apr
(107) |
May
(52) |
Jun
(49) |
Jul
(71) |
Aug
(68) |
Sep
(127) |
Oct
(95) |
Nov
(73) |
Dec
(106) |
| 2017 |
Jan
(224) |
Feb
(144) |
Mar
(144) |
Apr
(99) |
May
(84) |
Jun
(112) |
Jul
(136) |
Aug
(200) |
Sep
(206) |
Oct
(255) |
Nov
(210) |
Dec
(324) |
| 2018 |
Jan
(289) |
Feb
(140) |
Mar
(223) |
Apr
(171) |
May
(174) |
Jun
(131) |
Jul
(108) |
Aug
(139) |
Sep
(126) |
Oct
(142) |
Nov
(109) |
Dec
(195) |
| 2019 |
Jan
(129) |
Feb
(102) |
Mar
(120) |
Apr
(157) |
May
(126) |
Jun
(99) |
Jul
(102) |
Aug
(117) |
Sep
(128) |
Oct
(143) |
Nov
(153) |
Dec
(156) |
| 2020 |
Jan
(139) |
Feb
(149) |
Mar
(251) |
Apr
(175) |
May
(140) |
Jun
(117) |
Jul
(140) |
Aug
(209) |
Sep
(194) |
Oct
(160) |
Nov
(177) |
Dec
(170) |
| 2021 |
Jan
(41) |
Feb
(126) |
Mar
(155) |
Apr
(152) |
May
(150) |
Jun
(116) |
Jul
(54) |
Aug
(151) |
Sep
(102) |
Oct
(182) |
Nov
(230) |
Dec
(161) |
| 2022 |
Jan
(213) |
Feb
(164) |
Mar
(206) |
Apr
(232) |
May
(219) |
Jun
(196) |
Jul
(177) |
Aug
(142) |
Sep
(179) |
Oct
(161) |
Nov
(165) |
Dec
(212) |
| 2023 |
Jan
(265) |
Feb
(98) |
Mar
(149) |
Apr
(87) |
May
(110) |
Jun
(207) |
Jul
(176) |
Aug
(223) |
Sep
(136) |
Oct
(117) |
Nov
(202) |
Dec
(217) |
| 2024 |
Jan
(228) |
Feb
(246) |
Mar
(291) |
Apr
(215) |
May
(145) |
Jun
(128) |
Jul
(164) |
Aug
(143) |
Sep
(140) |
Oct
(97) |
Nov
(131) |
Dec
(142) |
| 2025 |
Jan
(145) |
Feb
(130) |
Mar
(196) |
Apr
(190) |
May
(134) |
Jun
(126) |
Jul
(93) |
Aug
(189) |
Sep
(199) |
Oct
(151) |
Nov
(141) |
Dec
(226) |
| 2026 |
Jan
(201) |
Feb
(220) |
Mar
(208) |
Apr
(196) |
May
(96) |
Jun
(15) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: stassats <sta...@us...> - 2026-06-08 23:33:39
|
The branch "master" has been updated in SBCL:
via b0916688cbced286faa4b5cf804961655d3880e2 (commit)
from ddedba22893371ebb96b2b81865eefd2ba27ab6d (commit)
- Log -----------------------------------------------------------------
commit b0916688cbced286faa4b5cf804961655d3880e2
Author: Stas Boukarev <sta...@gm...>
Date: Mon Jun 8 23:31:27 2026 +0300
Check types for concatenate-subseq
---
src/compiler/array-tran.lisp | 39 ++++++++++----------
src/compiler/seqtran.lisp | 88 +++++++++++++++++++++++++++-----------------
src/compiler/srctran.lisp | 62 +++++++++++++++++++++----------
3 files changed, 117 insertions(+), 72 deletions(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 18245c6fa..7e1adaba5 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -382,25 +382,26 @@
(setf (getf (leaf-info constant) key)
(constant-sequence-element-type (constant-value constant) key)))))
-(defun sequence-elements-type (sequence &optional key)
- (or (let ((uses (lvar-uses sequence)))
- (if (consp uses)
- (let (other-types
- constant-types)
- (loop for use in uses
- do
- (let ((type (constant-array-element-type (node-constant use) key)))
- (if type
- (push type constant-types)
- (push (node-single-value-type use) other-types))))
- (when constant-types
- (let ((union (sb-kernel::%type-union constant-types)))
- (if other-types
- (let ((element-type (type-array-element-type (sb-kernel::%type-union other-types))))
- (unless (eq element-type *wild-type*)
- (type-union union element-type)))
- union))))
- (constant-array-element-type (node-constant uses) key)))
+(defun sequence-elements-type (sequence &optional key (constants t))
+ (or (and constants
+ (let ((uses (lvar-uses sequence)))
+ (if (consp uses)
+ (let (other-types
+ constant-types)
+ (loop for use in uses
+ do
+ (let ((type (constant-array-element-type (node-constant use) key)))
+ (if type
+ (push type constant-types)
+ (push (node-single-value-type use) other-types))))
+ (when constant-types
+ (let ((union (sb-kernel::%type-union constant-types)))
+ (if other-types
+ (let ((element-type (type-array-element-type (sb-kernel::%type-union other-types))))
+ (unless (eq element-type *wild-type*)
+ (type-union union element-type)))
+ union))))
+ (constant-array-element-type (node-constant uses) key))))
(if key
*universal-type*
(unwild (type-array-element-type (lvar-type sequence))))))
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 3c9c5663f..b8dc4f923 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1833,6 +1833,57 @@
(defoptimizer (vector-push-extend ir2-hook) ((item vector &optional min-extension) node)
(check-sequence-item item vector node "Can't push ~a into ~a"))
+(defun check-concatenate-sequence-type (type result-element-type sequence node &key (description "concatenate")
+ (constants t))
+ (when result-element-type
+ (let ((constant (and (constant-lvar-p sequence)
+ (lvar-value sequence))))
+ (if (and constant
+ (proper-sequence-p constant))
+ (map nil
+ (lambda (elt)
+ (multiple-value-bind (fits really) (ctypep elt result-element-type)
+ (when (and really (not fits))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a ~s into ~s"
+ description
+ elt
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type))
+ (return-from check-concatenate-sequence-type)))))
+ constant)
+ (let ((element-type (sequence-elements-type sequence nil constants)))
+ (when (and element-type
+ (not (eq element-type *wild-type*))
+ (not (types-equal-or-intersect element-type result-element-type)))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a elements of type ~s into ~s"
+ description
+ (type-specifier element-type)
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type)))))))))
+
+(defun check-concatenate-element-type (type result-element-type element-type node &key (description "concatenate"))
+ (when (and result-element-type
+ element-type
+ (not (eq element-type *wild-type*))
+ (not (types-equal-or-intersect element-type result-element-type)))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a elements of type ~s into ~s"
+ description
+ (type-specifier element-type)
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type)))))
+
(defun check-concatenate (type sequences node &optional (description "concatenate"))
(let ((result-element-type (if (ctype-p type)
type
@@ -1840,40 +1891,9 @@
(return-from check-concatenate))))))
(unless (or (eq result-element-type *wild-type*)
(eq result-element-type *universal-type*))
- (loop for i from 0
- for sequence in sequences
- for constant = (and (constant-lvar-p sequence)
- (lvar-value sequence))
- do (if (and constant
- (proper-sequence-p constant))
- (map nil
- (lambda (elt)
- (multiple-value-bind (fits really) (ctypep elt result-element-type)
- (when (and really (not fits))
- (let ((*compiler-error-context* node))
- (compiler-warn "Can't ~a ~s, of type ~s, into ~s"
- description
- elt (type-of elt)
- (if (ctype-p type)
- (type-specifier (make-array-type '(*)
- :specialized-element-type type
- :element-type type))
- type))
- (return)))))
- constant)
- (let ((element-type (sequence-elements-type sequence)))
- (when (and element-type
- (not (eq element-type *wild-type*))
- (not (types-equal-or-intersect element-type result-element-type)))
- (let ((*compiler-error-context* node))
- (compiler-warn "Can't ~a elements of type ~s into ~s"
- description
- (type-specifier element-type)
- (if (ctype-p type)
- (type-specifier (make-array-type '(*)
- :specialized-element-type type
- :element-type type))
- type))))))))))
+ (loop for sequence in sequences
+ do (check-concatenate-sequence-type type result-element-type
+ sequence node :description description)))))
(defoptimizer (%concatenate-to-string ir2-hook) ((&rest args) node)
(check-concatenate 'string args node))
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index ec545cbcd..487fe4f2a 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -453,30 +453,54 @@
(defoptimizer (%concatenate-to-vector-subseq externally-checkable-type) ((type &rest args) node lvar)
(concatenate-subseq-type lvar args))
-(defun concatenate-subseq-check-ranges (args node)
- (loop while args
- do (let ((arg (pop args)))
- (when (constant-lvar-p arg)
- (case (lvar-value arg)
- (sb-impl::%subseq
- (check-sequence-ranges (pop args) (pop args) (pop args) node))
- (sb-impl::%splice
- (loop repeat (lvar-value (pop args))
- do (pop args)))
- (sb-impl::%repeat
- (pop args)
- (pop args)))))))
+(defun check-concatenate-subseq (type args node)
+ (let* ((result-element-type (and type
+ (if (ctype-p type)
+ type
+ (block nil
+ (type-array-element-type (or (careful-specifier-type type)
+ (return)))))))
+ (result-element-type (unless (or (eq result-element-type *wild-type*)
+ (eq result-element-type *universal-type*))
+ result-element-type)))
+ (loop while args
+ do (let ((arg (pop args)))
+ (when (constant-lvar-p arg)
+ (case (lvar-value arg)
+ (sb-impl::%subseq
+ (let ((sequence (pop args))
+ (start (pop args))
+ (end (pop args)))
+ (check-sequence-ranges sequence start end node)
+ (check-concatenate-sequence-type type result-element-type sequence node :constants nil)))
+ (sb-impl::%splice
+ (loop repeat (lvar-value (pop args))
+ for elt = (pop args)
+ do
+ (check-concatenate-element-type type result-element-type (lvar-type elt) node)))
+ (sb-impl::%repeat
+ (pop args)
+ (let ((elt
+ (pop args)))
+ (check-concatenate-element-type type result-element-type (lvar-type elt) node)))
+ (t
+ (check-concatenate-sequence-type type result-element-type arg node :constants nil))))))))
(defoptimizer (%concatenate-to-string-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq 'string args node))
(defoptimizer (%concatenate-to-base-string-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq 'base-string args node))
(defoptimizer (%concatenate-to-list-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq nil args node))
(defoptimizer (%concatenate-to-simple-vector-subseq ir2-hook) ((&rest args) node)
- (concatenate-subseq-check-ranges args node))
-(defoptimizer (%concatenate-to-vector-subseq ir2-hook) ((type &rest args) node)
- (concatenate-subseq-check-ranges args node))
+ (check-concatenate-subseq nil args node))
+(defoptimizer (%concatenate-to-vector-subseq ir2-hook) ((widetag &rest args) node)
+ (check-concatenate-subseq (and (constant-lvar-p widetag)
+ (sb-vm:saetp-ctype
+ (find (lvar-value widetag)
+ sb-vm:*specialized-array-element-type-properties*
+ :key #'sb-vm:saetp-typecode)))
+ args node))
(defoptimizer (%concatenate-to-list derive-type) ((&rest args))
(loop for arg in args
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-07 01:46:07
|
The branch "master" has been updated in SBCL:
via ddedba22893371ebb96b2b81865eefd2ba27ab6d (commit)
from db0328683bd10509f6c02f5c6e41716ebf18e6c2 (commit)
- Log -----------------------------------------------------------------
commit ddedba22893371ebb96b2b81865eefd2ba27ab6d
Author: Stas Boukarev <sta...@gm...>
Date: Sun Jun 7 04:44:38 2026 +0300
arm64: can't call sc-is on unused tns
Fixes lp#2155788
---
src/compiler/arm64/call.lisp | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/compiler/arm64/call.lisp b/src/compiler/arm64/call.lisp
index 6541cd427..4256d0245 100644
--- a/src/compiler/arm64/call.lisp
+++ b/src/compiler/arm64/call.lisp
@@ -313,8 +313,8 @@
(next-tn (and next
(tn-ref-tn next))))
(cond ((and next-tn
+ (neq (tn-kind next-tn) :unused)
(not (sc-is next-tn control-stack))
- (neq (tn-kind next-tn) :unused)
(ldp-stp-offset-p (* i n-word-bytes) n-word-bits))
(inst ldp move-temp next-tn
(@ ocfp-tn (* i n-word-bytes)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-06 19:23:16
|
The branch "master" has been updated in SBCL:
via db0328683bd10509f6c02f5c6e41716ebf18e6c2 (commit)
from 3efad92f20327eae7c3398043dc883803aa3fb9d (commit)
- Log -----------------------------------------------------------------
commit db0328683bd10509f6c02f5c6e41716ebf18e6c2
Author: Piotr Kubaj <pk...@an...>
Date: Sat Jun 6 18:36:03 2026 +0200
ppc64: fix big-endian ELFv2 build
There are numerous assumptions that big-endian => ELFv1, little-endian
=> ELFv2. That is incorrect, there are systems running on big-endian
ELFv2.
---
make-config.sh | 10 ++++++++++
src/compiler/ppc64/c-call.lisp | 14 +++++++-------
src/compiler/ppc64/parms.lisp | 4 +++-
src/runtime/ppc-arch.c | 6 ++++--
src/runtime/ppc64-assem.S | 5 ++++-
5 files changed, 28 insertions(+), 11 deletions(-)
diff --git a/make-config.sh b/make-config.sh
index 5c11da0e5..06f33bd04 100755
--- a/make-config.sh
+++ b/make-config.sh
@@ -765,6 +765,16 @@ case "$sbcl_arch" in
fi
;;
ppc64)
+ # The ppc64 C calling convention is either ELFv1, which passes function
+ # pointers as 3-word descriptors, or ELFv2, which branches to the entry
+ # address directly. This is a property of the toolchain, independent of
+ # endianness (ppc64le is always ELFv2; ppc64 big-endian may be either), so
+ # ask the C compiler which ABI it targets via its _CALL_ELF predefine
+ # (2 = ELFv2, 1 or undefined = ELFv1) and add :ppc64-elfv1 for the
+ # descriptor ABI.
+ if [ "`echo | ${CC:-cc} -E -dM - 2>/dev/null | grep -w _CALL_ELF | awk '{print $3}'`" != 2 ]; then
+ printf ' :ppc64-elfv1' >> $ltf
+ fi
;;
riscv)
if [ "$xlen" = "64" ]; then
diff --git a/src/compiler/ppc64/c-call.lisp b/src/compiler/ppc64/c-call.lisp
index 25f667d78..9d4526e5b 100644
--- a/src/compiler/ppc64/c-call.lisp
+++ b/src/compiler/ppc64/c-call.lisp
@@ -25,7 +25,7 @@
;;;; "The stack pointer (stored in r1) shall maintain quadword alignment."
;;;; (quadword = 16 bytes)
(defconstant +stack-alignment-mask+ 15)
-(defconstant +stack-frame-size+ #+little-endian 12 #+big-endian 14)
+(defconstant +stack-frame-size+ #-ppc64-elfv1 12 #+ppc64-elfv1 14)
(defstruct arg-state
(gpr-args 0)
@@ -139,7 +139,7 @@
(arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
(values (make-wired-tn* 'positive-fixnum any-reg-sc-number nsp-offset)
(let ((size (arg-state-stack-frame-size arg-state)))
- (cond #+little-endian
+ (cond #-ppc64-elfv1
((= size +stack-frame-size+)
;; no stack args
0)
@@ -261,7 +261,7 @@
(make-fpr (n)
(make-random-tn (sc-or-lose 'double-reg) n)))
(let* ((segment (make-segment))
- #+big-endian
+ #+ppc64-elfv1
(function-descriptor-size 24))
(assemble (segment 'nil)
;; Copy args from registers or stack to new position
@@ -387,7 +387,7 @@
(bug "Unknown alien floating point type: ~S" type))))))
;; Leave a gap for a PPC64ELF ABIv1 function descriptor,
;; to be filled in later relative to the SAP.
- #+big-endian
+ #+ppc64-elfv1
(dotimes (k (/ function-descriptor-size 4)) ; nop is 4 bytes
(inst nop))
(mapc #'save-arg
@@ -411,9 +411,9 @@
(inst stdu stack-pointer stack-pointer (- frame-size))
;; And make the call.
- #+little-endian
+ #-ppc64-elfv1
(load-address-into r0 (callback_wrapper_trampoline))
- #+big-endian
+ #+ppc64-elfv1
(destructuring-bind (r2 r12) (mapcar #'make-gpr '(2 12))
(load-address-into r12 (callback_wrapper_trampoline))
(inst ld r0 r12 0)
@@ -461,7 +461,7 @@
;; instruction of the wrapper. This assembler wrapper only
;; cares about the address, so leave the other descriptor
;; fields filled with no-op instructions.
- #+big-endian
+ #+ppc64-elfv1
(setf (sap-ref-64 sap 0) (+ (sap-int sap) function-descriptor-size))
(alien-funcall
(extern-alien "ppc_flush_icache"
diff --git a/src/compiler/ppc64/parms.lisp b/src/compiler/ppc64/parms.lisp
index aa5ed948d..e16310630 100644
--- a/src/compiler/ppc64/parms.lisp
+++ b/src/compiler/ppc64/parms.lisp
@@ -80,7 +80,9 @@
:dynamic-space-start #x1000000000)
(defconstant alien-linkage-table-growth-direction :up)
-(defconstant alien-linkage-table-entry-size #+little-endian 28 #+big-endian 24)
+;; ELFv2 uses a 7-instruction inline jump (28 bytes); the ELFv1 ABI uses
+;; a 3-word function descriptor (24 bytes).
+(defconstant alien-linkage-table-entry-size #-ppc64-elfv1 28 #+ppc64-elfv1 24)
(defenum (:start 8)
diff --git a/src/runtime/ppc-arch.c b/src/runtime/ppc-arch.c
index b626feec5..b429cdc1d 100644
--- a/src/runtime/ppc-arch.c
+++ b/src/runtime/ppc-arch.c
@@ -616,7 +616,9 @@ arch_write_linkage_table_entry(int index, void *target_addr, int datap)
// but trick the compiler into thinking it isn't, so that it does not
// indirect through a descriptor, but instead we get its logical address.
if (target_addr != &call_into_c) {
-#ifdef LISP_FEATURE_LITTLE_ENDIAN
+#ifndef LISP_FEATURE_PPC64_ELFV1
+ /* ELFv2: no function descriptors, so the linkage entry is an inline
+ * jump that materializes the target address in r12 and branches to it. */
int* inst_ptr;
unsigned long a0,a16,a32,a48;
unsigned int inst;
@@ -670,7 +672,7 @@ arch_write_linkage_table_entry(int index, void *target_addr, int datap)
os_flush_icache((os_vm_address_t) reloc_addr, (char*) inst_ptr - reloc_addr);
#else
- // Could use either ABI, but we're assuming v1
+ /* ELFv1: function pointers are descriptors, as detailed below. */
/* In the 64-bit v1 ABI, function pointers are alway passed around
* as "function descriptors", not directly the jump target address.
* A descriptor is 3 words:
diff --git a/src/runtime/ppc64-assem.S b/src/runtime/ppc64-assem.S
index 00d481356..beeabaab6 100644
--- a/src/runtime/ppc64-assem.S
+++ b/src/runtime/ppc64-assem.S
@@ -259,7 +259,7 @@ Low Address
/* "When a function is entered through its global entry point,
* register r12 contains the entry-point address." */
-#ifdef LISP_FEATURE_BIG_ENDIAN
+#ifdef LISP_FEATURE_PPC64_ELFV1
mfctr 11
ld reg_CFUNC, 0(11)
/* In the v1 64-bit ABI, a function pointer is a pointer to a
@@ -273,6 +273,9 @@ Low Address
// ld 11, 16(11)
mtctr reg_CFUNC
#else
+ /* ELFv2: the call target is the function's address itself; reg_CFUNC
+ * is r12, which the global entry point uses to set up its own TOC.
+ * No descriptor indirection. */
mfctr reg_CFUNC
#endif
/* Into C we go. */
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: snuglas <sn...@us...> - 2026-06-05 17:07:02
|
The branch "master" has been updated in SBCL:
via 3efad92f20327eae7c3398043dc883803aa3fb9d (commit)
from f3d711cd2af700a1ed9b22570987e7ccf94885bc (commit)
- Log -----------------------------------------------------------------
commit 3efad92f20327eae7c3398043dc883803aa3fb9d
Author: Douglas Katzman <do...@go...>
Date: Fri Jun 5 13:06:43 2026 -0400
Add a missing opaque-identity
---
tests/callback.impure.lisp | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp
index 3289e1947..83b3ce476 100644
--- a/tests/callback.impure.lisp
+++ b/tests/callback.impure.lisp
@@ -511,4 +511,4 @@
(setf (sb-sys:sap-ref-word (car restorer) 0) (cdr restorer)))
(assert (eql *got-arg* 0d0))
(assert (= result 42.0d0))
- (assert (eql (tan 0d0) 0d0))))) ; back to normal
+ (assert (eql (tan (opaque-identity 0d0)) 0d0))))) ; back to normal
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: snuglas <sn...@us...> - 2026-06-05 17:03:21
|
The branch "master" has been updated in SBCL:
via f3d711cd2af700a1ed9b22570987e7ccf94885bc (commit)
from 9deb748799125a1ee6c4feee6bfa22ddd2b035cc (commit)
- Log -----------------------------------------------------------------
commit f3d711cd2af700a1ed9b22570987e7ccf94885bc
Author: Douglas Katzman <do...@go...>
Date: Fri Jun 5 12:50:13 2026 -0400
Sketch out a way to trace/intercept foreign calls
---
src/code/alien-callback.lisp | 27 +++++++++++++++++++++++++++
tests/callback.impure.lisp | 21 +++++++++++++++++++++
2 files changed, 48 insertions(+)
diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp
index 1c04c7110..b55b1d695 100644
--- a/src/code/alien-callback.lisp
+++ b/src/code/alien-callback.lisp
@@ -354,6 +354,33 @@ function value."
(make-alien-pointer-type))
(cast (alien-callable-function lisp-name) (* t)))))
+;;; Changing the entry point of an alien linkage table entry allows testing without
+;;; the foreign library, or mocking of foreign routines. This is more powerful than
+;;; encapsulatig a function defined via DEFINE-ALIEN-ROUTINE because it catches uses
+;;; from bare (ALIEN-FUNCALL (EXTERN-ALIEN "f" ...)) and WITH-ALIEN.
+;;; Note also that a nonexistent foreign function can be "overridden".
+#+(or arm64 x86-64)
+(progn
+;; Not officially part of SB-ALIEN: interface, but need to protect from tree-shaker.
+(export 'sb-alien-internals::override-alien-linkage-entrypoint 'sb-alien-internals)
+(defun sb-alien-internals::override-alien-linkage-entrypoint (c-name new-value)
+ (let* ((linkage-index (sb-impl::ensure-alien-linkage-index c-name nil))
+ (new-jump-address
+ (etypecase new-value
+ (string (int-sap (find-foreign-symbol-address new-value)))
+ (symbol (alien-sap (gethash new-value sb-alien::*alien-callables*)))
+ (integer (int-sap new-value))))
+ (address-of-jump-address
+ #+arm64 (sap+ (int-sap (sb-vm::alien-linkage-index-to-addr linkage-index nil)) 8)
+ #+x86-64
+ ;; Access the linkage index as if data, even though it's a function- this computes
+ ;; the address of the word in the linkage space which needs to get overwritten.
+ ;; Computing as a function would get the immutable address within the space.
+ (int-sap (sb-vm::alien-linkage-index-to-addr linkage-index t))) ; datap = T
+ (original-jump-address (sap-ref-word address-of-jump-address 0)))
+ (setf (sap-ref-sap address-of-jump-address 0) new-jump-address)
+ (cons address-of-jump-address original-jump-address))))
+
(in-package "SB-THREAD")
#+sb-thread
(defun enter-foreign-callback (index return arguments)
diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp
index 5df538a39..3289e1947 100644
--- a/tests/callback.impure.lisp
+++ b/tests/callback.impure.lisp
@@ -491,3 +491,24 @@
(setq sap (alien-sap callable)))
(assert (sb-sys:sap= sap (alien-sap callable)))
(assert (= (alien-funcall callable 1 2) (+ 3 i)))))))
+
+#+(or (and linux arm64) x86-64)
+(progn
+(defvar *got-arg*)
+(define-alien-callable intercepted-tan double ((x double))
+ (setf *got-arg* x)
+ ;; we'd have to do something to get the actual underlying function.
+ ;; For purposes of this test, just return anything.
+ 42.0d0)
+(with-test (:name :trace-foreign-call)
+ (let (restorer result)
+ (unwind-protect
+ (progn
+ (setq restorer
+ (sb-alien-internals:override-alien-linkage-entrypoint
+ "tan" 'intercepted-tan))
+ (setq result (tan (opaque-identity 0d0))))
+ (setf (sb-sys:sap-ref-word (car restorer) 0) (cdr restorer)))
+ (assert (eql *got-arg* 0d0))
+ (assert (= result 42.0d0))
+ (assert (eql (tan 0d0) 0d0))))) ; back to normal
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-05 00:19:27
|
The branch "master" has been updated in SBCL:
via 9deb748799125a1ee6c4feee6bfa22ddd2b035cc (commit)
from a3cfdde6a335d9b1f0028006f19ce0a71694a32c (commit)
- Log -----------------------------------------------------------------
commit 9deb748799125a1ee6c4feee6bfa22ddd2b035cc
Author: Stas Boukarev <sta...@gm...>
Date: Fri Jun 5 03:16:36 2026 +0300
Turn (copy-list small-constant) into (list ,@constant)
---
src/compiler/array-tran.lisp | 2 +-
src/compiler/seqtran.lisp | 15 +++++++++++++++
2 files changed, 16 insertions(+), 1 deletion(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index c88f9aacd..18245c6fa 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -184,7 +184,7 @@
(loop until (atom list)
do (pop list)
(incf length))
- length))
+ (values length list)))
(defun constant-sequence-element-type (sequence &optional key)
(let (min
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index c1a5c0d7c..3c9c5663f 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -2156,6 +2156,10 @@
'seq))
(give-up-ir1-transform)))
+(defun quote-list (list)
+ (loop for e in list
+ collect (list 'quote e)))
+
(make-defs ((($fun $proper)
(copy-list nil)
(list-copy-seq t)))
@@ -2170,6 +2174,17 @@
(remove-if-not *
(change-full-call combination 'copy-remove-if-not)
'seq))
+ (and (constant-lvar-p seq)
+ (let ((list (lvar-value seq)))
+ (when (proper-or-dotted-list-p list)
+ (multiple-value-bind (length dotted) (dotted-list-length list)
+ (when (<= length 10)
+ (if dotted
+ (let ((last (last list)))
+ `(list* ,@(quote-list (butlast list))
+ ',(car last)
+ ',(cdr last)))
+ `(list ,@(quote-list list))))))))
(when (policy node (or (> speed space) (> instrument-consing 1)))
;; If speed is more important than space, or cons profiling is wanted,
;; then inline the whole copy loop.
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-05 00:02:29
|
The branch "master" has been updated in SBCL:
via a3cfdde6a335d9b1f0028006f19ce0a71694a32c (commit)
from 898313d8e7d3d953e8153d74da078975c2957bf4 (commit)
- Log -----------------------------------------------------------------
commit a3cfdde6a335d9b1f0028006f19ce0a71694a32c
Author: Stas Boukarev <sta...@gm...>
Date: Fri Jun 5 02:56:28 2026 +0300
lvar-constants: combine functions and refs from multiple uses
---
src/compiler/ir1util.lisp | 110 +++++++++++++++++++++++++++++++---------------
tests/bad-code.pure.lisp | 5 +++
2 files changed, 79 insertions(+), 36 deletions(-)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index bf1a3c846..d1e03dd84 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -96,6 +96,21 @@
use))))))
(recurse lvar))))
+(defun principal-ref (ref &optional casts)
+ (labels ((recurse-lvar (lvar ref)
+ (if lvar
+ (recurse (lvar-uses lvar) ref)
+ ref))
+ (recurse (node original-ref)
+ (cond ((ref-p node)
+ (recurse-lvar (lambda-var-ref-lvar node) node))
+ ((and casts
+ (cast-p node))
+ (recurse-lvar (cast-value node) node))
+ (t
+ original-ref))))
+ (recurse ref ref)))
+
(defun principal-lvar-ref (lvar &optional casts)
(labels ((recurse (lvar ref)
(if lvar
@@ -3769,42 +3784,65 @@ is :ANY, the function name is not checked."
(node-lvar ref)))))
lvar))
(uses (lvar-uses lvar)))
- (cond ((constant-lvar-p lvar)
- (values :values (list (lvar-value lvar))))
- ((constant-lvar-uses-p lvar)
- (values :values (lvar-uses-values lvar)))
- ((ref-p uses)
- (let* ((ref (principal-lvar-ref lvar))
- (leaf (and ref
- (ref-leaf ref))))
- (when (lambda-var-p leaf)
- (let ((seen (or seen (alloc-xset)))
- constants)
- (add-to-xset lvar seen)
- (map-lambda-var-refs-from-calls
- (lambda (call lvar)
- (unless (xset-member-p lvar seen)
- (add-to-xset lvar seen)
- (multiple-value-bind (type values) (recurse lvar seen)
- (case type
- (:values
- (push (cons call values) constants))
- (:calls
- (setf constants (nconc values constants)))))))
- leaf)
- (when constants
- (values :calls constants))))))
- ((and walk-functions
- (combination-p uses)
- (eq (combination-kind uses) :known))
- (let ((fun-info (fun-info-constants (combination-fun-info uses))))
- (when fun-info
- (let ((constants (funcall fun-info uses)))
- (when constants
- (multiple-value-bind (kind constants)
- (recurse constants seen)
- (when constants
- (values kind constants))))))))))))
+ (flet ((handle-ref (ref)
+ (let* ((ref (principal-ref ref))
+ (leaf (and ref
+ (ref-leaf ref))))
+ (cond ((lambda-var-p leaf)
+ (let ((seen (or seen (alloc-xset)))
+ constants)
+ (add-to-xset lvar seen)
+ (map-lambda-var-refs-from-calls
+ (lambda (call lvar)
+ (unless (xset-member-p lvar seen)
+ (add-to-xset lvar seen)
+ (multiple-value-bind (type values) (recurse lvar seen)
+ (case type
+ (:values
+ (push (cons call values) constants))
+ (:calls
+ (setf constants (nconc values constants)))))))
+ leaf)
+ (when constants
+ (values :calls constants))))
+ ((constant-p leaf)
+ (values :values (list (constant-value leaf)))))))
+ (handle-combination (node)
+ (and (combination-p node)
+ (eq (combination-kind node) :known)
+ (let ((fun-info (fun-info-constants (combination-fun-info node))))
+ (when fun-info
+ (let ((constants (funcall fun-info node)))
+ (when constants
+ (multiple-value-bind (kind constants)
+ (recurse constants seen)
+ (when constants
+ (values kind constants))))))))))
+ (cond ((constant-lvar-p lvar)
+ (values :values (list (lvar-value lvar))))
+ ((constant-lvar-uses-p lvar)
+ (values :values (lvar-uses-values lvar)))
+ ((ref-p uses)
+ (handle-ref uses))
+ (walk-functions
+ (if (consp uses)
+ (let (constants)
+ (loop for use in uses
+ do (multiple-value-bind (kind values)
+ (typecase use
+ (ref
+ (handle-ref use))
+ (t
+ (handle-combination use)))
+ (case kind
+ (:values
+ (setf constants (nconc values constants)))
+ (:valls
+ (setf constants (nconc values (cdr constants))))
+ (t
+ (return))))
+ finally (return (values :values constants))))
+ (handle-combination uses))))))))
(defun lambda-var-original-name (leaf)
(let ((home (lambda-var-home leaf)))
diff --git a/tests/bad-code.pure.lisp b/tests/bad-code.pure.lisp
index 93b34c766..3db776fc5 100644
--- a/tests/bad-code.pure.lisp
+++ b/tests/bad-code.pure.lisp
@@ -882,6 +882,11 @@
(checked-compile
'(lambda (n)
(setf (car (aref #((1) (2)) n)) 10))
+ :allow-warnings t)))
+ (assert (nth-value 2
+ (checked-compile
+ '(lambda (x)
+ (sort (if x (aref #((1) (4)) x)) #'>))
:allow-warnings t))))
(with-test (:name :constant-modification-nil)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-05 00:02:25
|
The branch "master" has been updated in SBCL:
via 898313d8e7d3d953e8153d74da078975c2957bf4 (commit)
from ac5a3f378a16d1b3a7a002eb1194d958f49fe0f2 (commit)
- Log -----------------------------------------------------------------
commit 898313d8e7d3d953e8153d74da078975c2957bf4
Author: Stas Boukarev <sta...@gm...>
Date: Fri Jun 5 02:25:25 2026 +0300
More constant modification pass-throughs
---
src/compiler/seqtran.lisp | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 858a7b6da..c1a5c0d7c 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -4299,6 +4299,14 @@
(defoptimizers constants (car cdr) ((cons))
cons)
+(defoptimizers constants (%find-position %find-position-if %find-position-if-not)
+ ((x sequence from-end start end key))
+ sequence)
+
+(defoptimizers constants (remove remove-if remove-if-not)
+ ((x sequence &rest rest))
+ sequence)
+
(defoptimizer (vector-to-list derive-type) ((vector))
(when (typep (nth-value 1 (sequence-lvar-dimensions vector)) '(integer 1))
(specifier-type 'cons)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-04 23:16:58
|
The branch "master" has been updated in SBCL:
via ac5a3f378a16d1b3a7a002eb1194d958f49fe0f2 (commit)
from b378f284eab221c5c1dc914d5c12e67dc0ed4cf0 (commit)
- Log -----------------------------------------------------------------
commit ac5a3f378a16d1b3a7a002eb1194d958f49fe0f2
Author: Stas Boukarev <sta...@gm...>
Date: Fri Jun 5 02:13:20 2026 +0300
constant-sequence-element-type: ignore circular lists
---
src/compiler/array-tran.lisp | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index e0d5364ba..c88f9aacd 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -198,7 +198,9 @@
(cdr-type *empty-type*)
cdr-min cdr-max cdr-symbols)
(if (if (listp sequence)
- (null sequence)
+ (or (null sequence)
+ (unless (proper-or-dotted-list-p sequence)
+ (return-from constant-sequence-element-type *universal-type*)))
(= (array-total-size sequence) 0))
*empty-type*
(let ()
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-04 22:32:40
|
The branch "master" has been updated in SBCL:
via b378f284eab221c5c1dc914d5c12e67dc0ed4cf0 (commit)
from de8f08567ed68a0eabcf024199abf67206b76462 (commit)
- Log -----------------------------------------------------------------
commit b378f284eab221c5c1dc914d5c12e67dc0ed4cf0
Author: Stas Boukarev <sta...@gm...>
Date: Fri Jun 5 01:30:34 2026 +0300
Add a type deriver for ELT
It's not always transformed to NTH or AREF.
---
src/compiler/array-tran.lisp | 3 +++
tests/seq.pure.lisp | 9 +++++++++
2 files changed, 12 insertions(+)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 2c354a117..e0d5364ba 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -490,6 +490,9 @@
(defoptimizer (aref derive-type) ((array &rest subscripts))
(sequence-elements-type array))
+(defoptimizer (elt derive-type) ((sequence index))
+ (sequence-elements-type sequence))
+
(defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts))
(assert-new-value-type new-value array))
diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp
index 8b11b0506..119542e4c 100644
--- a/tests/seq.pure.lisp
+++ b/tests/seq.pure.lisp
@@ -1137,3 +1137,12 @@
((v '(1 2)) v)
((v #(2 3)) v)
((v #9*1) v))))
+
+(with-test (:name :elt-constants-type)
+ (assert-type
+ (lambda (x n)
+ (elt (if x
+ #(1 2)
+ '(1 3))
+ n))
+ (integer 1 3)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-04 22:32:38
|
The branch "master" has been updated in SBCL:
via de8f08567ed68a0eabcf024199abf67206b76462 (commit)
from a7b2d403a2eaaff69a7e3b0cf67922dd000c38fb (commit)
- Log -----------------------------------------------------------------
commit de8f08567ed68a0eabcf024199abf67206b76462
Author: Stas Boukarev <sta...@gm...>
Date: Thu Jun 4 23:22:19 2026 +0300
Unify the sequence element-type derivers
---
src/compiler/array-tran.lisp | 451 +++++++++++++++++++------------------------
tests/compiler-2.pure.lisp | 4 +-
2 files changed, 205 insertions(+), 250 deletions(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index a4582063d..2c354a117 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -171,79 +171,6 @@
;;;; DERIVE-TYPE optimizers
-(defun sequence-elements-type (sequence &optional key)
- (let ((constant (lvar-constant sequence))
- min
- max
- union)
- (or (when constant
- (if (and (arrayp (constant-value constant))
- (not key))
- (derive-aref-type sequence)
- (or (getf (leaf-info constant) key)
- (setf (getf (leaf-info constant) key)
- (let ((sequence (constant-value constant)))
- (if (null sequence)
- *universal-type*
- (flet ((process (elt)
- (let* ((elt (if key
- (handler-case (funcall key elt)
- (error ()
- (return-from sequence-elements-type *universal-type*)))
- elt))
- (type (typecase elt ;; ctype-of gives too much detail
- (integer
- (if min
- (setf min (min min elt)
- max (max max elt))
- (setf min elt
- max elt))
- nil)
- (cons
- (specifier-type 'cons))
- (simple-string
- (specifier-type 'simple-string))
- (string
- (specifier-type 'string))
- (simple-vector
- (specifier-type 'simple-vector))
- ((simple-array * (*))
- (specifier-type '(simple-array * (*))))
- (vector
- (specifier-type 'vector))
- (array
- (specifier-type 'array))
- (character
- (specifier-type 'character))
- (symbol
- (specifier-type 'symbol))
- (double-float
- (specifier-type 'double-float))
- (single-float
- (specifier-type 'single-float))
- (t (return-from sequence-elements-type *universal-type*)))))
- (when type
- (setf union
- (if union
- (type-union union type)
- type))))))
- (when (cond ((vectorp sequence)
- (loop for x across sequence
- do (process x))
- t)
- ((proper-or-dotted-list-p sequence)
- (loop for car = (pop sequence)
- do (process car)
- while (consp sequence))
- t))
- (if min
- (let ((int (make-numeric-type 'integer min max)))
- (if union
- (type-union union int)
- int))
- union)))))))))
- (type-array-element-type (lvar-type sequence)))))
-
(defmacro xc-typecase (arg &rest clauses)
#+sb-xc-host
`(cond ,@(mapcar (lambda (clause)
@@ -251,7 +178,15 @@
clauses))
#-sb-xc-host `(typecase ,arg . ,clauses))
-(defun constant-array-element-type (constant)
+(defun dotted-list-length (list)
+ (let ((length 0))
+ (declare (fixnum length))
+ (loop until (atom list)
+ do (pop list)
+ (incf length))
+ length))
+
+(defun constant-sequence-element-type (sequence &optional key)
(let (min
max
symbols
@@ -262,179 +197,197 @@
car-min car-max car-symbols
(cdr-type *empty-type*)
cdr-min cdr-max cdr-symbols)
- (block nil
- (when constant
- (or (getf (leaf-info constant) nil)
- (setf (getf (leaf-info constant) nil)
- (let ((array (constant-value constant)))
- (or
- (and (zerop (array-total-size array))
- *empty-type*)
- #-sb-xc-host
- (flet ((int-min-max (array min max)
- (declare (optimize (insert-array-bounds-checks 0)))
- (with-array-data ((array array) (start) (end))
- (let ((min min)
- (max max))
- (loop for i from start below end
- do
- (let ((elt (aref array i)))
- (when (> elt max)
- (setf max elt))
- (when (< elt min)
- (setf min elt))))
- (make-numeric-type 'integer min max)))))
- (declare (inline int-min-max))
- (macrolet ((test (type)
- (let ((ctype (specifier-type type)))
- `(and (typep array '(array ,type))
- (int-min-max (the (array ,type) array)
- ,(numeric-type-high ctype)
- ,(numeric-type-low ctype))))))
- (cond
- ((test word))
- ((test sb-vm:signed-word))
- ((test (unsigned-byte 8)))
- ((test (signed-byte 8)))
- ((test (unsigned-byte 16)))
- ((test (signed-byte 16)))
- #+64-bit
- ((test (unsigned-byte 32)))
- #+64-bit
- ((test (signed-byte 32)))
- ((test fixnum))
- ((test bit))
- ((csubtypep (array-type-specialized-element-type (leaf-type constant))
- (specifier-type '(or float complex base-char)))
- (return)))))
- (flet ((lower-type (elt min max set-min set-max symbols set-symbols
- give-up)
- (declare (ignorable symbols set-symbols))
- ;; ctype-of gives too much detail
- (xc-typecase elt
- (integer
- (funcall set-min
- (if min
- (min min elt)
- elt))
- (funcall set-max
- (if max
- (max max elt)
- elt))
- nil)
- #+sb-xc-host
- (symbol
- (specifier-type 'symbol))
- #-sb-xc-host
- (symbol
- (unless symbols
- (setf symbols (alloc-xset)))
- (add-to-xset elt symbols)
- (funcall set-symbols symbols)
- nil)
- (cons
- (specifier-type 'cons))
- (simple-string
- (specifier-type 'simple-string))
- (string
- (specifier-type 'string))
- (simple-vector
- (specifier-type 'simple-vector))
- ((simple-array * (*))
- (specifier-type '(simple-array * (*))))
- (vector
- (specifier-type 'vector))
- (array
- (specifier-type 'array))
- #+sb-unicode
- (base-char
- (specifier-type 'base-char))
- (character
- (specifier-type 'character))
- (double-float
- (specifier-type 'double-float))
- (single-float
- (specifier-type 'single-float))
- (t (funcall give-up)))))
- (loop for i below (array-total-size array)
- for elt = (row-major-aref array i)
- for type = (cond ((and conses
- (consp elt))
- (block nil
- (let ((type (lower-type (car elt) car-min car-max
- (lambda (new)
- (setf car-min new))
- (lambda (new)
- (setf car-max new))
- car-symbols
- (lambda (new)
- (setf car-symbols new))
- (lambda ()
- (setf conses nil)
- (return (specifier-type 'cons))))))
- (when type
- (setf car-type (type-union type car-type))))
- (let ((type (lower-type (cdr elt) cdr-min cdr-max
- (lambda (new)
- (setf cdr-min new))
- (lambda (new)
- (setf cdr-max new))
- cdr-symbols
- (lambda (new)
- (setf cdr-symbols new))
- (lambda ()
- (setf conses nil)
- (return (specifier-type 'cons))))))
- (when type
- (setf cdr-type (type-union type cdr-type))))
- (setf any-conses t)
- nil))
- (t
- (lower-type elt min max
- (lambda (new)
- (setf min new))
- (lambda (new)
- (setf max new))
- symbols
- (lambda (new)
- (setf symbols new))
- (lambda ()
- (return)))))
- do (when type
- (setf union
- (if union
- (type-union union type)
- type)))
- finally
- (flet ((result (union symbols min max)
- (when symbols
- (let ((symbols (make-member-type symbols)))
- (setf union (if union
- (type-union union symbols)
- symbols))))
- (if min
- (let ((int (make-numeric-type 'integer min max)))
- (if union
- (type-union union int)
- int))
- union)))
- (let ((union (result union symbols min max)))
- (return
- (if (and conses
- any-conses)
- (type-union (or union *empty-type*)
- (sb-c::make-cons-type (result car-type car-symbols car-min car-max)
- (result cdr-type cdr-symbols cdr-min cdr-max)))
- union))))))))))))))
+ (if (if (listp sequence)
+ (null sequence)
+ (= (array-total-size sequence) 0))
+ *empty-type*
+ (let ()
+ #-sb-xc-host
+ (unless key
+ (flet ((int-min-max (array min max)
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (with-array-data ((array array) (start) (end))
+ (let ((min min)
+ (max max))
+ (loop for i from start below end
+ do
+ (let ((elt (aref array i)))
+ (when (> elt max)
+ (setf max elt))
+ (when (< elt min)
+ (setf min elt))))
+ (make-numeric-type 'integer min max)))))
+ (declare (inline int-min-max))
+ (when (arrayp sequence)
+ (macrolet ((test (type)
+ (let ((ctype (specifier-type type)))
+ `(and (typep sequence '(array ,type))
+ (int-min-max (the (array ,type) sequence)
+ ,(numeric-type-high ctype)
+ ,(numeric-type-low ctype))))))
+ (cond
+ ((test word))
+ ((test sb-vm:signed-word))
+ ((test (unsigned-byte 8)))
+ ((test (signed-byte 8)))
+ ((test (unsigned-byte 16)))
+ ((test (signed-byte 16)))
+ #+64-bit
+ ((test (unsigned-byte 32)))
+ #+64-bit
+ ((test (signed-byte 32)))
+ ((test fixnum))
+ ((test bit))
+ ((typep sequence '(or (array base-char) (array double-float) (array single-float)
+ (array (complex double-float)) (array (complex single-float))))
+ (return-from constant-sequence-element-type)))))))
+ (flet ((lower-type (elt min max set-min set-max symbols set-symbols
+ give-up)
+ (declare (ignorable symbols set-symbols))
+ ;; ctype-of gives too much detail
+ (xc-typecase elt
+ (integer
+ (funcall set-min
+ (if min
+ (min min elt)
+ elt))
+ (funcall set-max
+ (if max
+ (max max elt)
+ elt))
+ nil)
+ #+sb-xc-host
+ (symbol
+ (specifier-type 'symbol))
+ #-sb-xc-host
+ (symbol
+ (unless symbols
+ (setf symbols (alloc-xset)))
+ (add-to-xset elt symbols)
+ (funcall set-symbols symbols)
+ nil)
+ (cons
+ (specifier-type 'cons))
+ (simple-string
+ (specifier-type 'simple-string))
+ (string
+ (specifier-type 'string))
+ (simple-vector
+ (specifier-type 'simple-vector))
+ ((simple-array * (*))
+ (specifier-type '(simple-array * (*))))
+ (vector
+ (specifier-type 'vector))
+ (array
+ (specifier-type 'array))
+ #+sb-unicode
+ (base-char
+ (specifier-type 'base-char))
+ (character
+ (specifier-type 'character))
+ (double-float
+ (specifier-type 'double-float))
+ (single-float
+ (specifier-type 'single-float))
+ (t (funcall give-up)))))
+ (loop for i below (if (arrayp sequence)
+ (array-total-size sequence)
+ (dotted-list-length sequence))
+ for elt* = (if (arrayp sequence)
+ (row-major-aref sequence i)
+ (elt sequence i))
+ for elt = (if key
+ (handler-case (funcall key elt*)
+ (error ()
+ (return-from constant-sequence-element-type *universal-type*)))
+ elt*)
+ for type = (cond ((and conses
+ (consp elt))
+ (block nil
+ (let ((type (lower-type (car elt) car-min car-max
+ (lambda (new)
+ (setf car-min new))
+ (lambda (new)
+ (setf car-max new))
+ car-symbols
+ (lambda (new)
+ (setf car-symbols new))
+ (lambda ()
+ (setf conses nil)
+ (return (specifier-type 'cons))))))
+ (when type
+ (setf car-type (type-union type car-type))))
+ (let ((type (lower-type (cdr elt) cdr-min cdr-max
+ (lambda (new)
+ (setf cdr-min new))
+ (lambda (new)
+ (setf cdr-max new))
+ cdr-symbols
+ (lambda (new)
+ (setf cdr-symbols new))
+ (lambda ()
+ (setf conses nil)
+ (return (specifier-type 'cons))))))
+ (when type
+ (setf cdr-type (type-union type cdr-type))))
+ (setf any-conses t)
+ nil))
+ (t
+ (lower-type elt min max
+ (lambda (new)
+ (setf min new))
+ (lambda (new)
+ (setf max new))
+ symbols
+ (lambda (new)
+ (setf symbols new))
+ (lambda ()
+ (return)))))
+ do (when type
+ (setf union
+ (if union
+ (type-union union type)
+ type)))
+ finally
+ (flet ((result (union symbols min max)
+ (when symbols
+ (let ((symbols (make-member-type symbols)))
+ (setf union (if union
+ (type-union union symbols)
+ symbols))))
+ (if min
+ (let ((int (make-numeric-type 'integer min max)))
+ (if union
+ (type-union union int)
+ int))
+ union)))
+ (let ((union (result union symbols min max)))
+ (return
+ (if (and conses
+ any-conses)
+ (type-union (or union *empty-type*)
+ (sb-c::make-cons-type (result car-type car-symbols car-min car-max)
+ (result cdr-type cdr-symbols cdr-min cdr-max)))
+ union))))))))))
+(defun unwild (type)
+ (if (eq type *wild-type*)
+ *universal-type*
+ type))
-(defun derive-aref-type (array)
- (or (let ((uses (lvar-uses array)))
+(defun constant-array-element-type (constant key)
+ (when constant
+ (or (getf (leaf-info constant) key)
+ (setf (getf (leaf-info constant) key)
+ (constant-sequence-element-type (constant-value constant) key)))))
+
+(defun sequence-elements-type (sequence &optional key)
+ (or (let ((uses (lvar-uses sequence)))
(if (consp uses)
(let (other-types
constant-types)
(loop for use in uses
do
- (let ((type (constant-array-element-type (node-constant use))))
+ (let ((type (constant-array-element-type (node-constant use) key)))
(if type
(push type constant-types)
(push (node-single-value-type use) other-types))))
@@ -445,8 +398,10 @@
(unless (eq element-type *wild-type*)
(type-union union element-type)))
union))))
- (constant-array-element-type (node-constant uses))))
- (type-array-element-type (lvar-type array))))
+ (constant-array-element-type (node-constant uses) key)))
+ (if key
+ *universal-type*
+ (unwild (type-array-element-type (lvar-type sequence))))))
(deftransform array-in-bounds-p ((array &rest subscripts))
(block nil
@@ -533,7 +488,7 @@
(give-up))))))))
(defoptimizer (aref derive-type) ((array &rest subscripts))
- (derive-aref-type array))
+ (sequence-elements-type array))
(defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts))
(assert-new-value-type new-value array))
@@ -542,14 +497,14 @@
(hairy-data-vector-ref hairy-data-vector-ref/check-bounds
data-vector-ref)
((array index))
- (derive-aref-type array))
+ (sequence-elements-type array))
#+(or x86 x86-64)
(defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
- (derive-aref-type array))
+ (sequence-elements-type array))
(defoptimizer (vector-pop derive-type) ((array))
- (derive-aref-type array))
+ (sequence-elements-type array))
(deftransform vector-push-extend ((element vector) * * :node node)
(let* ((type (lvar-type vector))
@@ -657,7 +612,7 @@
(derive-%with-array-data/mumble-type array))
(defoptimizer (row-major-aref derive-type) ((array index))
- (derive-aref-type array))
+ (sequence-elements-type array))
(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
(assert-new-value-type new-value array))
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 5f4af64c4..87a85d31d 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -4656,14 +4656,14 @@
(loop for x in '(a b c)
when (eql n x)
return x))
- symbol)
+ (member a b c nil))
(assert-type
(lambda (n)
(let ((x '(1 2 (10))))
(dolist (x x)
(when (eql x n)
(return x)))))
- (or list (integer 1 2)))
+ (or (integer 1 2) (cons (integer 10 10) null) null))
(assert-type
(lambda (n)
(declare (optimize (debug 2)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-04 20:00:06
|
The branch "master" has been updated in SBCL:
via a7b2d403a2eaaff69a7e3b0cf67922dd000c38fb (commit)
from 5881276137ac2b800ac25cbfa9eaecbcddd05a09 (commit)
- Log -----------------------------------------------------------------
commit a7b2d403a2eaaff69a7e3b0cf67922dd000c38fb
Author: Stas Boukarev <sta...@gm...>
Date: Thu Jun 4 22:50:58 2026 +0300
Derive AREF type for multiple uses with constants
---
src/compiler/array-tran.lisp | 369 +++++++++++++++++++++++--------------------
src/compiler/ir1opt.lisp | 21 +++
src/compiler/ir1util.lisp | 3 +
tests/array.pure.lisp | 10 ++
4 files changed, 228 insertions(+), 175 deletions(-)
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 01d69bb8c..a4582063d 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -251,182 +251,201 @@
clauses))
#-sb-xc-host `(typecase ,arg . ,clauses))
-(defun derive-aref-type (array)
- (or (let ((constant (lvar-constant array))
- min
- max
- symbols
- union
- (conses t)
- any-conses
- (car-type *empty-type*)
- car-min car-max car-symbols
- (cdr-type *empty-type*)
- cdr-min cdr-max cdr-symbols)
- (block nil
- (when constant
- (or (getf (leaf-info constant) nil)
- (setf (getf (leaf-info constant) nil)
- (let ((array (constant-value constant)))
- (or
- (and (zerop (array-total-size array))
- *empty-type*)
- #-sb-xc-host
- (flet ((int-min-max (array min max)
- (declare (optimize (insert-array-bounds-checks 0)))
- (with-array-data ((array array) (start) (end))
- (let ((min min)
- (max max))
- (loop for i from start below end
- do
- (let ((elt (aref array i)))
- (when (> elt max)
- (setf max elt))
- (when (< elt min)
- (setf min elt))))
- (make-numeric-type 'integer min max)))))
- (declare (inline int-min-max))
- (macrolet ((test (type)
- (let ((ctype (specifier-type type)))
- `(and (typep array '(array ,type))
- (int-min-max (the (array ,type) array)
- ,(numeric-type-high ctype)
- ,(numeric-type-low ctype))))))
- (cond
- ((test word))
- ((test sb-vm:signed-word))
- ((test (unsigned-byte 8)))
- ((test (signed-byte 8)))
- ((test (unsigned-byte 16)))
- ((test (signed-byte 16)))
- #+64-bit
- ((test (unsigned-byte 32)))
- #+64-bit
- ((test (signed-byte 32)))
- ((test fixnum))
- ((test bit))
- ((csubtypep (array-type-specialized-element-type (leaf-type constant))
- (specifier-type '(or float complex base-char)))
- (return)))))
- (flet ((lower-type (elt min max set-min set-max symbols set-symbols
- give-up)
- (declare (ignorable symbols set-symbols))
- ;; ctype-of gives too much detail
- (xc-typecase elt
- (integer
- (funcall set-min
- (if min
- (min min elt)
- elt))
- (funcall set-max
- (if max
- (max max elt)
- elt))
- nil)
- #+sb-xc-host
- (symbol
- (specifier-type 'symbol))
- #-sb-xc-host
- (symbol
- (unless symbols
- (setf symbols (alloc-xset)))
- (add-to-xset elt symbols)
- (funcall set-symbols symbols)
- nil)
- (cons
- (specifier-type 'cons))
- (simple-string
- (specifier-type 'simple-string))
- (string
- (specifier-type 'string))
- (simple-vector
- (specifier-type 'simple-vector))
- ((simple-array * (*))
- (specifier-type '(simple-array * (*))))
- (vector
- (specifier-type 'vector))
- (array
- (specifier-type 'array))
- #+sb-unicode
- (base-char
- (specifier-type 'base-char))
- (character
- (specifier-type 'character))
- (double-float
- (specifier-type 'double-float))
- (single-float
- (specifier-type 'single-float))
- (t (funcall give-up)))))
- (loop for i below (array-total-size array)
- for elt = (row-major-aref array i)
- for type = (cond ((and conses
- (consp elt))
- (block nil
- (let ((type (lower-type (car elt) car-min car-max
- (lambda (new)
- (setf car-min new))
- (lambda (new)
- (setf car-max new))
- car-symbols
- (lambda (new)
- (setf car-symbols new))
- (lambda ()
- (setf conses nil)
- (return (specifier-type 'cons))))))
- (when type
- (setf car-type (type-union type car-type))))
- (let ((type (lower-type (cdr elt) cdr-min cdr-max
- (lambda (new)
- (setf cdr-min new))
- (lambda (new)
- (setf cdr-max new))
- cdr-symbols
- (lambda (new)
- (setf cdr-symbols new))
- (lambda ()
- (setf conses nil)
- (return (specifier-type 'cons))))))
- (when type
- (setf cdr-type (type-union type cdr-type))))
- (setf any-conses t)
- nil))
- (t
- (lower-type elt min max
- (lambda (new)
- (setf min new))
- (lambda (new)
- (setf max new))
- symbols
- (lambda (new)
- (setf symbols new))
- (lambda ()
- (return)))))
- do (when type
- (setf union
+(defun constant-array-element-type (constant)
+ (let (min
+ max
+ symbols
+ union
+ (conses t)
+ any-conses
+ (car-type *empty-type*)
+ car-min car-max car-symbols
+ (cdr-type *empty-type*)
+ cdr-min cdr-max cdr-symbols)
+ (block nil
+ (when constant
+ (or (getf (leaf-info constant) nil)
+ (setf (getf (leaf-info constant) nil)
+ (let ((array (constant-value constant)))
+ (or
+ (and (zerop (array-total-size array))
+ *empty-type*)
+ #-sb-xc-host
+ (flet ((int-min-max (array min max)
+ (declare (optimize (insert-array-bounds-checks 0)))
+ (with-array-data ((array array) (start) (end))
+ (let ((min min)
+ (max max))
+ (loop for i from start below end
+ do
+ (let ((elt (aref array i)))
+ (when (> elt max)
+ (setf max elt))
+ (when (< elt min)
+ (setf min elt))))
+ (make-numeric-type 'integer min max)))))
+ (declare (inline int-min-max))
+ (macrolet ((test (type)
+ (let ((ctype (specifier-type type)))
+ `(and (typep array '(array ,type))
+ (int-min-max (the (array ,type) array)
+ ,(numeric-type-high ctype)
+ ,(numeric-type-low ctype))))))
+ (cond
+ ((test word))
+ ((test sb-vm:signed-word))
+ ((test (unsigned-byte 8)))
+ ((test (signed-byte 8)))
+ ((test (unsigned-byte 16)))
+ ((test (signed-byte 16)))
+ #+64-bit
+ ((test (unsigned-byte 32)))
+ #+64-bit
+ ((test (signed-byte 32)))
+ ((test fixnum))
+ ((test bit))
+ ((csubtypep (array-type-specialized-element-type (leaf-type constant))
+ (specifier-type '(or float complex base-char)))
+ (return)))))
+ (flet ((lower-type (elt min max set-min set-max symbols set-symbols
+ give-up)
+ (declare (ignorable symbols set-symbols))
+ ;; ctype-of gives too much detail
+ (xc-typecase elt
+ (integer
+ (funcall set-min
+ (if min
+ (min min elt)
+ elt))
+ (funcall set-max
+ (if max
+ (max max elt)
+ elt))
+ nil)
+ #+sb-xc-host
+ (symbol
+ (specifier-type 'symbol))
+ #-sb-xc-host
+ (symbol
+ (unless symbols
+ (setf symbols (alloc-xset)))
+ (add-to-xset elt symbols)
+ (funcall set-symbols symbols)
+ nil)
+ (cons
+ (specifier-type 'cons))
+ (simple-string
+ (specifier-type 'simple-string))
+ (string
+ (specifier-type 'string))
+ (simple-vector
+ (specifier-type 'simple-vector))
+ ((simple-array * (*))
+ (specifier-type '(simple-array * (*))))
+ (vector
+ (specifier-type 'vector))
+ (array
+ (specifier-type 'array))
+ #+sb-unicode
+ (base-char
+ (specifier-type 'base-char))
+ (character
+ (specifier-type 'character))
+ (double-float
+ (specifier-type 'double-float))
+ (single-float
+ (specifier-type 'single-float))
+ (t (funcall give-up)))))
+ (loop for i below (array-total-size array)
+ for elt = (row-major-aref array i)
+ for type = (cond ((and conses
+ (consp elt))
+ (block nil
+ (let ((type (lower-type (car elt) car-min car-max
+ (lambda (new)
+ (setf car-min new))
+ (lambda (new)
+ (setf car-max new))
+ car-symbols
+ (lambda (new)
+ (setf car-symbols new))
+ (lambda ()
+ (setf conses nil)
+ (return (specifier-type 'cons))))))
+ (when type
+ (setf car-type (type-union type car-type))))
+ (let ((type (lower-type (cdr elt) cdr-min cdr-max
+ (lambda (new)
+ (setf cdr-min new))
+ (lambda (new)
+ (setf cdr-max new))
+ cdr-symbols
+ (lambda (new)
+ (setf cdr-symbols new))
+ (lambda ()
+ (setf conses nil)
+ (return (specifier-type 'cons))))))
+ (when type
+ (setf cdr-type (type-union type cdr-type))))
+ (setf any-conses t)
+ nil))
+ (t
+ (lower-type elt min max
+ (lambda (new)
+ (setf min new))
+ (lambda (new)
+ (setf max new))
+ symbols
+ (lambda (new)
+ (setf symbols new))
+ (lambda ()
+ (return)))))
+ do (when type
+ (setf union
+ (if union
+ (type-union union type)
+ type)))
+ finally
+ (flet ((result (union symbols min max)
+ (when symbols
+ (let ((symbols (make-member-type symbols)))
+ (setf union (if union
+ (type-union union symbols)
+ symbols))))
+ (if min
+ (let ((int (make-numeric-type 'integer min max)))
(if union
- (type-union union type)
- type)))
- finally
- (flet ((result (union symbols min max)
- (when symbols
- (let ((symbols (make-member-type symbols)))
- (setf union (if union
- (type-union union symbols)
- symbols))))
- (if min
- (let ((int (make-numeric-type 'integer min max)))
- (if union
- (type-union union int)
- int))
- union)))
- (let ((union (result union symbols min max)))
- (return
- (if (and conses
- any-conses)
- (type-union (or union *empty-type*)
- (sb-c::make-cons-type (result car-type car-symbols car-min car-max)
- (result cdr-type cdr-symbols cdr-min cdr-max)))
- union)))))))))))))
+ (type-union union int)
+ int))
+ union)))
+ (let ((union (result union symbols min max)))
+ (return
+ (if (and conses
+ any-conses)
+ (type-union (or union *empty-type*)
+ (sb-c::make-cons-type (result car-type car-symbols car-min car-max)
+ (result cdr-type cdr-symbols cdr-min cdr-max)))
+ union))))))))))))))
+
+(defun derive-aref-type (array)
+ (or (let ((uses (lvar-uses array)))
+ (if (consp uses)
+ (let (other-types
+ constant-types)
+ (loop for use in uses
+ do
+ (let ((type (constant-array-element-type (node-constant use))))
+ (if type
+ (push type constant-types)
+ (push (node-single-value-type use) other-types))))
+ (when constant-types
+ (let ((union (sb-kernel::%type-union constant-types)))
+ (if other-types
+ (let ((element-type (type-array-element-type (sb-kernel::%type-union other-types))))
+ (unless (eq element-type *wild-type*)
+ (type-union union element-type)))
+ union))))
+ (constant-array-element-type (node-constant uses))))
(type-array-element-type (lvar-type array))))
(deftransform array-in-bounds-p ((array &rest subscripts))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 0431cd88b..2b5c0d684 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -40,6 +40,27 @@
;; check for EQL types and singleton numeric types
(values (type-singleton-p type)))))
+(defun node-constant (node &optional ignore-types)
+ (when node
+ (let ((type (node-derived-type node)))
+ (labels ((process-ref (ref)
+ (when (ref-p ref)
+ (let (leaf)
+ (if (constant-p (setf leaf (ref-leaf ref)))
+ (when (or ignore-types
+ (ctypep (constant-value leaf) (single-value-type type)))
+ (values leaf ref))
+ (process-lvar (lambda-var-ref-lvar ref))))))
+ (process-lvar (lvar)
+ (when lvar
+ (process-ref (lvar-uses (principal-lvar lvar)))))
+ (process-node (node)
+ (cond ((cast-p node)
+ (process-lvar (cast-value node)))
+ ((ref-p node)
+ (process-ref node)))))
+ (process-node node)))))
+
(defun lvar-constant (lvar &optional ignore-types)
(declare (type lvar lvar))
(let ((type (lvar-type lvar)))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 425466049..bf1a3c846 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -712,6 +712,9 @@
(handle-combination dest))))))))
(erase lvar nth-value))))
+(defun node-single-value-type (node)
+ (single-value-type (node-derived-type node)))
+
;;; Update lvar use information so that NODE is no longer a use of its
;;; LVAR.
;;;
diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
index 27ef5602e..27d8b3309 100644
--- a/tests/array.pure.lisp
+++ b/tests/array.pure.lisp
@@ -1156,3 +1156,13 @@
a
(error "")))
(and array (not simple-array))))
+
+(with-test (:name :aref-constants-type)
+ (assert-type
+ (lambda (x n)
+ (aref (if n #(1 -2) #(1 2)) x))
+ (integer -2 2))
+ (assert-type
+ (lambda (x n)
+ (aref (if n (the string n) #(1 2)) x))
+ (or (integer 1 2) character)))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-03 01:19:27
|
The branch "master" has been updated in SBCL:
via 5881276137ac2b800ac25cbfa9eaecbcddd05a09 (commit)
from 91b8b81d14e0b722eee160765e151fae84c0637b (commit)
- Log -----------------------------------------------------------------
commit 5881276137ac2b800ac25cbfa9eaecbcddd05a09
Author: Stas Boukarev <sta...@gm...>
Date: Wed Jun 3 04:16:23 2026 +0300
check-concatenate: consider each constant value
---
src/compiler/seqtran.lisp | 47 +++++++++++++++++++++++++++++++++--------------
tests/bad-code.pure.lisp | 7 +++++++
2 files changed, 40 insertions(+), 14 deletions(-)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index db4f7bfc9..858a7b6da 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1842,19 +1842,38 @@
(eq result-element-type *universal-type*))
(loop for i from 0
for sequence in sequences
- for element-type = (sequence-elements-type sequence)
- do (when (and element-type
- (not (eq element-type *wild-type*))
- (not (types-equal-or-intersect element-type result-element-type)))
- (let ((*compiler-error-context* node))
- (compiler-warn "Can't ~a elements of type ~s into ~s"
- description
- (type-specifier element-type)
- (if (ctype-p type)
- (type-specifier (make-array-type '(*)
- :specialized-element-type type
- :element-type type))
- type))))))))
+ for constant = (and (constant-lvar-p sequence)
+ (lvar-value sequence))
+ do (if (and constant
+ (proper-sequence-p constant))
+ (map nil
+ (lambda (elt)
+ (multiple-value-bind (fits really) (ctypep elt result-element-type)
+ (when (and really (not fits))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a ~s, of type ~s, into ~s"
+ description
+ elt (type-of elt)
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type))
+ (return)))))
+ constant)
+ (let ((element-type (sequence-elements-type sequence)))
+ (when (and element-type
+ (not (eq element-type *wild-type*))
+ (not (types-equal-or-intersect element-type result-element-type)))
+ (let ((*compiler-error-context* node))
+ (compiler-warn "Can't ~a elements of type ~s into ~s"
+ description
+ (type-specifier element-type)
+ (if (ctype-p type)
+ (type-specifier (make-array-type '(*)
+ :specialized-element-type type
+ :element-type type))
+ type))))))))))
(defoptimizer (%concatenate-to-string ir2-hook) ((&rest args) node)
(check-concatenate 'string args node))
@@ -1872,7 +1891,7 @@
(defoptimizer (merge ir2-hook) ((type sequence1 sequence2 predicate &key &allow-other-keys) node)
(when (constant-lvar-p type)
- (check-concatenate (lvar-value type) (list sequence1 sequence2) node "merge")))
+ (check-concatenate (lvar-value type) (list sequence1 sequence2) node "merge")))
;;; Expand simple cases of UB<SIZE>-BASH-COPY inline. "simple" is
;;; defined as those cases where we are doing word-aligned copies from
diff --git a/tests/bad-code.pure.lisp b/tests/bad-code.pure.lisp
index e822da9fa..93b34c766 100644
--- a/tests/bad-code.pure.lisp
+++ b/tests/bad-code.pure.lisp
@@ -1101,3 +1101,10 @@
#'list)
1 #'eq))
:allow-style-warnings t))))
+
+(with-test (:name :concatenate-mismatch)
+ (assert (nth-value 2
+ (checked-compile
+ `(lambda (m)
+ (concatenate 'string '(1 #\a) m))
+ :allow-warnings t))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-02 20:52:39
|
The branch "master" has been updated in SBCL:
via 91b8b81d14e0b722eee160765e151fae84c0637b (commit)
from 2329ddf0dca2f182c77e2dea9f72a03fecae3069 (commit)
- Log -----------------------------------------------------------------
commit 91b8b81d14e0b722eee160765e151fae84c0637b
Author: Stas Boukarev <sta...@gm...>
Date: Tue Jun 2 23:50:22 2026 +0300
More thorough type checking for concatenate arguments
Using sequence-elements-type, which works for constant lists and vectors.
---
src/compiler/seqtran.lisp | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 7f0fbc0fc..db4f7bfc9 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -1842,14 +1842,14 @@
(eq result-element-type *universal-type*))
(loop for i from 0
for sequence in sequences
- for sequence-type = (lvar-type sequence)
- for element-type = (type-array-element-type sequence-type)
- do (unless (or (eq element-type *wild-type*)
- (types-equal-or-intersect element-type result-element-type))
+ for element-type = (sequence-elements-type sequence)
+ do (when (and element-type
+ (not (eq element-type *wild-type*))
+ (not (types-equal-or-intersect element-type result-element-type)))
(let ((*compiler-error-context* node))
- (compiler-warn "Can't ~a ~s into ~s"
+ (compiler-warn "Can't ~a elements of type ~s into ~s"
description
- (type-specifier sequence-type)
+ (type-specifier element-type)
(if (ctype-p type)
(type-specifier (make-array-type '(*)
:specialized-element-type type
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-06-01 03:36:49
|
The branch "master" has been updated in SBCL:
via 2329ddf0dca2f182c77e2dea9f72a03fecae3069 (commit)
from 8c7db506073866892480ecd686f164db8a4447aa (commit)
- Log -----------------------------------------------------------------
commit 2329ddf0dca2f182c77e2dea9f72a03fecae3069
Author: Stas Boukarev <sta...@gm...>
Date: Mon Jun 1 06:15:08 2026 +0300
coerce derive-type: exclude rational types
---
src/compiler/srctran.lisp | 13 ++++++++++---
tests/coerce.pure.lisp | 8 ++++++--
2 files changed, 16 insertions(+), 5 deletions(-)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c0fadb58f..ec545cbcd 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -8933,6 +8933,7 @@
symbol (or symbol (simple-array * (0)) extended-sequence function character)
sequence sequence))))
:numeric nil)))
+ ;; Exclude some types if they are excluded from the input value
(let ((value (lvar-type value))
(exclude nil))
(macrolet ((cases (&body cases)
@@ -8941,18 +8942,24 @@
collect `(unless (types-equal-or-intersect (specifier-type ',exclude) value)
(setf exclude
(if exclude
- (type-intersection exclude (specifier-type ',excluded))
+ (type-union exclude (specifier-type ',excluded))
(specifier-type ',excluded))))))))
(unless (or (eq value *universal-type*)
(opaque-type-p value))
+ (let* ((negated (type-negation value))
+ (not-rational (type-intersection negated (specifier-type 'rational))))
+ (unless (eq not-rational *empty-type*)
+ (setf exclude not-rational)))
(cases
number number
real real
- sequence sequence
+ sequence (or list vector)
+ ;; symbol can be coerced to a function which can be an extended sequence
+ (or (and symbol (not null)) sequence) sequence
(and array (not vector)) (and array (not vector))
array (and array (not vector))
(and array (not simple-array)) (and array (not simple-array))
- (or (and symbol (not null)) function cons) function
+ (or symbol function sequence) function
(or character string (and symbol (not null))) character)
(when exclude
(setf value-type
diff --git a/tests/coerce.pure.lisp b/tests/coerce.pure.lisp
index 1510cf057..0b7dfbbee 100644
--- a/tests/coerce.pure.lisp
+++ b/tests/coerce.pure.lisp
@@ -193,7 +193,7 @@
(assert-type
(lambda (x y)
(coerce (the function x) y))
- (or function sequence))
+ (or list (simple-array * (*)) function sb-kernel:extended-sequence))
(assert-type
(lambda (x y)
(coerce (the (and symbol (not null)) x) y))
@@ -225,7 +225,11 @@
(assert-type
(lambda (x y)
(coerce (the (not real) x) y))
- (not real)))
+ (not real))
+ (assert-type
+ (lambda (x y)
+ (coerce (the (not fixnum) x) y))
+ (not fixnum)))
(with-test (:name :numbero-to-list-error)
(assert-error (coerce (opaque-identity 1)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-05-30 14:24:20
|
The branch "master" has been updated in SBCL:
via 8c7db506073866892480ecd686f164db8a4447aa (commit)
from 54d7e2b9026bbcb2954a727d67b809fd503d91d8 (commit)
- Log -----------------------------------------------------------------
commit 8c7db506073866892480ecd686f164db8a4447aa
Author: Stas Boukarev <sta...@gm...>
Date: Sat May 30 17:17:00 2026 +0300
(coerce 1 'list) should signal an error
---
src/code/coerce.lisp | 4 +++-
tests/coerce.pure.lisp | 5 +++++
2 files changed, 8 insertions(+), 1 deletion(-)
diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index 8d1c295c7..d915c4b24 100644
--- a/src/code/coerce.lisp
+++ b/src/code/coerce.lisp
@@ -148,7 +148,9 @@
(vector
(vector-to-list object))
(sequence
- (sb-sequence:make-sequence-like nil (length object) :initial-contents object))))
+ (sb-sequence:make-sequence-like nil (length object) :initial-contents object))
+ (t
+ (coerce-error))))
(function
(coerce-to-fun object))
(t
diff --git a/tests/coerce.pure.lisp b/tests/coerce.pure.lisp
index 32f2fce05..1510cf057 100644
--- a/tests/coerce.pure.lisp
+++ b/tests/coerce.pure.lisp
@@ -226,3 +226,8 @@
(lambda (x y)
(coerce (the (not real) x) y))
(not real)))
+
+(with-test (:name :numbero-to-list-error)
+ (assert-error (coerce (opaque-identity 1)
+ (opaque-identity 'list))
+ type-error))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-05-30 14:24:17
|
The branch "master" has been updated in SBCL:
via 54d7e2b9026bbcb2954a727d67b809fd503d91d8 (commit)
from f5195f65be942f7562f3bf3edc885fed75317498 (commit)
- Log -----------------------------------------------------------------
commit 54d7e2b9026bbcb2954a727d67b809fd503d91d8
Author: Stas Boukarev <sta...@gm...>
Date: Sat May 30 17:08:10 2026 +0300
coerce type derivation: preserve simple array dimensions
---
src/compiler/srctran.lisp | 58 +++++++++++++++++++++++++++++++----------------
tests/coerce.pure.lisp | 2 +-
2 files changed, 39 insertions(+), 21 deletions(-)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index b23d191c3..c0fadb58f 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -8894,26 +8894,44 @@
(type-union type (specifier-type 'sequence))))
((not (types-equal-or-intersect type (specifier-type '(or number sequence symbol))))
type))))
- (cases
- float (or float (complex float))
- integer (or integer float (complex float))
- ratio (or ratio float (complex float))
- rational (or rational float (complex float))
- complex complex
- null (or null (simple-array * (0)) extended-sequence)
- cons (or cons function (simple-array * (*)) extended-sequence)
- (and (simple-array * (*)) (not (string 1))) (or (simple-array * (*)) list extended-sequence)
- (simple-array * (*)) (or (simple-array * (*)) list extended-sequence character)
- (and vector (not string)) sequence
- vector (or sequence character)
- (and array (not vector)) type
- (and simple-array (not (string 1))) (or simple-array list extended-sequence)
- simple-array (or simple-array list extended-sequence character)
- (and array (not string)) (or sequence array)
- array (or sequence array character)
- (and symbol (not null)) (or (and symbol (not null)) function character)
- symbol (or symbol (simple-array * (0)) extended-sequence function character)
- sequence sequence)))
+ (if (and (array-type-p type)
+ (not (array-type-complexp type))
+ (typep (array-type-dimensions type) '(cons fixnum null)))
+ (let ((length (car (array-type-dimensions type)))
+ (et (array-type-specialized-element-type type)))
+ (type-union (specifier-type 'sb-kernel:extended-sequence)
+ (cond ((> length 1)
+ (specifier-type 'cons))
+ ((= length 1)
+ (if (or (eq et *wild-type*)
+ (csubtypep et (specifier-type 'character)))
+ (specifier-type '(or cons character))
+ (specifier-type 'cons)))
+ (t
+ (specifier-type 'list)))
+ (make-array-type (array-type-dimensions type)
+ :element-type *wild-type*
+ :complexp nil)))
+ (cases
+ float (or float (complex float))
+ integer (or integer float (complex float))
+ ratio (or ratio float (complex float))
+ rational (or rational float (complex float))
+ complex complex
+ null (or null (simple-array * (0)) extended-sequence)
+ cons (or cons function (simple-array * (*)) extended-sequence)
+ (and (simple-array * (*)) (not (string 1))) (or (simple-array * (*)) list extended-sequence)
+ (simple-array * (*)) (or (simple-array * (*)) list extended-sequence character)
+ (and vector (not string)) sequence
+ vector (or sequence character)
+ (and array (not vector)) type
+ (and simple-array (not (string 1))) (or simple-array list extended-sequence)
+ simple-array (or simple-array list extended-sequence character)
+ (and array (not string)) (or sequence array)
+ array (or sequence array character)
+ (and symbol (not null)) (or (and symbol (not null)) function character)
+ symbol (or symbol (simple-array * (0)) extended-sequence function character)
+ sequence sequence))))
:numeric nil)))
(let ((value (lvar-type value))
(exclude nil))
diff --git a/tests/coerce.pure.lisp b/tests/coerce.pure.lisp
index 482b5163d..32f2fce05 100644
--- a/tests/coerce.pure.lisp
+++ b/tests/coerce.pure.lisp
@@ -189,7 +189,7 @@
(assert-type
(lambda (y)
(coerce "ab" y))
- (or list (simple-array * (*)) sb-kernel:extended-sequence))
+ (or cons (simple-array * (2)) sb-kernel:extended-sequence))
(assert-type
(lambda (x y)
(coerce (the function x) y))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: stassats <sta...@us...> - 2026-05-30 14:24:15
|
The branch "master" has been updated in SBCL:
via f5195f65be942f7562f3bf3edc885fed75317498 (commit)
from 2868d4dd0e946ab8e0bbea5e1aee778e8873184d (commit)
- Log -----------------------------------------------------------------
commit f5195f65be942f7562f3bf3edc885fed75317498
Author: Stas Boukarev <sta...@gm...>
Date: Sat May 30 16:56:38 2026 +0300
coerce type exclusion: add (and array (not simple-array))
---
src/compiler/srctran.lisp | 1 +
1 file changed, 1 insertion(+)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 88ec395d1..b23d191c3 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -8933,6 +8933,7 @@
sequence sequence
(and array (not vector)) (and array (not vector))
array (and array (not vector))
+ (and array (not simple-array)) (and array (not simple-array))
(or (and symbol (not null)) function cons) function
(or character string (and symbol (not null))) character)
(when exclude
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: melisgl <me...@us...> - 2026-05-30 10:18:20
|
The branch "master" has been updated in SBCL:
via 2868d4dd0e946ab8e0bbea5e1aee778e8873184d (commit)
from cec8b3965734dea6c08976ee9a9b0fa66f513577 (commit)
- Log -----------------------------------------------------------------
commit 2868d4dd0e946ab8e0bbea5e1aee778e8873184d
Author: Gabor Melis <me...@re...>
Date: Fri May 29 12:47:08 2026 +0200
doc: define and clean up docstring syntax
Previously, the format was ad-hoc and implicitly defined by
doc/manual/docstrings.lisp. Now, it is a bit less ad-hoc and still
implicitly defined docstrings.lisp.
The syntax is now a simple, strict subset of Markdown with escaping
extensions. The long comment near the top of docstrings.lisp has the
documentation.
Some notable changes:
- Markdown backticks are supported (e.g. `exit`(3),
`/usr/local/bin/`).
- When the heuristic codification is overly eager, use backslashes to
prevent codification (e.g. \\HTTP, where the backslash is doubled
assuming that this is in a docstring).
- It is now possible to have code that's not downcased
(`\\\\AC_LOCAL`, backslashes doubled again).
- Fenced code blocks are supported (but use them sparingly).
- Texinfo @itemize is used instead of @table.
- Texinfo @var was inconsistently used at best. What used to be @var
is now simply @code.
For the user, the most visible effect of this change is that the
manual has much fewer errors in codification, and a few docstrings
have backticks and escapes in them, which should be acceptably
readable in the sources or via CL:DOCUMENTATION.
---
NEWS | 2 +
contrib/sb-bsd-sockets/inet4.lisp | 4 +-
contrib/sb-bsd-sockets/inet6.lisp | 4 +-
contrib/sb-bsd-sockets/local.lisp | 6 +-
contrib/sb-concurrency/mailbox.lisp | 6 +-
contrib/sb-introspect/introspect.lisp | 2 +-
contrib/sb-md5/md5.lisp | 58 ++--
contrib/sb-posix/interface.lisp | 6 +-
doc/manual/docstrings.lisp | 595 ++++++++++++++++++++++------------
doc/manual/threading.texinfo | 1 +
src/code/alien-callback.lisp | 24 +-
src/code/cold-init.lisp | 10 +-
src/code/deadline.lisp | 13 +-
src/code/defpackage.lisp | 20 +-
src/code/error.lisp | 2 +-
src/code/filesys.lisp | 4 +-
src/code/final.lisp | 62 ++--
src/code/foreign-load.lisp | 8 +-
src/code/loop.lisp | 4 +-
src/code/macros.lisp | 39 ++-
src/code/misc-aliens.lisp | 2 +-
src/code/ntrace.lisp | 141 ++++----
src/code/pprint.lisp | 20 +-
src/code/run-program.lisp | 222 +++++++------
src/code/save.lisp | 148 +++++----
src/code/target-alieneval.lisp | 46 +--
src/code/target-extensions.lisp | 2 +-
src/code/target-hash-table.lisp | 183 ++++++-----
src/code/target-package.lisp | 9 +-
src/code/target-pathname.lisp | 8 +-
src/code/target-random.lisp | 3 +-
src/code/target-thread.lisp | 6 +-
src/code/timer.lisp | 13 +-
src/code/traceroot.lisp | 52 +--
src/code/typep.lisp | 3 +-
src/code/unix.lisp | 2 +-
src/cold/exports.lisp | 21 +-
src/compiler/ir1-translators.lisp | 25 +-
src/compiler/macros.lisp | 4 +-
src/compiler/main.lisp | 143 ++++----
src/pcl/generic-functions.lisp | 8 +-
src/pcl/gray-streams.lisp | 10 +-
42 files changed, 1117 insertions(+), 824 deletions(-)
diff --git a/NEWS b/NEWS
index bdfc34262..217bc2278 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@ changes relative to sbcl-2.6.5:
* bug fix: TRACE no longer fails when trying to print a return value that
cannot be printed readble and *PRINT-READABLY* is true.
* documentation: SB-INTROSPECT is documented.
+ * documentation: fixed many typesetting problems and typos in the user
+ manual.
changes in sbcl-2.6.5 relative to sbcl-2.6.4:
* minor incompatible change: the condition signalled when an accessed slot
diff --git a/contrib/sb-bsd-sockets/inet4.lisp b/contrib/sb-bsd-sockets/inet4.lisp
index 69b405ab2..bee8ec7cd 100644
--- a/contrib/sb-bsd-sockets/inet4.lisp
+++ b/contrib/sb-bsd-sockets/inet4.lisp
@@ -9,9 +9,9 @@
Examples:
- (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)
+ (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)
- (make-instance 'sb-bsd-sockets:inet-socket :type :datagram :protocol :udp)
+ (make-instance 'sb-bsd-sockets:inet-socket :type :datagram :protocol :udp)
")))
(defun address-numbers/v4 (address)
diff --git a/contrib/sb-bsd-sockets/inet6.lisp b/contrib/sb-bsd-sockets/inet6.lisp
index f0007498f..319d47ce7 100644
--- a/contrib/sb-bsd-sockets/inet6.lisp
+++ b/contrib/sb-bsd-sockets/inet6.lisp
@@ -9,9 +9,9 @@
Examples:
- (make-instance 'sb-bsd-sockets:inet6-socket :type :stream :protocol :tcp)
+ (make-instance 'sb-bsd-sockets:inet6-socket :type :stream :protocol :tcp)
- (make-instance 'sb-bsd-sockets:inet6-socket :type :datagram :protocol :udp)
+ (make-instance 'sb-bsd-sockets:inet6-socket :type :datagram :protocol :udp)
")))
(defun address-numbers/v6 (address)
diff --git a/contrib/sb-bsd-sockets/local.lisp b/contrib/sb-bsd-sockets/local.lisp
index aedaf2b54..bb5580927 100644
--- a/contrib/sb-bsd-sockets/local.lisp
+++ b/contrib/sb-bsd-sockets/local.lisp
@@ -6,7 +6,7 @@
(defclass local-socket (socket)
((family :initform sockint::af-local))
(:documentation
- "Class representing local domain (AF_LOCAL) sockets,
+ "Class representing local domain (`\\\\AF_LOCAL`) sockets,
also known as unix-domain sockets."))
(defmethod socket-namestring ((socket local-socket))
@@ -41,8 +41,8 @@ also known as unix-domain sockets."))
(defclass local-abstract-socket (local-socket) ()
(:documentation
- "Class representing local domain (AF_LOCAL) sockets with addresses
-in the abstract namespace."))
+ "Class representing local domain (`\\\\AF_LOCAL`) sockets with
+addresses in the abstract namespace."))
(defmethod make-sockaddr-for ((socket local-abstract-socket)
&optional sockaddr &rest address)
diff --git a/contrib/sb-concurrency/mailbox.lisp b/contrib/sb-concurrency/mailbox.lisp
index c46ba68cb..3225b6218 100644
--- a/contrib/sb-concurrency/mailbox.lisp
+++ b/contrib/sb-concurrency/mailbox.lisp
@@ -127,9 +127,9 @@ message could be received."
from MAILBOX, or returns NIL if no messages are pending.
Note: Concurrent threads may be snarfing messages during the run of
-this function, so even though X,Y appear right next to each other in
-the result, does not necessarily mean that Y was the message sent
-right after X."
+this function, so even `X` and `Y` appearing right next to each other
+in the result does not necessarily mean that `Y` was the message sent
+right after `X`."
(prog* ((msgs '())
(sem (mailbox-semaphore mailbox))
(queue (mailbox-queue mailbox))
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 56c3e7fc7..b3a7fffdc 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -246,7 +246,7 @@ the sexp.")
the time of compilation. NIL if not compiled from a file.")
(plist
nil
- :documentation "The SOURCE-PLIST from WITH-COMPILATION-UNIT in effect
+ :documentation "The `SOURCE-PLIST` from WITH-COMPILATION-UNIT in effect
when the file was compiled.")
;; Any extra metadata that the caller might be interested in. For
;; example, DEFINITION-SOURCE of a method contains the specializers
diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp
index cc2cfe185..501c521af 100644
--- a/contrib/sb-md5/md5.lisp
+++ b/contrib/sb-md5/md5.lisp
@@ -270,7 +270,7 @@ where a is the intended low-order byte and d the high-order byte."
(deftype md5-regs ()
"The working state of the MD5 algorithm, which contains the 4 32-bit
-registers A, B, C and D."
+registers `\\\\A`, `\\\\B`, `\\\\C` and `\\\\D`."
`(ub32-vector 4))
(defmacro md5-regs-a (regs)
@@ -286,13 +286,13 @@ registers A, B, C and D."
`(ub32-aref ,regs 3))
(defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67)
- "Initial value of Register A of the MD5 working state.")
+ "Initial value of Register `\\\\A` of the MD5 working state.")
(defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef)
- "Initial value of Register B of the MD5 working state.")
+ "Initial value of Register `\\\\B` of the MD5 working state.")
(defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98)
- "Initial value of Register C of the MD5 working state.")
+ "Initial value of Register `\\\\C` of the MD5 working state.")
(defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10)
- "Initial value of Register D of the MD5 working state.")
+ "Initial value of Register `\\\\D` of the MD5 working state.")
(declaim (inline initial-md5-regs))
(defun initial-md5-regs ()
@@ -314,8 +314,8 @@ registers A, B, C and D."
(defun update-md5-block (regs block)
"This is the core part of the MD5 algorithm. It takes a complete 16
-word block of input, and updates the working state in A, B, C, and D
-accordingly."
+word block of input, and updates the working state in `\\\\A`,
+`\\\\B`, `\\\\C`, and `\\\\D` accordingly."
(declare (type md5-regs regs)
(type md5-block block)
(optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0)))
@@ -358,7 +358,7 @@ accordingly."
(declaim (inline fill-block fill-block-ub8 fill-block-char))
(defun fill-block-ub8 (block buffer offset)
"Convert a complete 64 (unsigned-byte 8) input vector segment
-starting from `offset' into the given 16 word MD5 block."
+starting from OFFSET into the given 16 word MD5 block."
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
(type md5-block block)
(type (simple-array (unsigned-byte 8) (*)) buffer)
@@ -384,7 +384,7 @@ starting from `offset' into the given 16 word MD5 block."
(defun fill-block-char (block buffer offset)
"DEPRECATED: Convert a complete 64 character input string segment
-starting from `offset' into the given 16 word MD5 block."
+starting from OFFSET into the given 16 word MD5 block."
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
(type md5-block block)
(type simple-string buffer)
@@ -412,9 +412,9 @@ starting from `offset' into the given 16 word MD5 block."
(defun fill-block (block buffer offset)
"Convert a complete 64 byte input vector segment into the given 16
word MD5 block. This currently works on (unsigned-byte 8) and
-character simple-arrays, via the functions `fill-block-ub8' and
-`fill-block-char' respectively. Note that it will not work correctly
-on character simple-arrays if `char-code-limit' is greater than 256."
+character simple-arrays, via the functions FILL-BLOCK-UB8 and
+FILL-BLOCK-CHAR respectively. Note that it will not work correctly
+on character simple-arrays if CHAR-CODE-LIMIT is greater than 256."
(declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
(type md5-block block)
(type (simple-array * (*)) buffer)
@@ -431,7 +431,7 @@ on character simple-arrays if `char-code-limit' is greater than 256."
(declaim (inline md5regs-digest))
(defun md5regs-digest (regs)
"Create the final 16 byte message-digest from the MD5 working state
-in `regs'. Returns a (simple-array (unsigned-byte 8) (16))."
+in REGS. Returns a (simple-array (unsigned-byte 8) (16))."
(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
#+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))
(type md5-regs regs))
@@ -474,9 +474,9 @@ in `regs'. Returns a (simple-array (unsigned-byte 8) (16))."
(declaim (inline copy-to-buffer))
(defun copy-to-buffer (from from-offset count buffer buffer-offset)
- "Copy a partial segment from input vector `from' starting at
-`from-offset' and copying `count' elements into the 64 byte buffer
-starting at `buffer-offset'."
+ "Copy a partial segment from input vector FROM starting at
+FROM-OFFSET and copying COUNT elements into the 64 byte buffer
+starting at BUFFER-OFFSET."
(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
#+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))
(type sb-int:index from-offset)
@@ -510,12 +510,12 @@ starting at `buffer-offset'."
from-index))))))
(defun update-md5-state (state sequence &key (start 0) (end (length sequence)))
- "Update the given md5-state from `sequence', which is either a
+ "Update the given md5-state from SEQUENCE, which is either a
simple-string or a simple-array with element-type (unsigned-byte 8),
-bounded by `start' and `end', which must be numeric bounding-indices.
+bounded by START and END, which must be numeric bounding-indices.
Note that usage on simple-strings is DEPRECATED, since this will not
-work correctly if `char-code-limit' is more than 256. String input
-should be converted to (unsigned-byte 8) simple-arrays with
+work correctly if CHAR-CODE-LIMIT is more than 256. String input
+should be converted to (UNSIGNED-BYTE 8) simple-arrays with
external-format conversion routines beforehand."
(declare (type md5-state state)
(type (simple-array * (*)) sequence)
@@ -591,8 +591,8 @@ by processing any remaining input in its buffer, with suitable padding
and appended bit-length, as specified by the MD5 standard.
The resulting MD5 message-digest is returned as an array of sixteen
-(unsigned-byte 8) values. Calling `update-md5-state' after a call to
-`finalize-md5-state' results in unspecified behaviour."
+(unsigned-byte 8) values. Calling UPDATE-MD5-STATE after a call to
+FINALIZE-MD5-STATE results in unspecified behaviour."
(declare (type md5-state state)
(optimize (speed 3) (safety 1) (space 0) (debug 1) #+lw-int32 (float 0)))
(locally
@@ -633,7 +633,7 @@ The resulting MD5 message-digest is returned as an array of sixteen
;;; High-Level Drivers
(defun md5sum-sequence (sequence &key (start 0) end)
- "Calculate the MD5 message-digest of data in `sequence', which should
+ "Calculate the MD5 message-digest of data in SEQUENCE, which should
be a 1d simple-array with element type (unsigned-byte 8). On CMU CL
and SBCL non-simple and non-1d arrays with this element-type are also
supported."
@@ -666,8 +666,8 @@ supported."
(defun md5sum-string (string &key (external-format :default) (start 0) end)
"Calculate the MD5 message-digest of the binary representation of
-`string' (as octets) in the external format specified by
-`external-format'. The boundaries `start' and `end' refer to character
+STRING (as octets) in the external format specified by
+EXTERNAL-FORMAT. The boundaries START and END refer to character
positions in the string, not to octets in the resulting binary
representation. The permissible external format specifiers are
determined by the underlying implementation."
@@ -716,16 +716,16 @@ determined by the underlying implementation."
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +buffer-size+ (* 128 1024)
- "Size of internal buffer to use for `md5sum-stream' and `md5sum-file'
+ "Size of internal buffer to use for MD5SUM-STREAM and MD5SUM-FILE
operations. This should be a multiple of 64, the MD5 block size."))
(deftype buffer-index () `(integer 0 ,+buffer-size+))
(defun md5sum-stream (stream)
- "Calculate an MD5 message-digest of the contents of `stream'. Its
+ "Calculate an MD5 message-digest of the contents of STREAM. Its
element-type has to be (unsigned-byte 8). Use on character streams is
DEPRECATED, as this will not work correctly on implementations with
-`char-code-limit' > 256 and ignores character coding issues."
+CHAR-CODE-LIMIT > 256 and ignores character coding issues."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
(locally
(declare (optimize (safety 1) (debug 0)))
@@ -755,7 +755,7 @@ DEPRECATED, as this will not work correctly on implementations with
(stream-element-type stream) stream))))))
(defun md5sum-file (pathname)
- "Calculate the MD5 message-digest of the file specified by `pathname'."
+ "Calculate the MD5 message-digest of the file specified by PATHNAME."
(declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
(md5sum-stream stream)))
diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 0e1570164..06918ee1e 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -322,7 +322,8 @@
(arg alien-pointer-to-anything-or-nil))
(define-protocol-class flock alien-flock ()
((type :initarg :type :accessor flock-type
- :documentation "Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
+ :documentation "Type of lock; `\\\\F_RDLCK`, `\\\\F_WRLCK`,
+`\\\\F_UNLCK`.")
(whence :initarg :whence :accessor flock-whence
:documentation "Flag for starting offset.")
(start :initarg :start :accessor flock-start
@@ -334,7 +335,8 @@
;; so we initialize it to 0.
(pid :initform 0 :reader flock-pid
:documentation
- "Process ID of the process holding the lock; returned with F_GETLK."))
+ "Process ID of the process holding the lock;
+ returned with `\\\\F_GETLK`."))
(:documentation "Class representing locks used in fcntl(2)."))
(define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
(if argp
diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp
index 0bcd20eeb..df899e9bd 100644
--- a/doc/manual/docstrings.lisp
+++ b/doc/manual/docstrings.lisp
@@ -6,12 +6,84 @@
;;;; public domain and is provided with absolutely no warranty. See
;;;; the COPYING file for more information.
;;;;
-;;;; Written by Rudi Schlatte <ru...@co...>, mangled
-;;;; by Nikodemus Siivola.
+;;;; Written by Rudi Schlatte <ru...@co...>, mangled by
+;;;; Nikodemus Siivola. Brought closer to Markdown by Gabor Melis.
+
+;;;; This code can convert a strict subset of Markdown to Texinfo.
+;;;; Supported:
+;;;;
+;;;; - Inline code: `set this with monospace`
+;;;;
+;;;; - Indented code blocks are indented with 4 extra spaces after a
+;;;; blank line:
+;;;;
+;;;; Like this:
+;;;;
+;;;; void main();
+;;;;
+;;;; - Fenced code blocks are indented at the normal level after a
+;;;; blank line:
+;;;;
+;;;; ```
+;;;; void main();
+;;;; ```
+;;;;
+;;;; Use fenced code blocks only when you have consecutive code
+;;;; blocks, which would be collapsed into a single code block
+;;;; when indented.
+;;;;
+;;;; - Itemized lists (like this one). List items can span multiple
+;;;; lines.
+;;;;
+;;;; - Nested lists are indented 4 spaces. A blank line required
+;;;; before the first one.
+;;;;
+;;;; Codification and Downcasing
+;;;; ---------------------------
+;;;
+;;;; Summary: Some text in docstrings is automatically codified (e.g.
+;;;; FOO -> `FOO`) and most code is downcased.
+;;;;
+;;;; We approximate the semantics of PAX::@CODIFICATION with the
+;;;; settings PAX:*DOCUMENT-UPPERCASE-IS-CODE* and
+;;;; PAX:*DOCUMENT-DOWNCASE-UPPERCASE-CODE* both true.
+;;;;
+;;;; - Fully-qualified all-uppercase string representatation of
+;;;; symbols are codified (SB-EXT:CAS, :XYZ).
+;;;;
+;;;; - All-uppercase SYMBOL-NAMEs accessible in the package that was
+;;;; in effect when the definition with the docstring was compiled
+;;;; are codified.
+;;;;
+;;;; - When at least 3 uppercase characters are followed by a
+;;;; lowercase character (e.g. SETFable), then the uppercase prefix
+;;;; is codified with the previous rules.
+;;;;
+;;;; Detecting the package is a heuristic endeavour. See
+;;;; GUESS-PACKAGE-FROM-ARGLIST and PACKAGE-OVERRIDE.
+;;;;
+;;;; When there is no corresponding symbol, the Markdown backtick
+;;;; syntax (`PRINT`) can be used to codify.
+;;;;
+;;;; When there are no lowercase nor #\" characters in inline code (as
+;;;; opposed to code blocks), be it auto-codified or explicitly
+;;;; backticked, it's downcased.
+;;;;
+;;;; When there is a corresponding symbol, but codification or
+;;;; downcasing should not happen, use backslash escapes.
+;;;;
+;;;; Escaping (following PAX::@OVERVIEW-OF-ESCAPING):
+;;;;
+;;;; PRINT -> @code{print} (Should be autolinked, unimplemented)
+;;;; \PRINT -> @code{print} (Prevent autolinking)
+;;;; \\PRINT -> PRINT (Prevent autolinking and codification)
+;;;; `PRINT` -> @code{print} (Should be autolinked, unimplemented)
+;;;; `\PRINT` -> @code{print} (Prevent autolinking)
+;;;; `\\PRINT` -> @code{PRINT} (Prevent autolinking and downcasing)
+;;;;
+;;;; Note that in docstrings, the backslashes need to be doubled.
;;;; TODO
-;;;; * Verbatim text
-;;;; * Quotations
;;;; * Method documentation untested
;;;; * Method sorting, somehow
;;;; * Index for macros & constants?
@@ -20,20 +92,6 @@
;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
;;;; easily generated)
-;;;; FIXME: The description below is no longer complete. This
-;;;; should possibly be turned into a contrib with proper documentation.
-
-;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
-;;;;
-;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
-;;;; the argument list of the defun / defmacro.
-;;;;
-;;;; Lines starting with * or - that are followed by intented lines
-;;;; are marked up with @itemize.
-;;;;
-;;;; Lines containing only a SYMBOL that are followed by indented
-;;;; lines are marked up as @table @code, with the SYMBOL as the item.
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-introspect))
@@ -450,24 +508,43 @@ with #\@. Optionally downcase the result."
(defun empty-p (line-number lines)
(and (< -1 line-number (length lines))
(not (indentation (svref lines line-number)))))
+
-;;; line markups
+;;;; Codification
-(defvar *not-code* '("ANSI" "CLHS" "UNIX" "SBCL" "BSD" "C" "A" "I"))
-(defvar *code*
- '(":WINDOW" ":HIDE" ":SHOW-NORMAL" ":SHOW-MAXIMIZED" ":SHOW-MINIMIZED"
- ":SHOW-NO-ACTIVATE" ":SHOW-MIN-NO-ACTIVE" ":SHOW-NA"
- ":SB-CORE-COMPRESSION" ":CONSOLE" ":GUI" ":APPLICATION-TYPE"
- "NODE*" "GUESSED-PC" "SYS" "SPECIALIZER-KIND" "SPECIFIC-SYNTAX"
- "QUALIFIERS*" "SPECIALIZERS*" "OUTER-NAME" "EXTERNAL-NAME"
- "GET-FOO" "RELEASE-FOO" "C-CALL" "BODY-FORM" "ALLOCATION"
- "INITIAL-VALUE" "ARG-NAME" "ARG-TYPE" "FORM" "WHILE"
- "TO-SEC" "TO-USEC" "STOP-SEC" "STOP-USEC" "DEADLINEP"
- "FUNDAMENTAL-CHARACTER-STREAM" "SOURCE-PLIST" "PEEK-TYPE"
- "THREAD-NAME" "THREAD-OBJECT" "NEW-VALUE" "PROCESS"
- "COLON" "ATSIGN" "GATE" "MAILBOX" "QUEUE" "X" "Y"
- "INDEX" "SEQUENCE" "ITERATOR" "STATEMENT"
- "MACROEXPAND-ALL"))
+;;; These wouldn't be necessary if we implemented PAX::@CODIFIABLE and
+;;; PAX::@INTERESTING properly.
+(defvar *not-code* '("A" "I"))
+
+;;; GUESS-PACKAGE-FROM-ARGLIST doesn't always guess right.
+(defvar *docstring-packages*
+ '(("SB-CONCURRENCY:GATEP" "SB-CONCURRENCY")
+ ("SB-CONCURRENCY:MAILBOXP" "SB-CONCURRENCY")
+ ("SB-CONCURRENCY:QUEUEP" "SB-CONCURRENCY")
+ ("SB-EXT:INTERACTIVE-EVAL" "SB-IMPL")
+ ("SB-EXT:PROCESS-P" "SB-IMPL")
+ ("SB-EXT:PROCESS-STATUS-HOOK" "SB-IMPL")
+ ("(SETF SB-EXT:READTABLE-NORMALIZATION)" "SB-IMPL")))
+
+(defun package-override (name)
+ (let ((fully-qualified-name (let ((*package* (find-package :cl)))
+ (prin1-to-string name))))
+ (second (find fully-qualified-name *docstring-packages*
+ :key #'first :test #'equal))))
+
+#+nil
+(let ((*texinfo-output* *standard-output*)
+ (*documentation-package* *package*))
+ (write-texinfo-string "`XXXXX`")
+ (write-texinfo-string "`\\XXXXX`")
+ (write-texinfo-string "`\\\\XXXXX`")
+ (write-texinfo-string "`Not allcaps`")
+ (write-texinfo-string "- a
+ c
+
+x
+")
+ (write-texinfo-string "`(X Y*)"))
(defun interesting-name-p (name)
(let ((name (if (and (plusp (length name))
@@ -500,8 +577,7 @@ with #\@. Optionally downcase the result."
(flet ((grab (start end)
(let ((name (subseq line start end)))
(when (and (not (member name *not-code* :test #'equal))
- (or (member name *code* :test #'equal)
- (interesting-name-p name)))
+ (interesting-name-p name))
(push (list start end) result))))
(got-symbol-p (start)
(let ((end (when (< start (length line))
@@ -528,15 +604,15 @@ with #\@. Optionally downcase the result."
(and (char= (char line i) #\:)
(or (= (1+ i) (length line))
(whitespacep (char line (1+ i)))))))
- ;; symbol end; remember it if it's not "A" or "I"
- (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
- (grab begin i))
+ ;; symbol end
+ (grab begin i)
(setf begin nil
maybe-begin t))
((and begin (not (find (char line i) *symbol-characters*)))
;; Not a symbol: abort
(setf begin nil))
- ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
+ ((and maybe-begin (not begin)
+ (find (char line i) *symbol-characters*))
;; potential symbol begin at this position
(setf begin i
maybe-begin nil))
@@ -568,192 +644,247 @@ variables if the symbol in question is contained in symbols
(let ((symbol-name (apply #'subseq line symbol/index)))
(format result (if (member symbol-name *texinfo-variables*
:test #'string=)
+ ;; FIXME: We don't use @var{} elsewhere.
+ ;; Should we here?
"@var{~A}"
"@code{~A}")
(string-downcase symbol-name)))
(setf last (second symbol/index)))
(write-string (subseq line last) result))))
+
-;;; lisp sections
+;;;; SBCL-flavoured Markdown to Texinfo Parser
+;;;; Replaces heuristic codification with strict Markdown rules.
-(defun lisp-section-p (line line-number lines)
- "Returns T if the given LINE looks like start of lisp code --
-i.e. if it starts with whitespace followed by a paren or
-semicolon, and the previous line is empty"
- (let ((offset (indentation line)))
- (and offset
- (plusp offset)
- (find (find-if-not #'whitespacep line) "(;")
- (empty-p (1- line-number) lines))))
+(defun blankp (line)
+ "Returns T if the line is empty or contains only whitespace."
+ (null (indentation line)))
-(defun collect-lisp-section (lines line-number)
- (flet ((maybe-line (index)
- (and (< index (length lines)) (svref lines index))))
- (let ((lisp (loop for index = line-number then (1+ index)
- for line = (maybe-line index)
- while (or (indentation line)
- ;; Allow empty lines in middle of lisp sections.
- (let ((next (1+ index)))
- (lisp-section-p (maybe-line next) next lines)))
- collect line)))
- (values (length lisp) `("@lisp" ,@lisp "@end lisp")))))
+(defun process-inline-markdown (string)
+ "Translates escapes (\*) and backticks (`FOO` -> @code{FOO}), while
+delegating normal text to the existing TEXINFO-LINE heuristic
+codifier."
+ (let ((len (length string))
+ (i 0)
+ (raw-buffer (make-string-output-stream))
+ (out (make-string-output-stream)))
+ (flet ((flush-raw ()
+ (let ((raw (get-output-stream-string raw-buffer)))
+ (when (plusp (length raw))
+ (write-string (texinfo-line raw) out)))))
+ (loop while (< i len)
+ for char = (char string i)
+ do (cond
+ ;; Escapes: \FOO
+ ((char= char #\\)
+ (flush-raw)
+ (incf i) ; Skip the backslash
+ (when (< i len)
+ (write-char (char string i) out)
+ (incf i)
+ ;; Protect the rest of the contiguous word from TEXINFO-LINE
+ (loop
+ while (and (< i len)
+ (not (member (char string i)
+ '(#\Space #\Tab #\Newline
+ #\( #\) #\[ #\] #\{ #\}
+ #\' #\" #\, #\. #\; #\? #\!))))
+ do (write-char (char string i) out)
+ (incf i))
+ (decf i)))
+ ;; Backticks: `CODE` with PAX downcasing and escape rules
+ ((char= char #\`)
+ (flush-raw)
+ (incf i)
+ (let ((code-buffer (make-string-output-stream)))
+ (loop while (and (< i len) (char/= (char string i) #\`))
+ do (write-char (char string i) code-buffer)
+ (incf i))
+ (let* ((code-str (get-output-stream-string code-buffer))
+ (slash-count (loop for c across code-str
+ while (char= c #\\)
+ count t))
+ ;; Consume up to 2 leading backslashes as PAX escapes
+ (actual-code (subseq code-str (min slash-count 2))))
+ (write-string "@code{" out)
+ (if (< slash-count 2)
+ ;; 0 or 1 backslash: Downcase if there are
+ ;; no lowercase letters (1 backslash turns
+ ;; off autolinking, which is naturally
+ ;; handled by bypassing TEXINFO-LINE).
+ (if (and (not (find-if #'lower-case-p actual-code))
+ (not (find #\" actual-code)))
+ (write-string (string-downcase actual-code) out)
+ (write-string actual-code out))
+ ;; 2 backslashes turn off autolinking AND downcasing.
+ (write-string actual-code out))
+ (write-string "}" out))))
+ (t
+ (write-char char raw-buffer)))
+ (incf i))
+ (flush-raw)
+ (get-output-stream-string out))))
-;;; itemized sections
+(defun collect-fenced-code (lines starting-line base-indent)
+ "Collects lines enclosed in ``` fences.
+Returns (VALUES CONSUMED-COUNT TEXINFO-LINES)."
+ (let* ((first-line (svref lines starting-line))
+ (trimmed (string-left-trim " " first-line)))
+ (when (and (>= (length trimmed) 3)
+ (string= (subseq trimmed 0 3) "```"))
+ (let ((lang (string-trim " " (subseq trimmed 3)))
+ (consumed 1)
+ (result nil))
+ (loop for index from (1+ starting-line) below (length lines)
+ for line = (svref lines index)
+ for line-trimmed = (string-left-trim " " line)
+ do (incf consumed)
+ if (and (>= (length line-trimmed) 3)
+ (string= (subseq line-trimmed 0 3) "```"))
+ do (loop-finish) ; Closing fence found
+ else
+ ;; Strip up to the base indentation of the environment
+ do (push (if (and (indentation line) (>= (indentation line) base-indent))
+ (subseq line base-indent)
+ line)
+ result))
+ (let ((env (if (string-equal lang "lisp") "lisp" "example")))
+ (values consumed
+ `(,(format nil "@~A" env)
+ ,@(nreverse result)
+ ,(format nil "@end ~A" env))))))))
+
+(defun collect-indented-code (lines starting-line base-indent)
+ "Collects lines using the classic 4-space indentation rule."
+ ;; An indented code block must be by a blank line (or be the first line).
+ (unless (and (> starting-line 0)
+ (not (blankp (svref lines (1- starting-line)))))
+ (let ((indent (indentation (svref lines starting-line))))
+ (when (and indent (>= indent (+ base-indent 4)))
+ (let ((consumed 0)
+ (result nil))
+ (loop for index from starting-line below (length lines)
+ for line = (svref lines index)
+ for line-indent = (indentation line)
+ do (cond
+ ((blankp line)
+ ;; Blank lines are allowed inside indented code blocks
+ (push "" result)
+ (incf consumed))
+ ((>= line-indent (+ base-indent 4))
+ (push (subseq line (+ base-indent 4)) result)
+ (incf consumed))
+ (t
+ (loop-finish)))) ; Indentation dropped, code block ends
+ ;; Trim trailing empty lines
+ (loop while (and result (string= (car result) ""))
+ do (pop result) (decf consumed))
+ (if result
+ (values consumed `("@example" ,@(nreverse result) "@end example"))
+ nil))))))
(defun maybe-itemize-offset (line)
- "Return NIL or the indentation offset if LINE looks like it starts
-an item in an itemization."
- (let* ((offset (indentation line))
- (char (when offset (char line offset))))
- (and offset
- (member char *itemize-start-characters* :test #'char=)
- (char= #\Space (find-if-not (lambda (c) (char= c char))
- line :start offset))
- offset)))
+ "Returns the indent if the line starts with a Markdown list marker (- or *)."
+ (let ((indent (indentation line)))
+ (when indent
+ (let ((trimmed (string-left-trim " " line)))
+ (when (and (>= (length trimmed) 2)
+ (member (char trimmed 0) '(#\- #\*))
+ (char= (char trimmed 1) #\Space))
+ indent)))))
-(defun collect-maybe-itemized-section (lines starting-line)
- ;; Return index of next line to be processed outside
- (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
- (result nil)
- (lines-consumed 0))
- (loop for line-number from starting-line below (length lines)
- for line = (svref lines line-number)
- for indentation = (indentation line)
- for offset = (maybe-itemize-offset line)
- do (cond
- ((not indentation)
- ;; empty line -- inserts paragraph.
- (push "" result)
- (incf lines-consumed))
- ((and offset (> indentation this-offset))
- ;; nested itemization -- handle recursively
- ;; FIXME: tables in itemizations go wrong
- (multiple-value-bind (sub-lines-consumed sub-itemization)
- (collect-maybe-itemized-section lines line-number)
- (when sub-lines-consumed
- (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
- (incf lines-consumed sub-lines-consumed)
- (setf result (append (reverse sub-itemization) result)))))
- ((and offset (= indentation this-offset))
- ;; start of new item
- (push (format nil "@item ~A"
- (texinfo-line (subseq line (1+ offset))))
- result)
- (incf lines-consumed))
- ((and (not offset) (> indentation this-offset))
- ;; continued item from previous line
- (push (texinfo-line line) result)
- (incf lines-consumed))
- (t
- ;; end of itemization
- (loop-finish))))
- ;; a single-line itemization isn't.
- (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
- (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
- nil)))
-
-;;; table sections
-
-(defun tabulation-body-p (offset line-number lines)
- (when (< line-number (length lines))
- (let ((offset2 (indentation (svref lines line-number))))
- (and offset2 (< offset offset2)))))
-
-(defun tabulation-p (offset line-number lines direction)
- (let ((step (ecase direction
- (:backwards (1- line-number))
- (:forwards (1+ line-number)))))
- (when (and (plusp line-number) (< line-number (length lines)))
- (and (eql offset (indentation (svref lines line-number)))
- (or (when (eq direction :backwards)
- (empty-p step lines))
- (tabulation-p offset step lines direction)
- (tabulation-body-p offset step lines))))))
-
-(defun maybe-table-offset (line-number lines)
- "Return NIL or the indentation offset if LINE looks like it starts
-an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
-empty line, another tabulation label, or a tabulation body, (3) and
-followed another tabulation label or a tabulation body."
- (let* ((line (svref lines line-number))
- (offset (indentation line))
- (prev (1- line-number))
- (next (1+ line-number)))
- (when (and offset (plusp offset))
- (and (or (empty-p prev lines)
- (tabulation-body-p offset prev lines)
- (tabulation-p offset prev lines :backwards))
- (or (tabulation-body-p offset next lines)
- (tabulation-p offset next lines :forwards))
- offset))))
-
-;;; FIXME: This and itemization are very similar: could they share
-;;; some code, mayhap?
-
-(defun collect-maybe-table-section (lines starting-line)
- ;; Return index of next line to be processed outside
- (let ((this-offset (maybe-table-offset starting-line lines))
- (result nil)
- (lines-consumed 0))
- (loop for line-number from starting-line below (length lines)
- for line = (svref lines line-number)
- for indentation = (indentation line)
- for offset = (maybe-table-offset line-number lines)
- do (cond
- ((not indentation)
- ;; empty line -- inserts paragraph.
- (push "" result)
- (incf lines-consumed))
- ((and offset (= indentation this-offset))
- ;; start of new item, or continuation of previous item
- (if (and result (search "@item" (car result) :test #'char=))
- (push (format nil "@itemx ~A" (texinfo-line line))
+(defun collect-markdown-itemize (lines starting-line base-indent)
+ "Collects a list, strictly enforcing the 4-space rule for list bodies."
+ (let ((this-offset (maybe-itemize-offset (svref lines starting-line))))
+ (when (and this-offset (= this-offset base-indent))
+ (let ((result nil)
+ (lines-consumed 0)
+ (child-base (+ base-indent 4)))
+ (loop for line-number = starting-line then (+ starting-line
+ lines-consumed)
+ while (< line-number (length lines))
+ for line = (svref lines line-number)
+ for indent = (indentation line)
+ for offset = (maybe-itemize-offset line)
+ do (cond
+ ((blankp line)
+ ;; Blank lines inside lists are buffered
+ (push "" result)
+ (incf lines-consumed))
+ ;; New Item in the same list
+ ((and offset (= offset base-indent))
+ (push (format nil "@item ~A"
+ (process-inline-markdown
+ (subseq line (+ offset 2))))
result)
- (progn
- (push "" result)
- (push (format nil "@item ~A" (texinfo-line line))
- result)))
- (incf lines-consumed))
- ((> indentation this-offset)
- ;; continued item from previous line
- (push (texinfo-line line) result)
- (incf lines-consumed))
- (t
- ;; end of itemization
- (loop-finish))))
- ;; a single-line table isn't.
- (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
- (values lines-consumed
- `("" "@table @emph" ,@(reverse result) "@end table" ""))
- nil)))
+ (incf lines-consumed))
+ ;; Indented block/text inside the list item (>= 4 spaces)
+ ((and indent (>= indent child-base))
+ (multiple-value-bind (sub-consumed sub-result)
+ (parse-markdown-blocks lines line-number child-base)
+ (if sub-consumed
+ (progn
+ (setf result (append (reverse sub-result) result))
+ (incf lines-consumed sub-consumed))
+ ;; Fallback: normal text continuing the item body
+ (progn
+ (push (process-inline-markdown
+ (subseq line child-base)) result)
+ (incf lines-consumed)))))
+ ;; Normal text continuing the item body (indent >
+ ;; base-indent, but < child-base)
+ ((and indent (> indent base-indent))
+ (push (process-inline-markdown line) result)
+ (incf lines-consumed))
+ ;; If we get here, the line is NOT a new bullet,
+ ;; and it less than 4 spaces of relative
+ ;; indentation, so the list is over.
+ (t
+ (loop-finish))))
+ ;; Trim trailing empty lines so they return to the outer scope.
+ (loop while (and result (string= (car result) ""))
+ do (pop result) (decf lines-consumed))
-;;; section markup
+ (values lines-consumed `("@itemize" ,@(reverse result)
+ "@end itemize"))))))
-(defmacro with-maybe-section (index &rest forms)
+(defun parse-markdown-blocks (lines index base-indent)
+ "Parse the line at INDEX as a Markdown block.
+Return (VALUES CONSUMED RESULT)."
+ (let ((line (svref lines index)))
+ (multiple-value-bind (n-lines-consumed result)
+ (collect-fenced-code lines index base-indent)
+ (cond
+ (n-lines-consumed
+ (values n-lines-consumed result))
+ ((maybe-itemize-offset line)
+ (collect-markdown-itemize lines index (maybe-itemize-offset line)))
+ ((and (indentation line) (>= (indentation line) (+ base-indent 4)))
+ (collect-indented-code lines index base-indent))
+ (t nil)))))
+
+(defmacro with-markdown-section (index &rest forms)
`(multiple-value-bind (count collected) (progn ,@forms)
- (when count
- (dolist (line collected)
- (write-line line *texinfo-output*))
- (incf ,index (1- count)))))
+ (when count
+ (dolist (line collected)
+ (write-line line *texinfo-output*))
+ (incf ,index count)
+ t)))
(defun write-texinfo-string (string &optional lambda-list)
- "Try to guess as much formatting for a raw docstring as possible."
(let ((*texinfo-variables* (flatten lambda-list))
- (lines (string-lines (escape-for-texinfo string nil))))
- (loop for line-number from 0 below (length lines)
- for line = (svref lines line-number)
- do (cond
- ((with-maybe-section line-number
- (and (lisp-section-p line line-number lines)
- (collect-lisp-section lines line-number))))
- ((with-maybe-section line-number
- (and (maybe-itemize-offset line)
- (collect-maybe-itemized-section lines line-number))))
- ((with-maybe-section line-number
- (and (maybe-table-offset line-number lines)
- (collect-maybe-table-section lines line-number))))
- (t
- (write-line (texinfo-line line) *texinfo-output*))))))
+ ;; Note: The heuristic upcaser (e.g., FOO to @code{foo}) can either run on 'string'
+ ;; before escape-for-texinfo, or be integrated into process-inline-markdown.
+ (lines (string-lines (escape-for-texinfo string nil)))
+ (line-number 0))
+ (loop while (< line-number (length lines))
+ for line = (svref lines line-number)
+ do (unless (with-markdown-section line-number
+ (parse-markdown-blocks lines line-number 0))
+ ;; If it wasn't a block, process it as a normal inline string
+ (write-line (process-inline-markdown line) *texinfo-output*)
+ (incf line-number)))))
+
;;;; texinfo formatting tools
@@ -850,7 +981,7 @@ followed another tabulation label or a tabulation body."
(format *texinfo-output* "@end itemize~%~%"))))))
(defun texinfo-body (doc)
- (write-texinfo-string (get-string doc)))
+ (write-texinfo-string (sanitize-docstring (get-string doc))))
(defun texinfo-end (doc)
(write-line (case (get-kind doc)
@@ -862,7 +993,8 @@ followed another tabulation label or a tabulation body."
(defun write-texinfo (doc)
"Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
(let ((*documentation-package*
- (or (guess-package-from-arglist (lambda-list doc))
+ (or (package-override (get-name doc))
+ (guess-package-from-arglist (lambda-list doc))
(let ((p (get-package doc)))
(cond ((eq p (find-package :cl))
;; Most of the implementation of CL is done under
@@ -883,6 +1015,51 @@ followed another tabulation label or a tabulation body."
;;;; Utilities lifted from MGL-PAX
+(defun sanitize-docstring (docstring)
+ (let ((indentation (docstring-indentation docstring)))
+ (strip-docstring-indent docstring indentation t)))
+
+;;; Return the minimum number of leading spaces in non-blank lines
+;;; after the first.
+(defun docstring-indentation (docstring &key (first-line-special-p t))
+ (let ((n-min-indentation nil))
+ (with-input-from-string (s docstring)
+ (loop for i upfrom 0
+ for line = (read-line s nil nil)
+ while line
+ do (when (and (or (not first-line-special-p) (plusp i))
+ (not (blankp line)))
+ (when (or (null n-min-indentation)
+ (< (n-leading-spaces line) n-min-indentation))
+ (setq n-min-indentation (n-leading-spaces line))))))
+ (or n-min-indentation 0)))
+
+(defun n-leading-spaces (line)
+ (let ((n 0))
+ (loop for i below (length line)
+ while (char= (aref line i) #\Space)
+ do (incf n))
+ n))
+
+(defun subseq* (seq start)
+ (subseq seq (min (length seq) start)))
+
+(defun strip-docstring-indent (docstring indentation first-line-special-p)
+ (with-output-to-string (out)
+ (with-input-from-string (s docstring)
+ (loop for i upfrom 0
+ do (multiple-value-bind (line missing-newline-p)
+ (read-line s nil nil)
+ (unless line
+ (return))
+ (write-string (if (and first-line-special-p
+ (zerop i))
+ line
+ (subseq* line indentation))
+ out)
+ (unless missing-newline-p
+ (terpri out)))))))
+
;;; Unexported argument names are highly informative about *PACKAGE*
;;; at read time. No one ever uses fully-qualified internal symbols
;;; from another package for arguments, right?
diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo
index 2ba749559..621c4fa39 100644
--- a/doc/manual/threading.texinfo
+++ b/doc/manual/threading.texinfo
@@ -126,6 +126,7 @@ named (CAS place), allowing users to add CAS support to new
places.
@include macro-sb-ext-cas.texinfo
+@include fun-sb-ext-get-cas-expansion.texinfo
@node Mutex Support
@comment node-name, next, previous, up
diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp
index a91eecac8..1c04c7110 100644
--- a/src/code/alien-callback.lisp
+++ b/src/code/alien-callback.lisp
@@ -274,15 +274,15 @@ Create new alien callable (old alien callable gets freed)."))
(defmacro define-alien-callable (name result-type typed-lambda-list
&body body
&environment env)
- "(define-alien-callable NAME RESULT-TYPE {(ARG-NAME ARG-TYPE)}*
- {doc-string} {decls}* {FORM}*)
-
-Define an alien function which can be called by alien code. The alien
+ "Define an alien function which can be called by alien code. The alien
function returned by (alien-callable-function NAME) expects alien
-arguments of the specified ARG-TYPEs and returns an alien of type
-RESULT-TYPE.
+arguments of the specified `ARG-TYPE`s and returns an alien of type
+`RESULT-TYPE`.
-If (alien-callable-function NAME) already exists, its value is not
+TYPED-LAMBDA-LIST is a list of `(ARG-NAME ARG-TYPE)` elements, and
+BODY is `{DOC-STRING} {DECL}* {FORM}*`.
+
+If (ALIEN-CALLABLE-FUNCTION NAME) already exists, its value is not
changed (though it is arranged that an updated version of the Lisp
callable function will be called, provided that the new type and the
existing type are compatible). This feature allows for incremental
@@ -301,12 +301,12 @@ redefinition of callable functions."
(defmacro with-alien-callable (definitions
&body body
&environment env)
- "Establish some local alien functions.
- Each element of DEFINITIONS is of the form:
- NAME RESULT-TYPE {(ARG-NAME ARG-TYPE)}*
- {doc-string} {decls}* {FORM}*
+ "Establish some local alien functions.
+ Each element of DEFINITIONS is of the form:
- The resulting alien callable value has dynamic extent."
+ NAME RESULT-TYPE {(ARG-NAME ARG-TYPE)}* {DOC-STRING} {DECL}* {FORM}*
+
+ The resulting alien callable value has dynamic extent."
(collect ((bindings)
(declarations)
(cleanup))
diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 729364ec5..6ed8b445a 100644
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -397,13 +397,13 @@ defaults to 0 when ABORT is false, and 1 when it is true.
When ABORT is false (the default), current thread is first unwound,
*EXIT-HOOKS* are run, other threads are terminated, and standard
-output streams are flushed before SBCL calls exit(3) -- at which point
-atexit(3) functions will run. If multiple threads call EXIT with ABORT
+output streams are flushed before SBCL calls `exit`(3) -- at which point
+`atexit`(3) functions will run. If multiple threads call EXIT with ABORT
being false, the first one to call it will complete the protocol.
-When ABORT is true, SBCL exits immediately by calling _exit(2) without
-unwinding stack, or calling exit hooks. Note that _exit(2) does not
-call atexit(3) functions unlike exit(3).
+When ABORT is true, SBCL exits immediately by calling `_exit`(2)
+without unwinding stack, or calling exit hooks. Note that `_exit`(2)
+does not call `atexit`(3) functions unlike `exit`(3).
Recursive calls to EXIT cause EXIT to behave as if ABORT was true.
diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp
index 87655278c..3abac3d32 100644
--- a/src/code/deadline.lisp
+++ b/src/code/deadline.lisp
@@ -205,13 +205,14 @@ If ABS-SEC and ABS-USEC are in the past, 0 0 is returned."
decode-timeout))
(defun decode-timeout (seconds)
"Decodes a relative timeout in SECONDS into five values, taking any
-global deadlines into account: TO-SEC, TO-USEC, STOP-SEC, STOP-USEC,
-DEADLINEP.
+global deadlines into account: `TO-SEC`, `TO-USEC`, `STOP-SEC`,
+`STOP-USEC`, `DEADLINEP`.
-TO-SEC and TO-USEC indicate the relative timeout in seconds and microseconds.
-STOP-SEC and STOP-USEC indicate the absolute timeout in seconds and
-microseconds. DEADLINEP is true if the returned values reflect a global
-deadline instead of the local timeout indicated by SECONDS.
+`TO-SEC` and `TO-USEC` indicate the relative timeout in seconds and
+microseconds. `STOP-SEC` and `STOP-USEC` indicate the absolute timeout
+in seconds and microseconds. `DEADLINEP` is true if the returned
+values reflect a global deadline instead of the local timeout
+indicated by SECONDS.
If SECONDS is null and there is no global timeout all returned values will be
null. If a global deadline has already passed when DECODE-TIMEOUT is called,
diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index ee67f1f14..dde0627c0 100644
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -447,21 +447,25 @@ definition is in variance with the current state of the package.
The value should be of the form:
- (:WARN [T | packages-names] :ERROR [T | package-names])
+ (:warn [t | packages-names] :error [t | package-names])
-specifying which packages get which behaviour -- with T signifying the default unless
-otherwise specified. If default is not specified, :WARN is used.
+specifying which packages get which behaviour -- with T signifying the
+default unless otherwise specified. If default is not specified, :WARN
+is used.
-:WARN keeps as much state as possible and causes SBCL to signal a full warning.
+- :WARN keeps as much state as possible and causes SBCL to signal a
+ full warning.
-:ERROR causes SBCL to signal an error when the variant DEFPACKAGE form is executed,
-with restarts provided for user to specify what action should be taken.
+- :ERROR causes SBCL to signal an error when the variant DEFPACKAGE
+ form is executed, with restarts provided for user to specify what
+ action should be taken.
Example:
- (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t))
+ (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t))
-specifies to signal a warning if SWANK package is in variance, and an error otherwise.")
+specifies to signal a warning if SWANK package is in variance, and an
+error otherwise.")
(defun note-package-variance (&rest args &key package &allow-other-keys)
(let ((pname (package-name package)))
diff --git a/src/code/error.lisp b/src/code/error.lisp
index 17e7b0131..78fcdaab8 100644
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -194,7 +194,7 @@ condition."
;;;; HANDLER-CASE and IGNORE-ERRORS.
(sb-xc:defmacro handler-case (form &rest cases)
- "(HANDLER-CASE form { (type ([var]) body) }* )
+ "(HANDLER-CASE form { (type ([var]) body) }*)
Execute FORM in a context with handlers established for the condition types. A
peculiar property allows type to be :NO-ERROR. If such a clause occurs, and
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 616fab4d8..2ded542d5 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -618,8 +618,8 @@ directory, or if the directory could not be deleted for any reason.
Both
- \(DELETE-DIRECTORY \"/tmp/foo\")
- \(DELETE-DIRECTORY \"/tmp/foo/\")
+ (DELETE-DIRECTORY \"/tmp/foo\")
+ (DELETE-DIRECTORY \"/tmp/foo/\")
delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not
exist or if is a file or a symbolic link."
diff --git a/src/code/final.lisp b/src/code/final.lisp
index dbff310d1..c43836e5f 100644
--- a/src/code/final.lisp
+++ b/src/code/final.lisp
@@ -187,13 +187,13 @@
(defun finalize (object function &key dont-save
&aux (function (%coerce-callable-to-fun function)))
"Arrange for the designated FUNCTION to be called when there
-are no more references to OBJECT, including references in
-FUNCTION itself.
+are no more references to OBJECT, including references in FUNCTION
+itself.
If DONT-SAVE is true, the finalizer will be cancelled when
SAVE-LISP-AND-DIE is called: this is useful for finalizers
-deallocating system memory, which might otherwise be called
-with addresses from the old image.
+deallocating system memory, which might otherwise be called with
+addresses from the old image.
In a multithreaded environment FUNCTION may be called in any
thread. In both single and multithreaded environments FUNCTION
@@ -205,33 +205,41 @@ signalled in whichever thread the FUNCTION was called in.
Examples:
- ;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
- (let* ((handle (get-handle))
- (object (make-object handle)))
- (finalize object (lambda () (release-handle handle)))
- object)
+```
+;;; GOOD, assuming RELEASE-HANDLE is re-entrant.
+(let* ((handle (get-handle))
+ (object (make-object handle)))
+ (finalize object (lambda () (release-handle handle)))
+ object)
+```
- ;;; BAD, finalizer refers to object being finalized, causing
- ;;; it to be retained indefinitely!
- (let* ((handle (get-handle))
- (object (make-object handle)))
- (finalize object
- (lambda ()
- (release-handle (object-handle object)))))
+```
+;;; BAD, finalizer refers to object being finalized, causing
+;;; it to be retained indefinitely!
+(let* ((handle (get-handle))
+ (object (make-object handle)))
+ (finalize object
+ (lambda ()
+ (release-handle (object-handle object)))))
+```
- ;;; BAD, not re-entrant!
- (defvar *rec* nil)
+```
+;;; BAD, not re-entrant!
+(defvar *rec* nil)
- (defun oops ()
- (when *rec*
- (error \"recursive OOPS\"))
- (let ((*rec* t))
- (gc))) ; or just cons enough to cause one
+(defun oops ()
+ (when *rec*
+ (error \"recursive OOPS\"))
+ (let ((*rec* t))
+ (gc))) ; or just cons enough to cause one
+```
- (progn
- (finalize \"oops\" #'oops)
- (oops)) ; GC causes re-entry to #'oops due to the finalizer
- ; -> ERROR, caught, WARNING signalled"
+```
+(progn
+ (finalize \"oops\" #'oops)
+ (oops)) ; GC causes re-entry to #'oops due to the finalizer
+ ; -> ERROR, caught, WARNING signalled
+```"
(declare (sb-c::tlab :system))
(let ((space (heap-allocated-p object)))
;; Rule out immediate, stack, arena, readonly, and static objects.
diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp
index c09c08b5d..a6f3b642b 100644
--- a/src/code/foreign-load.lisp
+++ b/src/code/foreign-load.lisp
@@ -33,17 +33,17 @@
container specified by designated PATHNAME, such as a .so on an ELF platform.
Locating the shared object follows standard rules of the platform, consult the
-manual page for dlopen(3) for details. Typically paths specified by
+manual page for `dlopen`(3) for details. Typically paths specified by
environment variables such as LD_LIBRARY_PATH are searched if the PATHNAME has
no directory, but on some systems (eg. Mac OS X) search may happen even if
-PATHNAME is absolute. (On Windows LoadLibrary is used instead of dlopen(3).)
+PATHNAME is absolute. (On Windows LoadLibrary is used instead of `dlopen`(3).)
On non-Windows platforms calling LOAD-SHARED-OBJECT again with a PATHNAME
EQUAL to the designated pathname of a previous call will replace the old
definitions; if a symbol was previously referenced through the object and
is not present in the reloaded version ...
[truncated message content] |
|
From: melisgl <me...@us...> - 2026-05-30 10:18:16
|
The branch "master" has been updated in SBCL:
via cec8b3965734dea6c08976ee9a9b0fa66f513577 (commit)
from 02bd195c1ab97edbb6b59593c92bb8e05e3e4a5e (commit)
- Log -----------------------------------------------------------------
commit cec8b3965734dea6c08976ee9a9b0fa66f513577
Author: Gabor Melis <me...@re...>
Date: Wed May 27 19:11:27 2026 +0200
doc: improve @code{}ification in the user manual
1. Previously, all uppercase words were downcased and enclosed in
texinfo @code{}, which didn't handle many common cases correctly. With
this change, only words that name interned symbols or packages are
codified:
POSIX -> POSIX (was @code{posix})
UDP -> UDP (was @code{udp})
The symbol name is looked up in the heuristically determined package,
which tries to match the package in the IN-PACKAGE form in effect
where the docstring is in the sources. This means that if M-. works in
Slime, then the documentation generator should be able to figure out
that it's code.
This change revealed several typos in the docstrings where the all
uppercase word did not correspond to the name of an interned
symbol.
2. Lowercase suffixes are now stripped from the word:
STRINGs -> @code{string}s (was STRINGS)
CLASSes -> @code{class}es (was CLASSes)
SETFable -> @code{setf}able (was SETFable)
3. #\' is now a delimiter, so this works:
ARRAY's -> @code{array}'s (was ARRAY's)
4. Trailing #\: characters followed by whitespace are considered
delimiters:
NIL: -> @code{nil}: (was @code{nil:})
5. Fixed the *NOT-SYMBOLS* opt-out mechanism (renamed to *NOT-CODE*)
and added an opt-in (*CODE*).
Overall, the new heuristics work much better with current docstring
style. However, there is no way to get all cases right, so explicit
markup in docstrings will be needed. Fixing that would require even
more of MGL-PAX, so I'm stopping here.
Also, we should probably have the generated documentation (a single
file, in a format suitable for diffing) under version control so that
we can detect documentation typos more easily.
---
contrib/sb-introspect/introspect.lisp | 12 ++--
contrib/sb-posix/strtod.lisp | 4 +-
contrib/sb-sprof/record.lisp | 6 +-
doc/manual/docstrings.lisp | 119 +++++++++++++++++++++++++++++-----
doc/manual/intro.texinfo | 4 +-
src/code/alien-callback.lisp | 3 +-
src/code/array.lisp | 2 +-
src/code/cold-init.lisp | 23 +++----
src/code/deadline.lisp | 6 +-
src/code/defpackage.lisp | 28 ++++----
src/code/reader.lisp | 6 +-
src/code/serve-event.lisp | 10 +--
src/code/target-alieneval.lisp | 4 +-
src/code/target-error.lisp | 16 ++---
src/code/target-thread.lisp | 2 +-
src/code/timer.lisp | 7 +-
src/cold/exports.lisp | 14 ++--
src/compiler/ir1-translators.lisp | 35 +++++-----
src/pcl/gray-streams.lisp | 4 +-
src/pcl/sequence.lisp | 41 ++++++------
20 files changed, 218 insertions(+), 128 deletions(-)
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 3d59acff1..56c3e7fc7 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -94,7 +94,8 @@ include the pathname of the file and the position of the definition."
(defun valid-function-name-p (name)
"See if NAME is a valid function name. In addition to the ANSI
definition of function name, which is symbols plus lists like (SETF
-SYMBOL), SBCL allows (CAS SYMBOL) and various internal constructs."
+SYMBOL), SBCL allows (SB-EXT:CAS SYMBOL) and various internal
+constructs."
(and (sb-int:valid-function-name-p name) t))
;;;; Utilities for code
@@ -290,7 +291,7 @@ returned for definitions that exist, but the source location (e.g.
DEFINITION-SOURCE-PATHNAME) may be missing. TYPE can currently be one
of the following.
-Public definition types:
+- Public definition types:
:CLASS
:COMPILER-MACRO
@@ -311,7 +312,7 @@ Public definition types:
:VARIABLE
:DECLARATION
-Internal definition types:
+- Internal definition types:
:OPTIMIZER
:SOURCE-TRANSFORM
@@ -961,9 +962,8 @@ CLASS-DESIGNATOR, and return them as an alist of generic function
name, DEFINITION-SOURCE pairs.
A method matches the criterion either if it specializes on the same
-class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
-specializers), or if it eql-specializes on an instance of the
-designated class.
+class as CLASS-DESIGNATOR designates, or if it eql-specializes on an
+instance of the designated class.
Experimental."
(let ((class (canonicalize-class-designator class-designator)))
diff --git a/contrib/sb-posix/strtod.lisp b/contrib/sb-posix/strtod.lisp
index 78aba86ca..7a378bbc6 100644
--- a/contrib/sb-posix/strtod.lisp
+++ b/contrib/sb-posix/strtod.lisp
@@ -1,8 +1,8 @@
(in-package "SB-POSIX")
(defun strtod (string)
- "Parse the string INPUT and return a double-precision float,
-and a secondary value, the number of characters consumed."
+ "Parse STRING into a double-precision float.
+As the second value, return the number of characters consumed."
(flet ((strtod/base-string (chars offset)
(declare (simple-base-string chars))
;; On x86, dx arrays are quicker to make than aliens.
diff --git a/contrib/sb-sprof/record.lisp b/contrib/sb-sprof/record.lisp
index 85d952461..8cb597786 100644
--- a/contrib/sb-sprof/record.lisp
+++ b/contrib/sb-sprof/record.lisp
@@ -45,9 +45,9 @@
The signature of FUNCTION must be compatible with (thread trace).
-FUNCTION is called once for each trace where THREAD is the SB-THREAD:TREAD
-instance which was sampled to produce TRACE, and TRACE is an opaque object
-to be passed to MAP-TRACE-PC-LOCS.
+FUNCTION is called once for each trace where THREAD is the
+SB-THREAD:THREAD instance that was sampled to produce TRACE, and TRACE
+is an opaque object to be passed to MAP-TRACE-PC-LOCS.
EXPERIMENTAL: Interface subject to change."
(let ((function (sb-kernel:%coerce-callable-to-fun function))
diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp
index 6e5c4d1c6..0bcd20eeb 100644
--- a/doc/manual/docstrings.lisp
+++ b/doc/manual/docstrings.lisp
@@ -84,8 +84,7 @@ you deserve to lose.")
(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&#'"
"List of characters that make up symbols in a docstring.")
-;;; #\s is included to catch some plurals (e.g. FDEFINITIONs).
-(defparameter *symbol-delimiters* " ,.!?;()s")
+(defparameter *symbol-delimiters* " ,.!?;()'")
(defparameter *ordered-documentation-kinds*
'(package type structure condition class macro))
@@ -103,7 +102,7 @@ you deserve to lose.")
(cons (car list) (flatten (cdr list))))))
(defun whitespacep (char)
- (find char #(#\tab #\space #\page)))
+ (find char #(#\tab #\space #\page #\newline)))
(defun setf-name-p (name)
(or (symbolp name)
@@ -454,15 +453,56 @@ with #\@. Optionally downcase the result."
;;; line markups
-(defvar *not-symbols* '("ANSI" "CLHS" "UNIX"))
+(defvar *not-code* '("ANSI" "CLHS" "UNIX" "SBCL" "BSD" "C" "A" "I"))
+(defvar *code*
+ '(":WINDOW" ":HIDE" ":SHOW-NORMAL" ":SHOW-MAXIMIZED" ":SHOW-MINIMIZED"
+ ":SHOW-NO-ACTIVATE" ":SHOW-MIN-NO-ACTIVE" ":SHOW-NA"
+ ":SB-CORE-COMPRESSION" ":CONSOLE" ":GUI" ":APPLICATION-TYPE"
+ "NODE*" "GUESSED-PC" "SYS" "SPECIALIZER-KIND" "SPECIFIC-SYNTAX"
+ "QUALIFIERS*" "SPECIALIZERS*" "OUTER-NAME" "EXTERNAL-NAME"
+ "GET-FOO" "RELEASE-FOO" "C-CALL" "BODY-FORM" "ALLOCATION"
+ "INITIAL-VALUE" "ARG-NAME" "ARG-TYPE" "FORM" "WHILE"
+ "TO-SEC" "TO-USEC" "STOP-SEC" "STOP-USEC" "DEADLINEP"
+ "FUNDAMENTAL-CHARACTER-STREAM" "SOURCE-PLIST" "PEEK-TYPE"
+ "THREAD-NAME" "THREAD-OBJECT" "NEW-VALUE" "PROCESS"
+ "COLON" "ATSIGN" "GATE" "MAILBOX" "QUEUE" "X" "Y"
+ "INDEX" "SEQUENCE" "ITERATOR" "STATEMENT"
+ "MACROEXPAND-ALL"))
+
+(defun interesting-name-p (name)
+ (let ((name (if (and (plusp (length name))
+ (find (aref name 0) "'`"))
+ (subseq name 1)
+ name)))
+ (or (find-package name)
+ (if (and (plusp (length name))
+ (char= (aref name 0) #\:))
+ (internedp (subseq name 1) :keyword)
+ (let ((pos (position #\: name)))
+ (if pos
+ (let ((package-name (subseq name 0 pos))
+ (symbol-name (subseq name (1+ pos))))
+ (when (and (plusp (length symbol-name))
+ (char= (aref symbol-name 0) #\:))
+ (setq symbol-name (subseq symbol-name 1)))
+ (if (and package-name (find-package package-name))
+ (internedp symbol-name package-name)
+ (internedp symbol-name *documentation-package*)))
+ (internedp name *documentation-package*)))))))
+
+(defun internedp (symbol-name package)
+ (nth-value 1 (find-symbol symbol-name package)))
(defun locate-symbols (line)
"Return a list of index pairs of symbol-like parts of LINE."
;; This would be a good application for a regex ...
(let (result)
(flet ((grab (start end)
- (unless (member (subseq line start end) *not-symbols*)
- (push (list start end) result)))
+ (let ((name (subseq line start end)))
+ (when (and (not (member name *not-code* :test #'equal))
+ (or (member name *code* :test #'equal)
+ (interesting-name-p name)))
+ (push (list start end) result))))
(got-symbol-p (start)
(let ((end (when (< start (length line))
(position #\space line :start start))))
@@ -474,12 +514,20 @@ with #\@. Optionally downcase the result."
(i 0 (1+ i)))
((>= i (length line))
;; symbol at end of line
- (when (and begin (or (> i (1+ begin))
- (not (member (char line begin) '(#\A #\I)))))
+ (when begin
(grab begin i))
(nreverse result))
(cond
- ((and begin (find (char line i) *symbol-delimiters*))
+ ((and begin
+ (or (find (char line i) *symbol-delimiters*)
+ ;; This catches lowercase suffixes. SETFable,
+ ;; PRINTs, CLASSes.
+ (and (<= (+ begin 3) i)
+ (lower-case-p (char line i)))
+ ;; For e.g. "T:"
+ (and (char= (char line i) #\:)
+ (or (= (1+ i) (length line))
+ (whitespacep (char line (1+ i)))))))
;; symbol end; remember it if it's not "A" or "I"
(when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
(grab begin i))
@@ -813,13 +861,52 @@ followed another tabulation label or a tabulation body."
(defun write-texinfo (doc)
"Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
- (texinfo-anchor doc)
- (texinfo-begin doc)
- (texinfo-inferred-body doc)
- (texinfo-body doc)
- (texinfo-end doc)
- ;; FIXME: Children should be sorted one way or another
- (mapc #'write-texinfo (get-children doc)))
+ (let ((*documentation-package*
+ (or (guess-package-from-arglist (lambda-list doc))
+ (let ((p (get-package doc)))
+ (cond ((eq p (find-package :cl))
+ ;; Most of the implementation of CL is done under
+ ;; (IN-PACKAGE :SB-IMPL).
+ (find-package :sb-impl))
+ ((eq p (find-package :sequence))
+ (find-package :sb-impl))
+ (t
+ (get-package doc)))))))
+ (texinfo-anchor doc)
+ (texinfo-begin doc)
+ (texinfo-inferred-body doc)
+ (texinfo-body doc)
+ (texinfo-end doc)
+ ;; FIXME: Children should be sorted one way or another
+ (mapc #'write-texinfo (get-children doc))))
+
+
+;;;; Utilities lifted from MGL-PAX
+
+;;; Unexported argument names are highly informative about *PACKAGE*
+;;; at read time. No one ever uses fully-qualified internal symbols
+;;; from another package for arguments, right?
+(defun guess-package-from-arglist (args)
+ (dolist (arg args)
+ (when (and (symbolp arg)
+ (not (external-symbol-in-any-package-p arg)))
+ (return (symbol-package arg)))
+ (when (and (listp arg)
+ (symbolp (first arg))
+ (not (external-symbol-in-any-package-p (first arg))))
+ (return (symbol-package (first arg))))))
+
+(defun external-symbol-in-any-package-p (symbol)
+ (loop for package in (list-all-packages)
+ thereis (external-symbol-p symbol package)))
+
+(defun external-symbol-p (symbol &optional (package (symbol-package symbol)))
+ (and package
+ (multiple-value-bind (symbol* status)
+ (find-symbol (symbol-name symbol) package)
+ (and (eq status :external)
+ (eq symbol symbol*)))))
+
;;;; main logic
diff --git a/doc/manual/intro.texinfo b/doc/manual/intro.texinfo
index 7fc59c7ec..df985e16a 100644
--- a/doc/manual/intro.texinfo
+++ b/doc/manual/intro.texinfo
@@ -72,8 +72,8 @@ extensions have proper documentation yet.
@item System Definition Tool
@code{asdf} is a flexible and popular protocol-oriented system
-definition tool by Daniel Barlow. @inforef{Top,the asdf manual,asdf}, for
-more information.
+definition tool by Daniel Barlow. @xref{Top, , , asdf} for more
+information.
@item Foreign Function Interface
@code{sb-alien} package allows interfacing with C-code, loading shared
diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp
index 9a9fdf216..a91eecac8 100644
--- a/src/code/alien-callback.lisp
+++ b/src/code/alien-callback.lisp
@@ -301,7 +301,8 @@ redefinition of callable functions."
(defmacro with-alien-callable (definitions
&body body
&environment env)
- "Establish some local alien functions. Each DEFINITION is of the form:
+ "Establish some local alien functions.
+ Each element of DEFINITIONS is of the form:
NAME RESULT-TYPE {(ARG-NAME ARG-TYPE)}*
{doc-string} {decls}* {FORM}*
diff --git a/src/code/array.lisp b/src/code/array.lisp
index cd17e958f..f70d27cb5 100644
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -1297,7 +1297,7 @@ of specialized arrays is supported."
(array-total-size array))
(defun array-displacement (array)
- "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
+ "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-OFFSET
options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
(declare (type array array))
(if (and (array-header-p array) ; if unsimple and
diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 61c5f500f..729364ec5 100644
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -410,18 +410,19 @@ Recursive calls to EXIT cause EXIT to behave as if ABORT was true.
TIMEOUT controls waiting for other threads to terminate when ABORT is
NIL. Once current thread has been unwound and *EXIT-HOOKS* have been
run, spawning new threads is prevented and all other threads are
-terminated by calling TERMINATE-THREAD on them. The system then waits
-for them to finish using JOIN-THREAD, waiting at most a total TIMEOUT
-seconds for all threads to join. Those threads that do not finish
-in time are simply ignored while the exit protocol continues. TIMEOUT
-defaults to *EXIT-TIMEOUT*, which in turn defaults to 60. TIMEOUT NIL
-means to wait indefinitely.
+terminated by calling SB-THREAD:TERMINATE-THREAD on them. The system
+then waits for them to finish using SB-THREAD:JOIN-THREAD, waiting at
+most a total TIMEOUT seconds for all threads to join. Those threads
+that do not finish in time are simply ignored while the exit protocol
+continues. TIMEOUT defaults to *EXIT-TIMEOUT*, which in turn defaults
+to 60. TIMEOUT NIL means to wait indefinitely.
-Note that TIMEOUT applies only to JOIN-THREAD, not *EXIT-HOOKS*. Since
-TERMINATE-THREAD is asynchronous, getting multithreaded application
-termination with complex cleanups right using it can be tricky. To
-perform an orderly synchronous shutdown use an exit hook instead of
-relying on implicit thread termination.
+Note that TIMEOUT applies only to SB-THREAD:JOIN-THREAD, not
+*EXIT-HOOKS*. Since SB-THREAD:TERMINATE-THREAD is asynchronous,
+getting multithreaded application termination with complex cleanups
+right using it can be tricky. To perform an orderly synchronous
+shutdown use an exit hook instead of relying on implicit thread
+termination.
Consequences are unspecified if serious conditions occur during EXIT
excepting errors from *EXIT-HOOKS*, which cause warnings and stop
diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp
index d0c4138cf..87655278c 100644
--- a/src/code/deadline.lisp
+++ b/src/code/deadline.lisp
@@ -72,9 +72,9 @@
respecting deadlines occurs either after the deadline has passed, or
would take longer than the time left to complete.
-Currently only SLEEP, blocking IO operations, GET-MUTEX, and
-CONDITION-WAIT respect deadlines, but this includes their implicit
-uses inside SBCL itself.
+Currently only SLEEP, blocking IO operations, SB-THREAD:GET-MUTEX, and
+SB-THREAD:CONDITION-WAIT respect deadlines, but this includes their
+implicit uses inside SBCL itself.
Unless OVERRIDE is true, existing deadlines can only be restricted,
not extended. Deadlines are per thread: children are unaffected by
diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index 076a24113..ee67f1f14 100644
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -217,21 +217,21 @@ implementation it is ~S." *!default-package-use-list*)
(defmacro defpackage (package &rest options)
#.(format nil
"Defines a new package called PACKAGE. Each of OPTIONS should be one of the
- following: ~{~&~4T~A~}
- All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
+ following: ~{~&~4T(~S ~A)~}
+ All options except ~{~S, ~}and :DOCUMENTATION can be used multiple
times."
- '((:use "{package-name}*")
- (:export "{symbol-name}*")
- (:import-from "<package-name> {symbol-name}*")
- (:shadow "{symbol-name}*")
- (:shadowing-import-from "<package-name> {symbol-name}*")
- (:local-nicknames "{(local-nickname actual-package-name)}*")
- (:lock "boolean")
- (:implement "{package-name}*")
- (:documentation "doc-string")
- (:intern "{symbol-name}*")
- (:size "<integer>")
- (:nicknames "{package-name}*"))
+ '(:use "{package-name}*"
+ :export "{symbol-name}*"
+ :import-from "<package-name> {symbol-name}*"
+ :shadow "{symbol-name}*"
+ :shadowing-import-from "<package-name> {symbol-name}*"
+ :local-nicknames "{(local-nickname actual-package-name)}*"
+ :lock "boolean"
+ :implement "{package-name}*"
+ :documentation "doc-string"
+ :intern "{symbol-name}*"
+ :size "<integer>"
+ :nicknames "{package-name}*")
'(:size :lock))
(let ((nicknames nil)
(local-nicknames nil)
diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 777a1d862..a4d5483de 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -351,9 +351,9 @@ readtable when not provided."
(defun set-syntax-from-char (to-char from-char &optional
(to-readtable *readtable*) (from-readtable nil))
- "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional
-readtable (defaults to the current readtable). The FROM-TABLE defaults to the
-standard Lisp readtable when NIL."
+ "Causes the syntax of TO-CHAR in TO-READTABLE to be the same as
+FROM-CHAR in FROM-READTABLE. TO-READTABLE defaults to *READTABLE*, and
+FROM-READTABLE defaults to the standard Lisp readtable when NIL."
;; TO-READTABLE is a readtable, not a readtable-designator
(assert-not-standard-readtable to-readtable 'set-syntax-from-char)
(let* ((from-readtable (or from-readtable *standard-readtable*))
diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index ca4bc17ae..81e9ee24f 100644
--- a/src/code/serve-event.lisp
+++ b/src/code/serve-event.lisp
@@ -280,11 +280,11 @@ T if SERVE-EVENT did something and NIL if not."
;;; Serve a single set of events.
(defun serve-event (&optional timeout)
- "Receive pending events on all FD-STREAMS and dispatch to the appropriate
-handler functions. If timeout is specified, server will wait the specified
-time (in seconds) and then return, otherwise it will wait until something
-happens. Server returns T if something happened and NIL otherwise. Timeout
-0 means polling without waiting."
+ "Receive pending events on all FD-STREAMs, and dispatch to the
+appropriate handler functions. If timeout is specified, server will
+wait the specified time (in seconds) and then return, otherwise it
+will wait until something happens. Server returns T if something
+happened and NIL otherwise. Timeout 0 means polling without waiting."
(multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
(decode-timeout timeout)
(declare (ignore stop-sec stop-usec))
diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index b66b9b804..4aebdbfe4 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -135,7 +135,7 @@ This is SETFable."
`(alien-funcall-into ,func-expr ,var ,@args)))))
(defmacro with-alien (bindings &body body &environment env)
- "Establish some local alien variables. Each BINDING is of the form:
+ "Establish some local alien variables. Each of BINDINGS is of the form:
VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
ALLOCATION should be one of:
:LOCAL (the default)
@@ -824,7 +824,7 @@ Also automatically DECLAIM the FTYPE of the defined function.
NAME may be either a string, a symbol, or a list of the form (string symbol).
-RETURN-TYPE is the alien type for the function return value. VOID may be
+RESULT-TYPE is the alien type for the function return value. VOID may be
used to specify a function with no result.
The remaining forms specify individual arguments that are passed to the
diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 936f1e94d..9074a3424 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -638,9 +638,9 @@ with that condition (or with no condition) will be returned."
report function from the specified PARENT-TYPEs. A slot spec is a list of:
(slot-name :reader <rname> :initarg <iname> {Option Value}*
- The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
- and :TYPE and the overall options :DEFAULT-INITARGS and
- [type] :DOCUMENTATION are also allowed.
+ The DEFCLASS slot options :ALLOCATION, :INITFORM, [slot]
+ :DOCUMENTATION and :TYPE and the overall options :DEFAULT-INITARGS
+ and [type] :DOCUMENTATION are also allowed.
The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
a string or a two-argument lambda or function name. If a function, the
@@ -1677,18 +1677,14 @@ stepped."))
(step-condition-args condition)))))
(:documentation "Condition signalled by code compiled with
single-stepping information when about to execute a form.
-STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the
-pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH
-holds the source-path to the original form within that file or NIL.
-Associated with this condition are always the restarts STEP-INTO,
-STEP-NEXT, and STEP-CONTINUE."))
+STEP-CONDITION-FORM holds the form. Associated with this condition are
+always the restarts STEP-INTO, STEP-NEXT, and STEP-CONTINUE."))
(define-condition step-result-condition (step-condition)
((result :initarg :result :reader step-condition-result)))
(setf (documentation 'step-condition-result 'function)
- "Return values associated with STEP-VALUES-CONDITION as a list,
-or the variable value associated with STEP-VARIABLE-CONDITION.")
+ "Return values associated with STEP-VALUES-CONDITION as a list.")
(define-condition step-values-condition (step-result-condition)
()
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 3f1d2f338..1fa5f2b99 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -2476,7 +2476,7 @@ Short version: be careful out there."
(defun terminate-thread (thread)
"Terminate the thread identified by THREAD, by interrupting it and
-causing it to call SB-EXT:ABORT-THREAD with :ALLOW-EXIT T.
+causing it to call SB-THREAD:ABORT-THREAD with :ALLOW-EXIT T.
The unwind caused by TERMINATE-THREAD is asynchronous, meaning that
eg. thread executing
diff --git a/src/code/timer.lisp b/src/code/timer.lisp
index 1aabd8a1e..93eed2e32 100644
--- a/src/code/timer.lisp
+++ b/src/code/timer.lisp
@@ -166,9 +166,10 @@ If a THREAD is supplied, FUNCTION is run in that thread. If THREAD is
T, a new thread is created for FUNCTION each time the timer is
triggered. If THREAD is NIL, FUNCTION is run in an unspecified thread.
-When THREAD is not T, INTERRUPT-THREAD is used to run FUNCTION and the
-ordering guarantees of INTERRUPT-THREAD apply. In that case, FUNCTION
-runs with interrupts disabled but WITH-INTERRUPTS is allowed.")
+When THREAD is not T, SB-THREAD:INTERRUPT-THREAD is used to run
+FUNCTION and the ordering guarantees of SB-THREAD:INTERRUPT-THREAD
+apply. In that case, FUNCTION runs with interrupts disabled but
+WITH-INTERRUPTS is allowed.")
(defun timer-name (timer)
"Return the name of TIMER."
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 58a953d25..07412165a 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -1064,12 +1064,12 @@ Lisp extension proposal by David N. Gray")
(defpackage "SB-SYS"
(:documentation
"private: In theory, this \"contains functions and information
-necessary for system interfacing\" (said cmu-user.tex at the time
-of the SBCL code fork). That probably was and is a good idea, but in
-practice, the distinctions between this package and SB-KERNEL
-and even SB-VM seem to have become somewhat blurred over the years.
-Some anomalies (e.g. FIND-IF-IN-CLOSURE being in SB-SYS instead of
-SB-KERNEL) have been undone, but probably more remain.")
+necessary for system interfacing\" (said cmu-user.tex at the time of
+the SBCL code fork). That probably was and is a good idea, but in
+practice, the distinctions between this package and SB-KERNEL and even
+SB-VM seem to have become somewhat blurred over the years. Some
+anomalies (e.g. SB-IMPL::FIND-IF-IN-CLOSURE being in SB-IMPL instead
+of SB-KERNEL) have been undone, but probably more remain.")
(:use "CL" "SB-EXT" "SB-INT")
(:export
;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS
@@ -3275,7 +3275,7 @@ structure representations")
"sorta public: Eventually this should become the debugger interface, with
basic stuff like BACKTRACE and ARG. For now, the actual supported interface
is still mixed indiscriminately with low-level internal implementation stuff
-like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*.")
+like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUNS*.")
(:use "CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL")
(:export "*BACKTRACE-FRAME-COUNT*"
"*DEBUG-BEGINNER-HELP-P*"
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index e9ea358f5..fc7f93d63 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -233,11 +233,12 @@ extent of the block."
(def-ir1-translator tagbody ((&rest statements) start next result)
"TAGBODY {tag | statement}*
-Define tags for use with GO. The STATEMENTS are evaluated in order, skipping
-TAGS, and NIL is returned. If a statement contains a GO to a defined TAG
-within the lexical scope of the form, then control is transferred to the next
-statement following that tag. A TAG must be an integer or a symbol. A
-STATEMENT must be a list. Other objects are illegal within the body."
+Define tags for use with GO. The STATEMENTs are evaluated in order,
+skipping TAGs, and NIL is returned. If a statement contains a GO to a
+defined TAG within the lexical scope of the form, then control is
+transferred to the next statement following that tag. A TAG must be an
+integer or a symbol. A STATEMENT must be a list. Other objects are
+illegal within the body."
(let ((segments (and statements
(parse-tagbody statements))))
(cond
@@ -410,7 +411,7 @@ Evaluate the FORMS in the specified SITUATIONS (any of :COMPILE-TOPLEVEL,
(def-ir1-translator macrolet ((definitions &rest body) start next result)
"MACROLET ({(name lambda-list form*)}*) body-form*
-Evaluate the BODY-FORMS in an environment with the specified local macros
+Evaluate BODY-FORMs in an environment with the specified local macros
defined. NAME is the local macro name, LAMBDA-LIST is a DEFMACRO style
destructuring lambda list, and the FORMS evaluate to the expansion."
(funcall-in-macrolet-lexenv
@@ -452,8 +453,9 @@ destructuring lambda list, and the FORMS evaluate to the expansion."
((macrobindings &body body) start next result)
"SYMBOL-MACROLET ({(name expansion)}*) decl* form*
-Define the NAMES as symbol macros with the given EXPANSIONS. Within the
-body, references to a NAME will effectively be replaced with the EXPANSION."
+Define the NAMEs as symbol macros with the given EXPANSIONs. Within
+the body, references to a NAME will effectively be replaced with the
+EXPANSION."
(funcall-in-symbol-macrolet-lexenv
macrobindings
(lambda (&optional vars)
@@ -899,8 +901,8 @@ form to reference any of the previous VARS."
"LOCALLY declaration* form*
Sequentially evaluate the FORMS in a lexical environment where the
-DECLARATIONS have effect. If LOCALLY is a top level form, then the FORMS are
-also processed as top level forms."
+DECLARATIONs have effect. If LOCALLY is a top level form, then the
+FORMs are also processed as top level forms."
(ir1-translate-locally body start next result))
;;;; FLET and LABELS
@@ -979,9 +981,10 @@ also processed as top level forms."
start next result)
"FLET ({(name lambda-list declaration* form*)}*) declaration* body-form*
-Evaluate the BODY-FORMS with local function definitions. The bindings do
-not enclose the definitions; any use of NAME in the FORMS will refer to the
-lexically apparent function definition in the enclosing environment."
+Evaluate the BODY-FORMs with local function definitions. The bindings
+do not enclose the definitions; any use of NAME in the FORMS will
+refer to the lexically apparent function definition in the enclosing
+environment."
(multiple-value-bind (names defs forms decls)
(parse-fletish definitions body 'flet)
(let* ((fvars (mapcar (lambda (name def original)
@@ -1010,9 +1013,9 @@ lexically apparent function definition in the enclosing environment."
(def-ir1-translator labels ((definitions &body body) start next result)
"LABELS ({(name lambda-list declaration* form*)}*) declaration* body-form*
-Evaluate the BODY-FORMS with local function definitions. The bindings enclose
-the new definitions, so the defined functions can call themselves or each
-other."
+Evaluate the BODY-FORMs with local function definitions. The bindings
+enclose the new definitions, so the defined functions can call
+themselves or each other."
(multiple-value-bind (names defs forms decls)
(parse-fletish definitions body 'labels)
(let* ((new-fenv
diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp
index 49472a7a5..f3352968a 100644
--- a/src/pcl/gray-streams.lisp
+++ b/src/pcl/gray-streams.lisp
@@ -282,7 +282,7 @@
(defgeneric stream-terpri (stream)
(:documentation
"Writes an end of line, as for TERPRI. Returns NIL. The default
- method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
+ method does (STREAM-WRITE-CHAR stream #\\NEWLINE)."))
(defmethod stream-terpri ((stream fundamental-character-output-stream))
(stream-write-char stream #\Newline))
@@ -331,7 +331,7 @@
successful, or NIL if it is not supported for this stream. This is
intended for use by by PPRINT and FORMAT ~T. The default method uses
STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
- #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
+ #\\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
column)
diff --git a/src/pcl/sequence.lisp b/src/pcl/sequence.lisp
index 73221bcb3..3a789ecd2 100644
--- a/src/pcl/sequence.lisp
+++ b/src/pcl/sequence.lisp
@@ -52,9 +52,9 @@
(:method ((s sequence))
(sequence:protocol-unimplemented 'sequence:length s))
(:documentation
- "Returns the length of SEQUENCE or signals a PROTOCOL-UNIMPLEMENTED
- error if the sequence protocol is not implemented for the class of
- SEQUENCE."))
+ "Returns the length of SEQUENCE or signals a
+ SEQUENCE:PROTOCOL-UNIMPLEMENTED error if the sequence protocol is
+ not implemented for the class of SEQUENCE."))
(defgeneric sequence:elt (sequence index)
(:method ((s list) index) (elt s index))
@@ -63,8 +63,8 @@
(sequence:protocol-unimplemented 'sequence:elt s))
(:documentation
"Returns the element at position INDEX of SEQUENCE or signals a
- PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
- implemented for the class of SEQUENCE."))
+ SEQUENCE:PROTOCOL-UNIMPLEMENTED error if the sequence protocol is
+ not implemented for the class of SEQUENCE."))
(defgeneric (setf sequence:elt) (new-value sequence index)
(:argument-precedence-order sequence new-value index)
@@ -74,8 +74,8 @@
(sequence:protocol-unimplemented '(setf sequence:elt) s))
(:documentation
"Replaces the element at position INDEX of SEQUENCE with NEW-VALUE
- and returns NEW-VALUE or signals a PROTOCOL-UNIMPLEMENTED error if
- the sequence protocol is not implemented for the class of
+ and returns NEW-VALUE or signals a SEQUENCE:PROTOCOL-UNIMPLEMENTED
+ error if the sequence protocol is not implemented for the class of
SEQUENCE."))
(defgeneric sequence:make-sequence-like
@@ -108,8 +108,8 @@
same class as SEQUENCE. Elements of the new sequence are
initialized to INITIAL-ELEMENT, if supplied, initialized to
INITIAL-CONTENTS if supplied, or undefined if neither is supplied.
- Signals a PROTOCOL-UNIMPLEMENTED error if the sequence protocol is
- not implemented for the class of SEQUENCE."))
+ Signals a SEQUENCE:PROTOCOL-UNIMPLEMENTED error if the sequence
+ protocol is not implemented for the class of SEQUENCE."))
(defgeneric sequence:adjust-sequence
(sequence length &key initial-element initial-contents)
@@ -148,8 +148,8 @@
of the returned sequence are initialized to INITIAL-ELEMENT, if
supplied, initialized to INITIAL-CONTENTS if supplied, or identical
to the elements of SEQUENCE if neither is supplied. Signals a
- PROTOCOL-UNIMPLEMENTED error if the sequence protocol is not
- implemented for the class of SEQUENCE."))
+ SEQUENCE:PROTOCOL-UNIMPLEMENTED error if the sequence protocol is
+ not implemented for the class of SEQUENCE."))
;;;; iterator protocol
@@ -301,8 +301,9 @@
3. from-end
The returned iterator can be used with the generic iterator
- functions ITERATOR-STEP, ITERATOR-ENDP, ITERATOR-ELEMENT, (SETF
- ITERATOR-ELEMENT), ITERATOR-INDEX and ITERATOR-COPY."))
+ functions SEQUENCE:ITERATOR-STEP, SEQUENCE:ITERATOR-STEP,
+ SEQUENCE:ITERATOR-ELEMENT, (SETF SEQUENCE:ITERATOR-ELEMENT),
+ SEQUENCE:ITERATOR-INDEX and SEQUENCE:ITERATOR-COPY."))
(defgeneric sequence:iterator-step (sequence iterator from-end)
(:method ((s list) iterator from-end)
@@ -392,9 +393,9 @@
step endp element set-element index copy)
(sequence &key from-end (start 0) end) &body body)
"Executes BODY with the elements of VARS bound to the iteration
- state returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE and
+ state returned by SEQUENCE:MAKE-SEQUENCE-ITERATOR for SEQUENCE and
ARGS. Elements of VARS may be NIL in which case the corresponding
- value returned by MAKE-SEQUENCE-ITERATOR is ignored."
+ value returned by SEQUENCE:MAKE-SEQUENCE-ITERATOR is ignored."
(declare (ignore iterator limit from-end-p
step endp element set-element index copy))
(let* ((ignored '())
@@ -415,11 +416,11 @@
&body body)
"Executes BODY with the names STEP, ENDP, ELT, SETF, INDEX and COPY
bound to local functions which execute the iteration state query and
-mutation functions returned by MAKE-SEQUENCE-ITERATOR for SEQUENCE and
-ARGS. When some names are not supplied or NIL is supplied for a given
-name, no local functions are established for those names. The
-functions established for STEP, ENDP, ELT, SETF, INDEX and COPY have
-dynamic extent."
+mutation functions returned by SEQUENCE:MAKE-SEQUENCE-ITERATOR for
+SEQUENCE and ARGS. When some names are not supplied or NIL is supplied
+for a given name, no local functions are established for those names.
+The functions established for STEP, ENDP, ELT, SETF, INDEX and COPY
+have dynamic extent."
(declare (ignore from-end start end))
(let ((nstate (gensym "STATE")) (nlimit (gensym "LIMIT"))
(nfrom-end (gensym "FROM-END-")) (nstep (gensym "STEP"))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: melisgl <me...@us...> - 2026-05-30 10:18:14
|
The branch "master" has been updated in SBCL:
via 02bd195c1ab97edbb6b59593c92bb8e05e3e4a5e (commit)
from 39ea7adbefe5d6d4b0cad3cfdf0b3dca349506b1 (commit)
- Log -----------------------------------------------------------------
commit 02bd195c1ab97edbb6b59593c92bb8e05e3e4a5e
Author: Gabor Melis <me...@re...>
Date: Fri May 29 09:40:47 2026 +0200
doc: tweaks
---
contrib/sb-posix/sb-posix.texinfo | 23 ---------------
doc/manual/docstrings.lisp | 2 +-
doc/manual/start-stop.texinfo | 59 ++++++++++++++++++++-------------------
3 files changed, 31 insertions(+), 53 deletions(-)
diff --git a/contrib/sb-posix/sb-posix.texinfo b/contrib/sb-posix/sb-posix.texinfo
index 2f851eb5b..2b6dfd32a 100644
--- a/contrib/sb-posix/sb-posix.texinfo
+++ b/contrib/sb-posix/sb-posix.texinfo
@@ -179,26 +179,12 @@ implementation-dependent members of all structure types on your system
objects corresponding to supported POSIX structures, and the supported
slots for those structures.
-@itemize
-
-@item flock
@include class-sb-posix-flock.texinfo
-
-@item passwd
@include class-sb-posix-passwd.texinfo
-
-@item passwd
@include class-sb-posix-group.texinfo
-
-@item stat
@include class-sb-posix-stat.texinfo
-
-@item termios
@include class-sb-posix-termios.texinfo
-
-@item timeval
@include class-sb-posix-timeval.texinfo
-@end itemize
@node Functions with idiosyncratic bindings
@subsection Functions with idiosyncratic bindings
@@ -206,14 +192,9 @@ slots for those structures.
A few functions in sb-posix don't correspond directly to their C
counterparts.
-@itemize
-@item getcwd
@include fun-sb-posix-getcwd.texinfo
-@item readlink
@include fun-sb-posix-readlink.texinfo
-@item syslog
@include fun-sb-posix-syslog.texinfo
-@end itemize
@node Extensions to POSIX
@@ -235,9 +216,5 @@ database while preventing the keyed accesses (@code{SB-POSIX:GETPWNAM},
@code{SB-POSIX:GETGRGID})
from running until iteration completes.
-@itemize
-@item do-passwds
@include macro-sb-posix-do-passwds.texinfo
-@item do-groups
@include macro-sb-posix-do-groups.texinfo
-@end itemize
diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp
index 1d2a5e56a..6e5c4d1c6 100644
--- a/doc/manual/docstrings.lisp
+++ b/doc/manual/docstrings.lisp
@@ -530,7 +530,7 @@ variables if the symbol in question is contained in symbols
(defun lisp-section-p (line line-number lines)
"Returns T if the given LINE looks like start of lisp code --
-ie. if it starts with whitespace followed by a paren or
+i.e. if it starts with whitespace followed by a paren or
semicolon, and the previous line is empty"
(let ((offset (indentation line)))
(and offset
diff --git a/doc/manual/start-stop.texinfo b/doc/manual/start-stop.texinfo
index 428cdd32f..fdae41717 100644
--- a/doc/manual/start-stop.texinfo
+++ b/doc/manual/start-stop.texinfo
@@ -24,10 +24,10 @@
@comment node-name, next, previous, up
@subsection From Shell to Lisp
-To run SBCL type @command{sbcl} at the command line.
+To run SBCL, type @command{sbcl} at the command line.
-You should end up in the toplevel @dfn{REPL} (read, eval, print
--loop), where you can interact with SBCL by typing expressions.
+You should end up in the toplevel @dfn{REPL} (read-eval-print loop),
+where you can interact with SBCL by typing expressions.
@smallexample
$ sbcl
@@ -39,7 +39,6 @@ It is mostly in the public domain; some portions are provided under
BSD-style licenses. See the CREDITS and COPYING files in the
distribution for more information.
* (+ 2 2)
-
4
* (exit)
$
@@ -51,8 +50,8 @@ See also @ref{Command Line Options} and @ref{Stopping SBCL}.
@comment node-name, next, previous, up
@subsection Running from Emacs
-To run SBCL as an inferior-lisp from Emacs in your @file{.emacs} do
-something like:
+To run SBCL as an @code{inferior-lisp} from Emacs, in your
+@file{.emacs} do something like:
@lisp
;;; The SBCL binary and command-line arguments
@@ -70,7 +69,7 @@ Integration}.
Standard Unix tools that are interpreters follow a common command line
protocol that is necessary to work with ``shebang scripts''. SBCL supports
-this via the @code{--script} command line option.
+this via the @code{--script} command line option @pxref{Command Line Options}.
Example file (@file{hello.lisp}):
@@ -79,13 +78,15 @@ Example file (@file{hello.lisp}):
(write-line "Hello, World!")
@end lisp
-Usage examples:
+Usage from the command line:
@smallexample
$ ./hello.lisp
Hello, World!
@end smallexample
+Note that SBCL skips the shebang line when it reads the file:
+
@smallexample
$ sbcl --script hello.lisp
Hello, World!
@@ -175,18 +176,17 @@ command line arguments are passed on to user code.
The full, unambiguous syntax for invoking SBCL at the command line is:
-@command{sbcl} @var{runtime-option}* @code{--end-runtime-options} @var{toplevel-option}* @code{--end-toplevel-options} @var{user-options}*
+@command{sbcl} @var{runtime-option}* @code{--end-runtime-options} @var{toplevel-option}* @code{--end-toplevel-options} @var{user-option}*
-For convenience, the @code{--end-runtime-options} and
-@code{--end-toplevel-options} elements can be omitted. Omitting these
-elements can be convenient when you are running the program
-interactively, and you can see that no ambiguities are possible with
-the option values you are using. Omitting these elements is probably a
-bad idea for any batch file where any of the options are under user
-control, since it makes it impossible for SBCL to detect erroneous
-command line input, so that erroneous command line arguments will be
-passed on to the user program even if they was intended for the
-runtime system or the Lisp system.
+For convenience, @code{--end-runtime-options} and
+@code{--end-toplevel-options} can be omitted, which can be convenient
+when you are running the program interactively, and you can see that
+no ambiguities are possible with the option values you are using.
+Omitting these elements is probably a bad idea for any batch file
+where any of the options are under user control, since it makes it
+impossible for SBCL to detect erroneous command line input, so that
+erroneous command line arguments will be passed on to the user program
+even if they was intended for the runtime system or the Lisp system.
@menu
* Runtime Options::
@@ -234,19 +234,20 @@ with LDB.
@cindex ldb
There are some dangerous low-level errors (for instance, control stack
exhausted, memory fault) that (or whose handlers) can corrupt the
-image. By default SBCL prints a warning, then tries to continue and
-handle the error in Lisp, but this will not always work and SBCL may
+image. By default, SBCL prints a warning, then tries to continue and
+handle the error in Lisp, but this will not always work, and SBCL may
malfunction or even hang. With this option, upon encountering such an
-error SBCL will invoke ldb (if present and enabled) or else exit.
+error, SBCL will exit instead of invoking LDB (if present and
+enabled).
@item --script @var{filename}
-As a runtime option this is equivalent to @code{--noinform}
+As a @emph{runtime} option, this is equivalent to @code{--noinform}
@code{--disable-ldb} @code{--lose-on-corruption}
@code{--end-runtime-options} @code{--script} @var{filename}. See the
-description of @code{--script} as a toplevel option below. If there
-are no other command line arguments following @code{--script}, the
-filename argument can be omitted.
+description of @code{--script} as a @emph{toplevel} option below. If
+there are no other command line arguments following @code{--script},
+the filename argument can be omitted.
@item --merge-core-pages
@@ -271,9 +272,9 @@ Print SBCL's version information, then exit.
In the future, runtime options may be added to control behaviour such
as lazy allocation of memory.
-Runtime options, including any --end-runtime-options option, are
-stripped out of the command line before the Lisp toplevel logic gets a
-chance to see it.
+Runtime options, including any @code{--end-runtime-options} option,
+are stripped out of the command line before the Lisp toplevel logic
+gets a chance to see it.
@node Toplevel Options
@comment node-name, next, previous, up
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: melisgl <me...@us...> - 2026-05-30 10:18:11
|
The branch "master" has been updated in SBCL:
via 39ea7adbefe5d6d4b0cad3cfdf0b3dca349506b1 (commit)
from 92d060d08232f96d7e7b7a7a6729a87438f5a72b (commit)
- Log -----------------------------------------------------------------
commit 39ea7adbefe5d6d4b0cad3cfdf0b3dca349506b1
Author: Gabor Melis <me...@re...>
Date: Fri May 29 09:54:56 2026 +0200
Bind *PRINT-READABLY* to NIL when printing TRACE "returned" message
It was already bound to NIL for the "call" message.
---
NEWS | 2 ++
src/code/ntrace.lisp | 3 ++-
tests/trace.impure.lisp | 10 ++++++++++
3 files changed, 14 insertions(+), 1 deletion(-)
diff --git a/NEWS b/NEWS
index b7dc4366b..bdfc34262 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@
changes relative to sbcl-2.6.5:
* minor incompatible change: FDEFINITION now returns the outermost wrapper
(added e.g. by TRACE, PROFILE) like SYMBOL-FUNCTION. (lp#799533)
+ * bug fix: TRACE no longer fails when trying to print a return value that
+ cannot be printed readble and *PRINT-READABLY* is true.
* documentation: SB-INTROSPECT is documented.
changes in sbcl-2.6.5 relative to sbcl-2.6.4:
diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index 5f4934a54..fad1e26c2 100644
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -360,7 +360,8 @@
(or (cdr entry)
(let ((cond (trace-info-condition-after info)))
(and cond (apply #'funcall (cdr cond) frame values)))))
- (let ((*current-level-in-print* 0)
+ (let ((*print-readably* nil)
+ (*current-level-in-print* 0)
(*standard-output* (make-string-output-stream))
(*in-trace* t))
(case (trace-info-report info)
diff --git a/tests/trace.impure.lisp b/tests/trace.impure.lisp
index 4722bad00..09a3a99c0 100644
--- a/tests/trace.impure.lisp
+++ b/tests/trace.impure.lisp
@@ -137,3 +137,13 @@
(let ((s (with-output-to-string (*trace-output*)
(g1))))
(assert (search "G1 returned INVOKED" s))))
+
+
+(defun echo (x)
+ x)
+
+(trace echo)
+
+;;; Check that this does not fail when printing *PACKAGE*.
+(let ((*print-readably* t))
+ (echo *package*))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: melisgl <me...@us...> - 2026-05-30 10:18:09
|
The branch "master" has been updated in SBCL:
via 92d060d08232f96d7e7b7a7a6729a87438f5a72b (commit)
from e1c2bc15e2661b851c67330d2d0815dbea6dead2 (commit)
- Log -----------------------------------------------------------------
commit 92d060d08232f96d7e7b7a7a6729a87438f5a72b
Author: Gabor Melis <me...@re...>
Date: Wed May 27 14:53:24 2026 +0200
Housekeeping: whitespace, typos, comments, credits
---
.gitignore | 78 +++++++++++-----------
.mailmap | 2 +
CREDITS | 6 +-
TLA | 8 +--
contrib/STANDARDS | 2 +-
contrib/sb-simple-streams/classes.lisp | 2 -
contrib/sb-simple-streams/direct.lisp | 2 -
contrib/sb-simple-streams/file.lisp | 2 -
contrib/sb-simple-streams/impl.lisp | 2 -
contrib/sb-simple-streams/iodefs.lisp | 2 -
contrib/sb-simple-streams/null.lisp | 2 -
contrib/sb-simple-streams/package.lisp | 2 -
contrib/sb-simple-streams/simple-stream-tests.lisp | 2 -
contrib/sb-simple-streams/socket.lisp | 2 -
contrib/sb-simple-streams/strategy.lisp | 2 -
contrib/sb-simple-streams/string.lisp | 2 -
contrib/sb-simple-streams/terminal.lisp | 2 -
doc/PACKAGING-SBCL.txt | 2 +-
doc/manual/docstrings.lisp | 2 -
src/pcl/compiler-support.lisp | 1 +
tests/compiler-2.impure-cload.lisp | 2 -
21 files changed, 51 insertions(+), 76 deletions(-)
diff --git a/.gitignore b/.gitignore
index 6a1497d6d..108e2c16b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -11,42 +11,42 @@
*.diff
*.patch
.gdb_history
-output
-obj
-local-target-features.lisp-expr
-customize-target-features.*
-customize-backend-subfeatures.*
-src/assembly/target
-src/compiler/assembly
-src/compiler/target
-src/runtime/Config
-src/runtime/TAGS
-src/runtime/genesis
-src/runtime/openbsd-sigcontext.h
-src/runtime/sbcl
-src/runtime/ldb
-src/runtime/sbcl.exe
-src/runtime/sbcl.mk
-src/runtime/shrinkwrap-sbcl*
-src/runtime/target-arch-os.h
-src/runtime/target-arch.h
-src/runtime/target-lispregs.h
-src/runtime/target-os.h
-src/runtime/embedcore-sbcl
-tests/test-status.lisp-expr
-tests/test.log
-tests/*.so
-tests/run-tests-*
-tests/last-random-state.lisp-expr
-tests/ansi-test/
-tools-for-build/avx2*
-tools-for-build/determine-endianness
-tools-for-build/determine-endianness.exe
-tools-for-build/grovel-headers
-tools-for-build/grovel-headers.exe
-tools-for-build/mmap-rwx
-tools-for-build/where-is-mcontext
-tools-for-build/perfecthash*
-contrib/asdf/asdf-upstream
-doc/manual/*.html
-version.lisp-expr
+/output
+/obj
+/local-target-features.lisp-expr
+/customize-target-features.*
+/customize-backend-subfeatures.*
+/src/assembly/target
+/src/compiler/assembly
+/src/compiler/target
+/src/runtime/Config
+/src/runtime/TAGS
+/src/runtime/genesis
+/src/runtime/openbsd-sigcontext.h
+/src/runtime/sbcl
+/src/runtime/ldb
+/src/runtime/sbcl.exe
+/src/runtime/sbcl.mk
+/src/runtime/shrinkwrap-sbcl*
+/src/runtime/target-arch-os.h
+/src/runtime/target-arch.h
+/src/runtime/target-lispregs.h
+/src/runtime/target-os.h
+/src/runtime/embedcore-sbcl
+/tests/test-status.lisp-expr
+/tests/test.log
+/tests/*.so
+/tests/run-tests-*
+/tests/last-random-state.lisp-expr
+/tests/ansi-test/
+/tools-for-build/avx2*
+/tools-for-build/determine-endianness
+/tools-for-build/determine-endianness.exe
+/tools-for-build/grovel-headers
+/tools-for-build/grovel-headers.exe
+/tools-for-build/mmap-rwx
+/tools-for-build/where-is-mcontext
+/tools-for-build/perfecthash*
+/contrib/asdf/asdf-upstream
+/doc/manual/*.html
+/version.lisp-expr
diff --git a/.mailmap b/.mailmap
index 78d577ae0..c9d40c74d 100644
--- a/.mailmap
+++ b/.mailmap
@@ -20,6 +20,8 @@ David Lichteblau <da...@li...> <da...@kn...>
Francois-Rene Rideau <tu...@go...> <fa...@tu...>
+Gabor Melis <me...@re...> <me...@ho...>
+
Jim Wise <ji...@us...>
Jim Wise <ji...@us...> <jimwise>
<ji...@us...> <jw...@dr...>
diff --git a/CREDITS b/CREDITS
index b2061fbca..bbf111e4b 100644
--- a/CREDITS
+++ b/CREDITS
@@ -168,7 +168,7 @@ Guy Steele wrote the original character functions
code/char.lisp
They were subsequently rewritten by David Dill, speeded up by Scott
Fahlman, and rewritten without fonts and with a new type system by Rob
-MachLachlan.
+MacLachlan.
Lee Schumacher made the Spice Lisp version of backquote. The comment
in the CMU CL sources suggests he based it on someone else's code for
@@ -695,8 +695,8 @@ Dave McDonald:
Gabor Melis:
He mainly worked on robustness related to signal handling, threads,
timers with small excursions to constraint propagation, weak hash
- tables (based on CMUCL code) and optimizing x86/x86-64 calling
- convention.
+ tables (based on CMUCL code), adaptive hash tables, and optimizing
+ x86/x86-64 calling convention.
Perry E. Metzger:
He ported SBCL to NetBSD with newer signals, building on the
diff --git a/TLA b/TLA
index bccf71987..17e5541d3 100644
--- a/TLA
+++ b/TLA
@@ -3,8 +3,8 @@
abbreviations we try to use pervasively in the system
As Dan Barlow pointed out long ago on the mailing list, unabbreviated
-names are easier to deal with than abbreviated names, because you
-never need to remember what abbreviation to use. That's true, but in a
+names are easier to deal with than abbreviated names because you never
+need to remember what abbreviation to use. That's true, but in a
language like Lisp which depends on compound names for important
things like structure accessors, that can lead to painful names like
MAKE-EXTERNAL-ENTRY-POINT-LAMBDA-EXPRESSION and associated indenting
@@ -30,8 +30,8 @@ making them more consistent.
SB storage base (in compiler IR2)
SC storage class (in compiler IR2)
TN temporary name (?) (in compiler IR2)
- VAR variable (in the lisp entity "noun" sense, not in the
+ VAR variable (in the lisp entity "noun" sense, not in the
adjectival sense)
XEP external entry point
-Making them even more consistent (within the limits of ANSI and
+Making them even more consistent (within the limits of ANSI and
MOP compatibility) would probably be good.
diff --git a/contrib/STANDARDS b/contrib/STANDARDS
index 16b937c43..9fb19a793 100644
--- a/contrib/STANDARDS
+++ b/contrib/STANDARDS
@@ -1,4 +1,4 @@
-Proposed contrib standard, $Revision$
+Proposed contrib standard
The SBCL contrib mechanism provides a mechanism to
manage code which does not form part of SBCL itself, but which is
diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp
index 27bc1bf80..a1ea68dd4 100644
--- a/contrib/sb-simple-streams/classes.lisp
+++ b/contrib/sb-simple-streams/classes.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/direct.lisp b/contrib/sb-simple-streams/direct.lisp
index 751bf3718..560e721af 100644
--- a/contrib/sb-simple-streams/direct.lisp
+++ b/contrib/sb-simple-streams/direct.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/file.lisp b/contrib/sb-simple-streams/file.lisp
index 60e5bb4e1..689ce2220 100644
--- a/contrib/sb-simple-streams/file.lisp
+++ b/contrib/sb-simple-streams/file.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp
index 2267ea75b..e37f7aa82 100644
--- a/contrib/sb-simple-streams/impl.lisp
+++ b/contrib/sb-simple-streams/impl.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/iodefs.lisp b/contrib/sb-simple-streams/iodefs.lisp
index b9d2e521e..92dd9c009 100644
--- a/contrib/sb-simple-streams/iodefs.lisp
+++ b/contrib/sb-simple-streams/iodefs.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/null.lisp b/contrib/sb-simple-streams/null.lisp
index 474718919..96bcd3f0d 100644
--- a/contrib/sb-simple-streams/null.lisp
+++ b/contrib/sb-simple-streams/null.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/package.lisp b/contrib/sb-simple-streams/package.lisp
index c9c38bca3..96c5c03fd 100644
--- a/contrib/sb-simple-streams/package.lisp
+++ b/contrib/sb-simple-streams/package.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-
;;; This code is in the public domain.
;;; The cmucl implementation of simple-streams was done by Paul Foley,
diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp
index 2fb510043..577071b35 100644
--- a/contrib/sb-simple-streams/simple-stream-tests.lisp
+++ b/contrib/sb-simple-streams/simple-stream-tests.lisp
@@ -1,5 +1,3 @@
-;;;; -*- lisp -*-
-
(defpackage sb-simple-streams-test
(:import-from #:test-util #:deftest)
(:use #:common-lisp #:sb-simple-streams))
diff --git a/contrib/sb-simple-streams/socket.lisp b/contrib/sb-simple-streams/socket.lisp
index 65357ac4a..2dfdbcea6 100644
--- a/contrib/sb-simple-streams/socket.lisp
+++ b/contrib/sb-simple-streams/socket.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp
index ceb2f9ebf..21fa57672 100644
--- a/contrib/sb-simple-streams/strategy.lisp
+++ b/contrib/sb-simple-streams/strategy.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/string.lisp b/contrib/sb-simple-streams/string.lisp
index 1bd604e1e..64f9a7201 100644
--- a/contrib/sb-simple-streams/string.lisp
+++ b/contrib/sb-simple-streams/string.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/contrib/sb-simple-streams/terminal.lisp b/contrib/sb-simple-streams/terminal.lisp
index 07feaa993..f459c37ff 100644
--- a/contrib/sb-simple-streams/terminal.lisp
+++ b/contrib/sb-simple-streams/terminal.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-;;;
;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
diff --git a/doc/PACKAGING-SBCL.txt b/doc/PACKAGING-SBCL.txt
index 311554950..efec4c634 100644
--- a/doc/PACKAGING-SBCL.txt
+++ b/doc/PACKAGING-SBCL.txt
@@ -8,7 +8,7 @@ can result from mistaking a packaged SBCL for the upstream one.
If you are working from a Git branch, all you need to do is make sure
the branch name reflects the situation -- the build system will
-incorporate the it in the version string.
+incorporate it in the version string.
If you are working from a release tarball, please edit
version.lisp-expr, and append ".packaging-target-or-patch[.version]".
diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp
index f6131ebba..1d2a5e56a 100644
--- a/doc/manual/docstrings.lisp
+++ b/doc/manual/docstrings.lisp
@@ -1,5 +1,3 @@
-;;; -*- lisp -*-
-
;;;; A docstring extractor for the sbcl manual. Creates
;;;; @include-ready documentation from the docstrings of exported
;;;; symbols of specified packages.
diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp
index 9ac81f2f8..5d0accf31 100644
--- a/src/pcl/compiler-support.lisp
+++ b/src/pcl/compiler-support.lisp
@@ -176,6 +176,7 @@
(t (constant-arg symbol) t)
* :node node)
(acond ((always-bound-struct-accessor-p object slot-name)
+ ;; Note that the SETF is undefined for :READ-ONLY slots.
`(setf (,(dsd-accessor-name it) object) new-value))
((policy node (= safety 3))
;; Safe code wants to check the type, and the global
diff --git a/tests/compiler-2.impure-cload.lisp b/tests/compiler-2.impure-cload.lisp
index 699c56ab3..77ed385f6 100644
--- a/tests/compiler-2.impure-cload.lisp
+++ b/tests/compiler-2.impure-cload.lisp
@@ -1,5 +1,3 @@
-;;;; -*- lisp -*-
-
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: melisgl <me...@us...> - 2026-05-30 10:18:06
|
The branch "master" has been updated in SBCL:
via e1c2bc15e2661b851c67330d2d0815dbea6dead2 (commit)
from 48063e41707f0965f57b2c124312376be9b12096 (commit)
- Log -----------------------------------------------------------------
commit e1c2bc15e2661b851c67330d2d0815dbea6dead2
Author: Gabor Melis <me...@re...>
Date: Wed May 27 14:24:37 2026 +0200
Improve reporting of NOTINLINE full calls in make-host-2.lisp
Previously, make-host-2.lisp reported full calls of inline functions
even if all full calls were NOTINLINE. This was because the diagnostic
loop failed to check the 0th bit of the EMITTED-FULL-CALLS cell (via
ODDP), which PONDER-FULL-CALL specifically uses to track whether any
of the calls lacked a NOTINLINE declaration.
Background: When accommodating compilation dependencies in other
ways (such as changing the build order) is too difficult, NOTINLINE is
used to avoid the compilation failures that a full call to a function
that's later inlined would cause.
With this change, there are no "Likely suspicious" calls reported on
the default x86-64 build.
---
make-host-2.lisp | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/make-host-2.lisp b/make-host-2.lisp
index 84d3d1460..77931b21e 100644
--- a/make-host-2.lisp
+++ b/make-host-2.lisp
@@ -98,6 +98,12 @@
(source-xform (sb-int:info :function :source-transform name))
(info (sb-int:info :function :info name)))
(when (and cell
+ ;; Do not report if all calls were expressly
+ ;; NOTINLINE. If CELL is odd (i.e. there were full
+ ;; calls without NOTINLINE), then the number of
+ ;; full calls reported includes those expressly
+ ;; NOTINLINE. See SB-C::EMITTED-FULL-CALL-COUNT.
+ (oddp cell)
(or inlinep
source-xform
(and info (sb-c::fun-info-templates info))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
|
From: melisgl <me...@us...> - 2026-05-30 10:18:04
|
The branch "master" has been updated in SBCL:
via 48063e41707f0965f57b2c124312376be9b12096 (commit)
from 480584f800ac07a1310f8c86dfc68024f34fa38e (commit)
- Log -----------------------------------------------------------------
commit 48063e41707f0965f57b2c124312376be9b12096
Author: Gabor Melis <me...@re...>
Date: Mon May 25 20:40:37 2026 +0200
doc: document sb-introspect
---
NEWS | 1 +
contrib/sb-introspect/introspect.lisp | 293 +++++++++++++++++++---------
contrib/sb-introspect/sb-introspect.texinfo | 61 ++++++
doc/manual/contrib-modules.texinfo | 4 +
doc/manual/docstrings.lisp | 3 +-
5 files changed, 267 insertions(+), 95 deletions(-)
diff --git a/NEWS b/NEWS
index e8178a80e..b7dc4366b 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,7 @@
changes relative to sbcl-2.6.5:
* minor incompatible change: FDEFINITION now returns the outermost wrapper
(added e.g. by TRACE, PROFILE) like SYMBOL-FUNCTION. (lp#799533)
+ * documentation: SB-INTROSPECT is documented.
changes in sbcl-2.6.5 relative to sbcl-2.6.4:
* minor incompatible change: the condition signalled when an accessed slot
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index fb2c5c420..3d59acff1 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -17,7 +17,7 @@
;;; own project, there will be much wailing and gnashing of teeth.
;;; Your teeth. If need be, we'll kick them for you. This is a
;;; contrib, we're allowed to look in internals. You're an
-;;; application programmer, and are not.
+;;; application programmer and are not.
;;; TODO
;;; 3) error handling. Signal random errors, or handle and resignal 'our'
@@ -67,7 +67,7 @@
;;;
(deftype debug-info ()
"Structure containing all the debug information related to a function.
-Function objects reference debug-infos which in turn reference
+Function objects reference debug-infos, which in turn reference
debug-sources and so on."
'sb-c::compiled-debug-info)
@@ -92,8 +92,9 @@ include the pathname of the file and the position of the definition."
(sb-c::debug-info-source debug-info))
(defun valid-function-name-p (name)
- "True if NAME denotes a valid function name, ie. one that can be passed to
-FBOUNDP."
+ "See if NAME is a valid function name. In addition to the ANSI
+definition of function name, which is symbols plus lists like (SETF
+SYMBOL), SBCL allows (CAS SYMBOL) and various internal constructs."
(and (sb-int:valid-function-name-p name) t))
;;;; Utilities for code
@@ -108,9 +109,9 @@ FBOUNDP."
(declaim (inline map-allocated-code-components))
(defun map-allocated-code-components (spaces fn)
"Call FN for each allocated code component in one of SPACES. FN
-receives the object and its size as arguments. SPACES should be a
-list of the symbols :dynamic, :static, :read-only, or :immobile on
-#+immobile-space"
+receives the object and its size as arguments. SPACES should be a list
+of the symbols :DYNAMIC, :STATIC, :READ-ONLY, or :IMMOBILE on
+#+IMMOBILE-SPACE. The shorthand (:ALL) is also accepted."
(apply #'sb-vm:map-allocated-objects
(lambda (obj header size)
(when (= sb-vm:code-header-widetag header)
@@ -119,7 +120,7 @@ list of the symbols :dynamic, :static, :read-only, or :immobile on
(declaim (inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
- "Call FN for each code component with a fdefn for FUNCTION in its
+ "Call FN for each code component with a FDEFN for FUNCTION in its
constant pool."
(let ((function (coerce function 'function)))
(map-allocated-code-components
@@ -146,32 +147,112 @@ constant pool."
;;;; Finding definitions
-(defstruct definition-source
- ;; Pathname of the source file that the definition was compiled from.
- ;; This is null if the definition was not compiled from a file.
- (pathname nil :type (or null pathname))
- ;; Source-path of the definition within the file.
- ;; This may be incomplete depending on the debug level at which the
- ;; source was compiled.
- (form-path '() :type list)
- ;; Depth first number of the form.
- ;; FORM-PATH above usually contains just the top-level form number,
- ;; ideally the proper form path could be dervied from the
- ;; form-number and the tlf-number, but it's a bit complicated and
- ;; Slime already knows how to deal with form numbers, so delegate
- ;; that job to Slime.
- (form-number nil :type (or null unsigned-byte))
- ;; Character offset of the top-level-form containing the definition.
- ;; This corresponds to the first element of form-path.
- (character-offset nil :type (or null unsigned-byte))
- ;; File-write-date of the source file when compiled.
- ;; Null if not compiled from a file.
- (file-write-date nil :type (or null unsigned-byte))
- ;; plist from WITH-COMPILATION-UNIT
- (plist nil)
+(defmacro defstruct* (name-and-options &rest slot-descriptions)
+ "Like DEFSTRUCT, but support :DOCUMENTATION among slot options.
+The documentation is attached to the slot's STRUCTURE-ACCESSOR.
+Example:
+
+ (defstruct* my-struct
+ (my-slot nil :documentation \"docstring\"))
+
+In addition to the normal DEFSTRUCT processing, the above also does
+the moral equivalent of
+
+ (setf (documentation 'my-struct-my-slot 'function) \"docstring\")"
+ (destructuring-bind (name &rest options)
+ (sb-c::ensure-list name-and-options)
+ (let* ((conc-name-option (find :conc-name options :key (lambda (x)
+ (if (consp x)
+ (car x)
+ x))))
+ (conc-name (cond ((not conc-name-option)
+ (format nil "~A-" name))
+ ((or (atom conc-name-option)
+ (null (cdr conc-name-option))
+ (null (second conc-name-option)))
+ "")
+ (t
+ (string (second conc-name-option)))))
+ (not-found (gensym))
+ (set-doc-forms ())
+ (new-sds
+ (loop
+ for sd in slot-descriptions
+ collect (let ((documentation
+ (and (listp sd)
+ (getf (cddr sd) :documentation not-found))))
+ (cond
+ ((or (not (listp sd))
+ (eq documentation not-found))
+ sd)
+ (t
+ (let ((accessor-name (intern
+ (format nil "~A~A" conc-name
+ (first sd)))))
+ (push `(setf (documentation ',accessor-name
+ 'function)
+ ,documentation)
+ set-doc-forms))
+ (let ((sd (copy-seq sd)))
+ (remf (cddr sd) :documentation)
+ sd)))))))
+ `(progn
+ (defstruct ,name-and-options
+ ,@new-sds)
+ ,@set-doc-forms))))
+
+;;; FIXME: Rename this
+(defstruct* definition-source
+ "This structure identifies a sexp in a compiled file.
+Despite the name, the source location may not correspond to a
+definition but to e.g. a function call (see WHO-CALLS)."
+ (pathname
+ nil :type (or null pathname)
+ :documentation "Pathname of the source file.
+This is NIL if the source location is not in a compiled file.")
+ (form-path
+ '() :type list
+ :documentation "List of indices that identify the sexp in the
+file given by DEFINITION-SOURCE-PATHNAME. The first element in the
+list is the index of the top-level form that contains the sexp. If the
+file was compiled at a high enough debug level, then the rest of the
+elements recursively index into the list structure of the top-level
+form.
+
+Thus, the form path is somewhat stable regarding edits in the file,
+but it gets invalidated by, for example, inserting a new top-level
+form before the sexp in question.")
+ (form-number
+ nil :type (or null unsigned-byte)
+ :documentation "Depth-first index of the sexp within the top-level
+form identified by the first element of DEFINITION-SOURCE-FORM-PATH.
+That is, this is the index of the sexp in the list of subexpressions
+of the top-level form ordered according to depth-first traversal. 0
+corresponds to the top-level form itself.
+
+When combined with the index of the top-level form (given by the first
+element of DEFINITION-SOURCE-FORM-PATH), the form number allows
+reconstruction of the rest of the form path, which may be missing.
+This requires parsing the source file. Currently, this job is
+delegated to e.g. SLIME.")
+ (character-offset
+ nil :type (or null unsigned-byte)
+ :documentation "Character offset of the top-level form containing
+the sexp.")
+ (file-write-date
+ nil :type (or null unsigned-byte)
+ :documentation "FILE-WRITE-DATE of DEFINITION-SOURCE-PATHNAME at
+the time of compilation. NIL if not compiled from a file.")
+ (plist
+ nil
+ :documentation "The SOURCE-PLIST from WITH-COMPILATION-UNIT in effect
+when the file was compiled.")
;; Any extra metadata that the caller might be interested in. For
- ;; example the specializers of the method whose definition-source this
- ;; is.
+ ;; example, DEFINITION-SOURCE of a method contains the specializers
+ ;; of the method to help disambiguate it.
+ ;;
+ ;; FIXME: This is currently unexported, but it is also necessary to
+ ;; disambiguate methods. See e.g. WHO-SPECIALIZES-DIRECTLY.
(description nil :type list))
(defun vops-translating-fun (name)
@@ -204,9 +285,12 @@ constant pool."
(defun find-definition-sources-by-name (name type)
"Returns a list of DEFINITION-SOURCEs for definitions of NAME with
-the given definition TYPE. TYPE can currently be one of the following.
+the given definition TYPE. A DEFINITION-SOURCE object is always
+returned for definitions that exist, but the source location (e.g.
+DEFINITION-SOURCE-PATHNAME) may be missing. TYPE can currently be one
+of the following.
-Public definition TYPEs:
+Public definition types:
:CLASS
:COMPILER-MACRO
@@ -227,7 +311,7 @@ Public definition TYPEs:
:VARIABLE
:DECLARATION
-Internal definition TYPEs:
+Internal definition types:
:OPTIMIZER
:SOURCE-TRANSFORM
@@ -250,8 +334,8 @@ Valid NAMEs are generally SYMBOLs with the following exceptions:
- For :PACKAGE, string designators are valid.
-If an unsupported TYPE is requested or NAME is invalid, the function
-will return NIL."
+If an unsupported TYPE is requested or NAME is invalid, this function
+returns NIL."
(flet ((get-class (name)
(and (symbolp name)
(find-class name nil)))
@@ -438,6 +522,18 @@ will return NIL."
nil)))))
(defun find-definition-source (object)
+ "Return the DEFINITION-SOURCE corresponding to the definition of OBJECT
+or NIL if there is no corresponding definition. OBJECT must be a
+PACKAGE, FUNCTION, METHOD, METHOD-COMBINATION, SB-MOP:SLOT-DEFINITION,
+STANDARD-OBJECT, STRUCTURE-OBJECT, CONDITION, CLASS, STRUCTURE-CLASS,
+or a subclass of CONDITION. An error is signalled for other types.
+
+A DEFINITION-SOURCE object is always returned for definitions that
+exist, but the source location (e.g. DEFINITION-SOURCE-PATHNAME) may
+be missing.
+
+For definitions that do not define an object (e.g. DEFVAR), use
+FIND-DEFINITION-SOURCES-BY-NAME."
(typecase object
((or sb-pcl::condition-class sb-pcl::structure-class)
(let ((classoid (sb-pcl::class-classoid object)))
@@ -533,13 +629,13 @@ will return NIL."
(function-lambda-list function))
(defun function-lambda-list (function)
- "Return the lambda list for the extended function designator FUNCTION.
-Works for special-operators, macros, simple functions, interpreted functions,
-and generic functions. Signals an error if FUNCTION is not a valid extended
-function designator.
+ "Return the lambda list of FUNCTION.
+FUNCTION must be a function object or a function name in the sense of
+VALID-FUNCTION-NAME-P. Works for special operators, macros, simple
+functions, interpreted functions, and generic functions.
-If the function does not have a lambda list (compiled with debug 0),
-then two values are returned: (values nil t)"
+The second return value indicates whether the lambda list could not be
+determined (e.g. because the function was compiled with DEBUG 0)."
(cond ((and (symbolp function) (special-operator-p function))
(function-lambda-list (info :function :ir1-convert function)))
((valid-function-name-p function)
@@ -554,14 +650,19 @@ then two values are returned: (values nil t)"
(values nil t)
(values raw-result nil))))))
-(defun deftype-lambda-list (typespec-operator)
- "Returns the lambda list of TYPESPEC-OPERATOR as first return
-value, and a flag whether the arglist could be found as second
-value."
- (check-type typespec-operator symbol)
- ;; Don't return a lambda-list for combinators AND,OR,NOT.
- (let* ((f (and (info :type :kind typespec-operator)
- (info :type :expander typespec-operator)))
+(defun deftype-lambda-list (type-specifier-name)
+ "Returns the lambda list of TYPE-SPECIFIER-NAME as the first return
+value, and a flag whether the arglist could be found as the second
+value.
+
+TYPE-SPECIFIER-NAME must be a symbol. This function can find the
+lambda list of derived type specifiers (e.g. those defined with
+DEFTYPE) and classes with compound type specifier syntaxes (e.g. the
+class FLOAT). It returns NIL, NIL for other type specifiers (e.g. AND,
+OR, NOT) and types (e.g. LIST)."
+ (check-type type-specifier-name symbol)
+ (let* ((f (and (info :type :kind type-specifier-name)
+ (info :type :expander type-specifier-name)))
(f (if (listp f) (car f) f)))
(if (functionp f)
(let ((lambda-list (%fun-lambda-list f)))
@@ -571,7 +672,7 @@ value."
(values nil nil))))
(defun method-combination-lambda-list (method-combination)
- "Return the lambda-list of METHOD-COMBINATION designator.
+ "Return the lambda list of the METHOD-COMBINATION designator.
METHOD-COMBINATION can be a method combination object,
or a method combination name."
(let* ((name (etypecase method-combination
@@ -583,7 +684,7 @@ or a method combination name."
(sb-pcl::method-combination-info-lambda-list info)))
(defun function-type (function-designator)
- "Returns the ftype of FUNCTION-DESIGNATOR, or NIL."
+ "Returns the ftype of FUNCTION-DESIGNATOR or NIL."
(etypecase function-designator
((or symbol cons)
;; XXX: why require FBOUNDP? Would it be wrong to always report the proclaimed type?
@@ -651,7 +752,12 @@ or a method combination name."
callees)))
(defun find-function-callers (function &optional (spaces '(:all)))
- "Return functions which call FUNCTION, by searching SPACES for code objects"
+ "List functions that call FUNCTION by searching SPACES for code objects.
+This can make previously garbage objects live.
+
+SPACES should be a list of the symbols :DYNAMIC, :STATIC, :READ-ONLY,
+or :IMMOBILE on #+IMMOBILE-SPACE. The shorthand (:ALL) is also
+accepted."
(let ((referrers '()))
(map-caller-code-components
function
@@ -820,47 +926,46 @@ or a method combination name."
result)))))
(defun who-calls (function-name)
- "Use the xref facility to search for source locations where the
-global function named FUNCTION-NAME is called. Returns a list of
-function name, definition-source pairs."
+ "Find the source locations where the global function FUNCTION-NAME is
+called, and return them as an alist of function or macro name,
+DEFINITION-SOURCE pairs."
(collect-xref :calls function-name))
(defun who-binds (symbol)
- "Use the xref facility to search for source locations where the
-special variable SYMBOL is rebound. Returns a list of function name,
-definition-source pairs."
+ "Find the source locations where the special variable SYMBOL is bound,
+and return them as an alist of function or macro name,
+DEFINITION-SOURCE pairs."
(collect-xref :binds symbol))
(defun who-references (symbol)
- "Use the xref facility to search for source locations where the
-special variable or constant SYMBOL is read. Returns a list of function
-name, definition-source pairs."
+ "Find the source locations where the special variable SYMBOL is read,
+and return them as an alist of function or macro name,
+DEFINITION-SOURCE pairs."
(collect-xref :references symbol))
(defun who-sets (symbol)
- "Use the xref facility to search for source locations where the
-special variable SYMBOL is written to. Returns a list of function name,
-definition-source pairs."
+ "Find the source locations where the special variable SYMBOL is set,
+and return them as an alist of function or macro name,
+DEFINITION-SOURCE pairs."
(collect-xref :sets symbol))
(defun who-macroexpands (macro-name)
- "Use the xref facility to search for source locations where the
-macro MACRO-NAME is expanded. Returns a list of function name,
-definition-source pairs."
+ "Find the source locations where the macro MACRO-NAME is expanded, and
+return them as an alist of function or macro name, DEFINITION-SOURCE
+pairs."
(collect-xref :macroexpands macro-name))
(defun who-specializes-directly (class-designator)
- "Search for source locations of methods directly specializing on
-CLASS-DESIGNATOR. Returns an alist of method name, definition-source
-pairs.
+ "Find the source locations of methods directly specializing on
+CLASS-DESIGNATOR, and return them as an alist of generic function
+name, DEFINITION-SOURCE pairs.
A method matches the criterion either if it specializes on the same
class as CLASS-DESIGNATOR designates (this includes CLASS-EQ
specializers), or if it eql-specializes on an instance of the
designated class.
-Experimental.
-"
+Experimental."
(let ((class (canonicalize-class-designator class-designator)))
(unless class
(return-from who-specializes-directly nil))
@@ -883,17 +988,17 @@ Experimental.
result))))
(defun who-specializes-generally (class-designator)
- "Search for source locations of methods specializing on
-CLASS-DESIGNATOR, or a subclass of it. Returns an alist of method
-name, definition-source pairs.
+ "Find the source locations of methods specializing on
+CLASS-DESIGNATOR or a subclass of it, and return them as an alist of
+generic function name, DEFINITION-SOURCE pairs.
+DEFINITION-SOURCE-DESCRIPTION identifies the method.
A method matches the criterion either if it specializes on the
designated class itself or a subclass of it (this includes CLASS-EQ
specializers), or if it eql-specializes on an instance of the
designated class or a subclass of it.
-Experimental.
-"
+Experimental."
(let ((class (canonicalize-class-designator class-designator)))
(unless class
(return-from who-specializes-generally nil))
@@ -945,12 +1050,12 @@ Experimental.
1)))
(defun allocation-information (object)
- "Returns information about the allocation of OBJECT. Primary return value
-indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK,
-or :FOREIGN.
+ "Returns information about the allocation of OBJECT. The primary return
+value indicates the general type of allocation: :IMMEDIATE, :HEAP,
+:STACK, or :FOREIGN.
-Possible secondary return value provides additional information about the
-allocation.
+Non-NIL secondary return values provide additional information about
+the allocation.
For :HEAP objects the secondary value is a plist:
@@ -958,7 +1063,7 @@ For :HEAP objects the secondary value is a plist:
Indicates the heap segment the object is allocated in.
:GENERATION
- Is the current generation of the object: 0 for nursery, 6 for pseudo-static
+ The current generation of the object: 0 for nursery, 6 for pseudo-static
generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.)
:LARGE
@@ -967,13 +1072,13 @@ For :HEAP objects the secondary value is a plist:
:BOXED
Indicates that the object is allocated in a boxed region. Unboxed
- allocation is used for eg. specialized arrays after they have survived one
+ allocation is used for e.g. specialized arrays after they have survived one
collection. (GENCGC and :SPACE :DYNAMIC only.)
:PINNED
Indicates that the page(s) on which the object resides are kept live due
to conservative references. Note that object may reside on a pinned page
- even if :PINNED in NIL if the GC has not had the need to mark the the page
+ even if :PINNED is NIL if the GC has not had the need to mark the page
as pinned. (GENCGC and :SPACE :DYNAMIC only.)
:WRITE-PROTECTED
@@ -982,11 +1087,11 @@ For :HEAP objects the secondary value is a plist:
the last GC of its generation. (GENCGC and :SPACE :DYNAMIC only.)
:PAGE
- The index of the page the object resides on. (GENGC and :SPACE :DYNAMIC
+ The index of the page the object resides on. (GENCGC and :SPACE :DYNAMIC
only.)
-For :STACK objects secondary value is the thread on whose stack the object is
-allocated.
+For :STACK objects, the secondary value is the thread on whose stack
+the object is allocated.
Expected use-cases include introspection to gain insight into allocation and
GC behaviour and restricting memoization to heap-allocated arguments.
@@ -1044,12 +1149,12 @@ Experimental: interface subject to change."
Returns OBJECT.
If SIMPLE is true (default is NIL), elides those pointers that are not
-notionally part of certain built-in objects, but backpointers to a
-conceptual parent: eg. elides the pointer from a SYMBOL to the
+notionally part of certain built-in objects but backpointers to a
+conceptual parent: e.g. elides the pointer from a SYMBOL to the
corresponding PACKAGE.
If EXT is true (default is T), includes some pointers that are not
-actually contained in the object, but found in certain well-known
+actually contained in the object but found in certain well-known
indirect containers: FDEFINITIONs, EQL specializers, classes, and
thread-local symbol values in other threads fall into this category.
diff --git a/contrib/sb-introspect/sb-introspect.texinfo b/contrib/sb-introspect/sb-introspect.texinfo
new file mode 100644
index 000000000..b4b63a5af
--- /dev/null
+++ b/contrib/sb-introspect/sb-introspect.texinfo
@@ -0,0 +1,61 @@
+@node sb-introspect
+@section sb-introspect
+@cindex Introspection Library
+
+The @code{sb-introspect} module is about finding definitions, as well
+as querying their properties and relationships in the running image.
+
+@menu
+* Finding Definitions::
+* Special Variables in sb-introspect::
+* Functions::
+* Types and Classes::
+* Allocation::
+@end menu
+
+
+@node Finding Definitions
+@subsection Finding Definitions
+
+@include struct-sb-introspect-definition-source.texinfo
+@include fun-sb-introspect-definition-source-pathname.texinfo
+@include fun-sb-introspect-definition-source-form-path.texinfo
+@include fun-sb-introspect-definition-source-form-number.texinfo
+@include fun-sb-introspect-definition-source-character-offset.texinfo
+@include fun-sb-introspect-definition-source-file-write-date.texinfo
+@include fun-sb-introspect-definition-source-plist.texinfo
+
+@include fun-sb-introspect-find-definition-source.texinfo
+@include fun-sb-introspect-find-definition-sources-by-name.texinfo
+
+@node Special Variables in sb-introspect
+@subsection Special Variables
+
+@include fun-sb-introspect-who-binds.texinfo
+@include fun-sb-introspect-who-references.texinfo
+@include fun-sb-introspect-who-sets.texinfo
+
+@node Functions
+@subsection Functions
+
+@include fun-sb-introspect-function-lambda-list.texinfo
+@include fun-sb-introspect-function-type.texinfo
+@include fun-sb-introspect-method-combination-lambda-list.texinfo
+@include fun-sb-introspect-valid-function-name-p.texinfo
+@include fun-sb-introspect-find-function-callers.texinfo
+@include fun-sb-introspect-find-function-callees.texinfo
+@include fun-sb-introspect-who-calls.texinfo
+@include fun-sb-introspect-who-macroexpands.texinfo
+
+@node Types and Classes
+@subsection Types and Classes
+
+@include fun-sb-introspect-deftype-lambda-list.texinfo
+@include fun-sb-introspect-who-specializes-directly.texinfo
+@include fun-sb-introspect-who-specializes-generally.texinfo
+
+@node Allocation
+@subsection Allocation
+
+@include fun-sb-introspect-allocation-information.texinfo
+@include fun-sb-introspect-map-root.texinfo
diff --git a/doc/manual/contrib-modules.texinfo b/doc/manual/contrib-modules.texinfo
index 7862d7015..f5f06e085 100644
--- a/doc/manual/contrib-modules.texinfo
+++ b/doc/manual/contrib-modules.texinfo
@@ -13,6 +13,7 @@ contributed modules.
* sb-concurrency::
* sb-cover::
* sb-grovel::
+* sb-introspect::
* sb-md5::
* sb-posix::
* sb-queue::
@@ -32,6 +33,9 @@ contributed modules.
@page
@include sb-grovel/sb-grovel.texinfo
+@page
+@include sb-introspect/sb-introspect.texinfo
+
@page
@include sb-md5/sb-md5.texinfo
diff --git a/doc/manual/docstrings.lisp b/doc/manual/docstrings.lisp
index ede40cfa6..f6131ebba 100644
--- a/doc/manual/docstrings.lisp
+++ b/doc/manual/docstrings.lisp
@@ -86,7 +86,8 @@ you deserve to lose.")
(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+&#'"
"List of characters that make up symbols in a docstring.")
-(defparameter *symbol-delimiters* " ,.!?;()")
+;;; #\s is included to catch some plurals (e.g. FDEFINITIONs).
+(defparameter *symbol-delimiters* " ,.!?;()s")
(defparameter *ordered-documentation-kinds*
'(package type structure condition class macro))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
46 messages has been excluded from this view by a project administrator.