summaryrefslogtreecommitdiff
path: root/guix/packages.scm
diff options
context:
space:
mode:
authorMarius Bakke <marius@gnu.org>2021-09-17 01:25:52 +0200
committerMarius Bakke <marius@gnu.org>2021-09-17 01:25:52 +0200
commit5c3cb22c9b2810669999e044b2de5e9331011a83 (patch)
tree3276e19cc1a0af3cece6ce4f2bfa930901888bb4 /guix/packages.scm
parentc896287ce5eff968a0b323f3a069653a64b96b4c (diff)
parent2a054d29dcfd4b68ed3914886b637f93ac7a0a72 (diff)
Merge branch 'master' into core-updates-frozen
Conflicts: gnu/packages/bioinformatics.scm gnu/packages/chez.scm gnu/packages/docbook.scm gnu/packages/ebook.scm gnu/packages/gnome.scm gnu/packages/linux.scm gnu/packages/networking.scm gnu/packages/python-web.scm gnu/packages/python-xyz.scm gnu/packages/tex.scm gnu/packages/version-control.scm gnu/packages/xml.scm guix/build-system/dune.scm guix/build-system/go.scm guix/build-system/linux-module.scm guix/packages.scm
Diffstat (limited to 'guix/packages.scm')
-rw-r--r--guix/packages.scm85
1 files changed, 81 insertions, 4 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 2349bb4340..863c12d528 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -56,6 +56,7 @@
%current-target-system
search-path-specification) ;for convenience
#:re-export-and-replace (delete) ;used as syntactic keyword
+ #:replace ((define-public* . define-public))
#:export (content-hash
content-hash?
content-hash-algorithm
@@ -103,6 +104,7 @@
package-supported-systems
package-properties
package-location
+ package-definition-location
hidden-package
hidden-package?
package-superseded
@@ -388,6 +390,60 @@ not already the case."
inputs)
(else (map add-input-label inputs))))
+(define-syntax current-location-vector
+ (lambda (s)
+ "Like 'current-source-location' but expand to a literal vector with
+one-indexed line numbers."
+ ;; Storing a literal vector in .go files is more efficient than storing an
+ ;; alist: less initialization code, fewer relocations, etc.
+ (syntax-case s ()
+ ((_)
+ (match (syntax-source s)
+ (#f #f)
+ (properties
+ (let ((file (assq-ref properties 'filename))
+ (line (assq-ref properties 'line))
+ (column (assq-ref properties 'column)))
+ (and file line column
+ #`#(#,file #,(+ 1 line) #,column)))))))))
+
+(define-inlinable (sanitize-location loc)
+ ;; Convert LOC to a vector or to #f.
+ (cond ((vector? loc) loc)
+ ((not loc) loc)
+ (else (vector (location-file loc)
+ (location-line loc)
+ (location-column loc)))))
+
+(define-syntax-parameter current-definition-location
+ ;; Location of the encompassing 'define-public'.
+ (const #f))
+
+(define-syntax define-public*
+ (lambda (s)
+ "Like 'define-public' but set 'current-definition-location' for the
+lexical scope of its body."
+ (define location
+ (match (syntax-source s)
+ (#f #f)
+ (properties
+ (let ((line (assq-ref properties 'line))
+ (column (assq-ref properties 'column)))
+ ;; Don't repeat the file name since it's redundant with 'location'.
+ ;; Encode the whole thing so that it fits in a fixnum on 32-bit
+ ;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is
+ ;; almost always zero), and 22 bits for LINE.
+ (and line column
+ (logior (ash (logand #x7f column) 22)
+ (logand (- (expt 2 22) 1) (+ 1 line))))))))
+
+ (syntax-case s ()
+ ((_ prototype body ...)
+ #`(define-public prototype
+ (syntax-parameterize ((current-definition-location
+ (lambda (s) #,location)))
+ body ...))))))
+
;; A package.
(define-record-type* <package>
package make-package
@@ -434,10 +490,12 @@ not already the case."
(properties package-properties (default '())) ; alist for anything else
- (location package-location
- (default (and=> (current-source-location)
- source-properties->location))
- (innate)))
+ (location package-location-vector
+ (default (current-location-vector))
+ (innate) (sanitize sanitize-location))
+ (definition-location package-definition-location-code
+ (default (current-definition-location))
+ (innate)))
(define (add-input-label input)
"Add an input label to INPUT."
@@ -473,6 +531,25 @@ not already the case."
package)
16)))))
+(define (package-location package)
+ "Return the source code location of PACKAGE as a <location> record, or #f if
+it is not known."
+ (match (package-location-vector package)
+ (#f #f)
+ (#(file line column) (location file line column))))
+
+(define (package-definition-location package)
+ "Like 'package-location', but return the location of the definition
+itself--i.e., that of the enclosing 'define-public' form, if any, or #f."
+ (match (package-definition-location-code package)
+ (#f #f)
+ (code
+ (let ((column (bit-extract code 22 29))
+ (line (bit-extract code 0 21)))
+ (match (package-location-vector package)
+ (#f #f)
+ (#(file _ _) (location file line column)))))))
+
(define-syntax-rule (package/inherit p overrides ...)
"Like (package (inherit P) OVERRIDES ...), except that the same
transformation is done to the package P's replacement, if any. P must be a bare