common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Turn docstrings into base-strings.

Browse source 
If an implementation is allowed to discard docstrings then it's also
allowed to coerce them into something.
This commit is contained in:
Stas Boukarev 2024-05-07 22:15:54 +03:00
parent 2394a8a1dd
commit d8591b83e4
5 changed files with 87 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
src/code/target-misc.lisp
View file

@ -174,34 +174,34 @@ the file system."
(macrolet
((cast-it ()
#-sb-unicode
'(if (and (simple-base-string-p s) (ok-space))
s
(replace (make-string (length s)) s))
#+sb-unicode
;; whether a copy is needed depends both on contents and simplicity
'(let* ((base-p (base-string-p s))
(recast (and (not base-p) (every #'base-char-p s))))
(if (and (simple-string-p s) (not recast) (ok-space))
`(when s
#-sb-unicode
(if (and (simple-base-string-p s) (ok-space))
s
(let ((n (length s)))
;; I think this could be done with a single allocator
;; and a length calculation. I don't care to do that.
(replace (if (or base-p recast)
(make-string n :element-type 'base-char)
(make-string n))
s))))))
(replace (make-string (length s)) s))
#+sb-unicode
;; whether a copy is needed depends both on contents and simplicity
(let* ((base-p (base-string-p s))
(recast (and (not base-p) (every #'base-char-p s))))
(if (and (simple-string-p s) (not recast) (ok-space))
s
(let ((n (length s)))
;; I think this could be done with a single allocator
;; and a length calculation. I don't care to do that.
(replace (if (or base-p recast)
(make-string n :element-type 'base-char)
(make-string n))
s)))))))
;;; Ensure basicness if possible, and simplicity always
(defun possibly-base-stringize (s)
(declare (string s))
(macrolet ((ok-space () 't))
(cast-it)))
(defun possibly-base-stringize (s)
(macrolet ((ok-space () 't))
(cast-it)))
;;; As above but copy dynamic-extent or other off-heap lisp strings
(defun possibly-base-stringize-to-heap (s)
(declare (string s) (sb-c::tlab :system))
(macrolet ((ok-space () '(or (dynamic-space-obj-p s) (read-only-space-obj-p s))))
(cast-it)))
) ; end MACROLET
(defun possibly-base-stringize-to-heap (s)
(declare (sb-c::tlab :system))
(macrolet ((ok-space () '(or (dynamic-space-obj-p s) (read-only-space-obj-p s))))
(cast-it)))
) ; end MACROLET
(in-package "SB-C")

2
src/compiler/entry.lisp
View file

@ -76,6 +76,8 @@ missing MAKE-LOAD-FORM methods?")
(and (policy bind (> store-source-form 0))
inline-expansion)))
(doc (functional-documentation internal-fun)))
(when doc
(setf doc (possibly-base-stringize doc)))
(setf (entry-info-form/doc info)
(if (and form doc) (cons form doc) (or form doc))))
(when (policy bind (>= debug 1))

2
src/compiler/fndb.lisp
View file

@ -619,7 +619,7 @@
vector
(flushable no-verify-arg-count))
(defknown (possibly-base-stringize possibly-base-stringize-to-heap) (string) simple-string
(defknown (possibly-base-stringize possibly-base-stringize-to-heap) ((or null string)) (or null simple-string)
(flushable no-verify-arg-count))
(defknown map (type-specifier (function-designator ((nth-arg 2 :sequence t)

3
src/pcl/defcombin.lisp
View file

@ -106,7 +106,8 @@
(cdr (assoc type (info :random-documentation :stuff name))))
(defun (setf random-documentation) (new-value name type)
(let ((pair (assoc type (info :random-documentation :stuff name))))
(let ((pair (assoc type (info :random-documentation :stuff name)))
(new-value (possibly-base-stringize new-value)))
(if pair
(setf (cdr pair) new-value)
(push (cons type new-value)

103
src/pcl/documentation.lisp
View file

@ -25,25 +25,26 @@
(defun (setf fun-doc) (new-value function)
(declare (type (or null string) new-value))
(typecase function
(interpreted-function
#+sb-fasteval
(setf (sb-interpreter:proto-fn-docstring (sb-interpreter:fun-proto-fn function))
new-value)
#+sb-eval
(setf (sb-eval:interpreted-function-documentation function) new-value))
(generic-function
(setf (slot-value function '%documentation) new-value))
(closure
(set-closure-extra-values
function nil
(pack-closure-extra-values
(nth-value +closure-name-index+ (closure-extra-values function))
new-value)))
(simple-fun
;; Don't allow PCL CTORs and other random functions through
;; because we don't want to affect builtin docstrings.
(setf (%simple-fun-doc function) new-value)))
(let ((new-value (possibly-base-stringize new-value)))
(typecase function
(interpreted-function
#+sb-fasteval
(setf (sb-interpreter:proto-fn-docstring (sb-interpreter:fun-proto-fn function))
new-value)
#+sb-eval
(setf (sb-eval:interpreted-function-documentation function) new-value))
(generic-function
(setf (slot-value function '%documentation) new-value))
(closure
(set-closure-extra-values
function nil
(pack-closure-extra-values
(nth-value +closure-name-index+ (closure-extra-values function))
new-value)))
(simple-fun
;; Don't allow PCL CTORs and other random functions through
;; because we don't want to affect builtin docstrings.
(setf (%simple-fun-doc function) new-value))))
new-value)
(defun real-function-name (name)
@ -94,17 +95,18 @@
;;; It, and the corresponding reader, are not for use outside this file.
(defun (setf %doc-info) (string name doc-type)
(declare (type (or null string) string))
(let ((info-number
(macrolet ((info-number (class type)
(meta-info-number (meta-info class type))))
(case doc-type
(variable (info-number :variable :documentation))
(structure
(cond ((eq (info :type :kind name) :instance)
(info-number :type :documentation))
((info :typed-structure :info name)
(info-number :typed-structure :documentation))))
(type (info-number :type :documentation))))))
(let ((string (possibly-base-stringize string))
(info-number
(macrolet ((info-number (class type)
(meta-info-number (meta-info class type))))
(case doc-type
(variable (info-number :variable :documentation))
(structure
(cond ((eq (info :type :kind name) :instance)
(info-number :type :documentation))
((info :typed-structure :info name)
(info-number :typed-structure :documentation))))
(type (info-number :type :documentation))))))
(cond (info-number
(if string
(set-info-value name info-number string)
@ -131,7 +133,8 @@
(t
(setf (fun-doc (fdefinition name)) string))))
((typep name '(or symbol cons))
(setf (random-documentation name doc-type) string)))))
(setf (random-documentation name doc-type) string))))
string)
(defun set-function-name-documentation (name documentation)
(aver name)
@ -256,14 +259,16 @@
(setf (fun-doc x) new-value))
(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
(set-function-name-documentation x new-value))
(set-function-name-documentation x (possibly-base-stringize new-value))
new-value)
(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
(awhen (compiler-macro-function x)
(setf (documentation it t) new-value)))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
(set-function-name-documentation x new-value))
(set-function-name-documentation x (possibly-base-stringize new-value))
new-value)
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'compiler-macro)))
(awhen (compiler-macro-function x)
@ -272,11 +277,13 @@
;;; SETF documentation is attached to the function that performs expansion,
;;; except for short form DEFSETF which is in the globaldb value directly.
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
(let ((expander (info :setf :expander x)))
(let ((expander (info :setf :expander x))
(new-value (possibly-base-stringize new-value)))
(typecase expander
((cons symbol) (setf (second expander) new-value))
(cons (setf (documentation (cdr expander) 'function) new-value))
(function (setf (documentation expander 'function) new-value)))))
(function (setf (documentation expander 'function) new-value))))
new-value)
(defmethod documentation ((x symbol) (doc-type (eql 'setf)))
(let ((expander (info :setf :expander x)))
@ -298,11 +305,13 @@
(defmethod (setf documentation)
(new-value (x method-combination) (doc-type (eql 't)))
(setf (slot-value x '%documentation) new-value))
(setf (slot-value x '%documentation) (possibly-base-stringize new-value))
new-value)
(defmethod (setf documentation)
(new-value (x method-combination) (doc-type (eql 'method-combination)))
(setf (slot-value x '%documentation) new-value))
(setf (slot-value x '%documentation) (possibly-base-stringize new-value))
new-value)
(defmethod (setf documentation)
(new-value (x symbol) (doc-type (eql 'method-combination)))
@ -314,7 +323,8 @@
(defmethod (setf documentation)
(new-value (x standard-method) (doc-type (eql 't)))
(setf (slot-value x '%documentation) new-value))
(setf (slot-value x '%documentation) (possibly-base-stringize new-value))
new-value)
;;; types, classes, and structure names
@ -348,11 +358,13 @@
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql ',doc-type)))
(acond
((find-class x nil)
(setf (documentation it t) new-value))
(t
(setf (%doc-info x ',doc-type) new-value)))))))
(let ((new-value (possibly-base-stringize new-value)))
(acond
((find-class x nil)
(setf (documentation it t) new-value))
(t
(setf (%doc-info x ',doc-type) new-value))))
new-value))))
(define-type-documentation-methods structure-class
(%doc-info (class-name x) 'type)
@ -360,7 +372,7 @@
(define-type-documentation-methods class
(slot-value x '%documentation)
(setf (slot-value x '%documentation) new-value))
(setf (slot-value x '%documentation) (possibly-base-stringize new-value)))
;; although the CLHS doesn't mention this, it is reasonable to
;; assume that parallel treatment of condition-class was intended
@ -390,8 +402,7 @@
(defmethod (setf documentation)
(new-value (slotd standard-slot-definition) (doc-type (eql 't)))
(declare (ignore doc-type))
(setf (slot-value slotd '%documentation) new-value))
(setf (slot-value slotd '%documentation) (possibly-base-stringize new-value)))
;;; Now that we have created the machinery for setting documentation, we can
;;; set the documentation for the machinery for setting documentation.