;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-39)
- #:use-module (ice-9 binary-ports)
#:use-module (ice-9 ftw)
- #:autoload (rnrs io ports) (make-custom-binary-input-port)
+ #:use-module (rnrs io ports) ;need 'port-position' etc.
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization)
#:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
+ #:use-module (guix diagnostics) ;<location>, &error-location, etc.
#:use-module (ice-9 format)
- #:autoload (ice-9 popen) (open-pipe*)
- #:autoload (ice-9 rdelim) (read-line)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module ((ice-9 iconv) #:prefix iconv:)
#:use-module (system foreign)
- #:re-export (memoize) ; for backwards compatibility
+ #:re-export (memoize ;for backwards compatibility
+
+ <location>
+ location
+ location?
+ location-file
+ location-line
+ location-column
+ source-properties->location
+ location->source-properties
+
+ &error-location
+ error-location?
+ error-location)
#:export (strip-keyword-arguments
default-keyword-arguments
substitute-keyword-arguments
current-source-directory
- <location>
- location
- location?
- location-file
- location-line
- location-column
- source-properties->location
- location->source-properties
-
- &error-location
- error-location?
- error-location
-
&fix-hint
fix-hint?
condition-fix-hint
target-aarch64?
target-arm?
target-64bit?
+ cc-for-target
+
version-compare
version>?
version>=?
guile-version>?
version-prefix?
string-replace-substring
- arguments-from-environment-variable
file-extension
file-sans-extension
tarball-sans-extension
call-with-temporary-directory
with-atomic-file-output
+ with-environment-variables
+ arguments-from-environment-variable
+
config-directory
cache-directory
canonical-newline-port))
\f
+;;;
+;;; Environment variables.
+;;;
+
+(define (call-with-environment-variables variables thunk)
+ "Call THUNK with the environment VARIABLES set."
+ (let ((environment (environ)))
+ (dynamic-wind
+ (lambda ()
+ (for-each (match-lambda
+ ((variable value)
+ (setenv variable value)))
+ variables))
+ thunk
+ (lambda ()
+ (environ environment)))))
+
+(define-syntax-rule (with-environment-variables variables exp ...)
+ "Evaluate EXP with the given environment VARIABLES set."
+ (call-with-environment-variables variables
+ (lambda () exp ...)))
+
+(define (arguments-from-environment-variable variable)
+ "Retrieve value of environment variable denoted by string VARIABLE in the
+form of a list of strings (`char-set:graphic' tokens) suitable for consumption
+by `args-fold', if VARIABLE is defined, otherwise return an empty list."
+ (let ((env (getenv variable)))
+ (if env
+ (string-tokenize env char-set:graphic)
+ '())))
+
+\f
;;;
;;; Filtering & pipes.
;;;
(and target
(string-suffix? "-mingw32" target)))
-(define (target-arm32?)
- (string-prefix? "arm" (or (%current-target-system) (%current-system))))
+(define* (target-arm32? #:optional (target (or (%current-target-system)
+ (%current-system))))
+ (string-prefix? "arm" target))
+
+(define* (target-aarch64? #:optional (target (or (%current-target-system)
+ (%current-system))))
+ (string-prefix? "aarch64" target))
-(define (target-aarch64?)
- (string-prefix? "aarch64" (or (%current-target-system) (%current-system))))
+(define* (target-arm? #:optional (target (or (%current-target-system)
+ (%current-system))))
+ (or (target-arm32? target) (target-aarch64? target)))
-(define (target-arm?)
- (or (target-arm32?) (target-aarch64?)))
+(define* (target-64bit? #:optional (system (or (%current-target-system)
+ (%current-system))))
+ (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64")))
-(define (target-64bit?)
- (let ((system (or (%current-target-system) (%current-system))))
- (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "ppc64"))))
+(define* (cc-for-target #:optional (target (%current-target-system)))
+ (if target
+ (string-append target "-gcc")
+ "gcc"))
(define version-compare
(let ((strverscmp
(list-prefix? (string-tokenize v1 not-dot)
(string-tokenize v2 not-dot)))))
+\f
+;;;
+;;; Files.
+;;;
+
(define (file-extension file)
"Return the extension of FILE or #f if there is none."
(let ((dot (string-rindex file #\.)))
(substring str start index)
pieces))))))))
-(define (arguments-from-environment-variable variable)
- "Retrieve value of environment variable denoted by string VARIABLE in the
-form of a list of strings (`char-set:graphic' tokens) suitable for consumption
-by `args-fold', if VARIABLE is defined, otherwise return an empty list."
- (let ((env (getenv variable)))
- (if env
- (string-tokenize env char-set:graphic)
- '())))
-
(define (call-with-temporary-output-file proc)
"Call PROC with a name of a temporary file and open output port to that
file; close the file and delete it when leaving the dynamic extent of this
;; raising an error would upset Geiser users
#f))))))
-;; A source location.
-(define-record-type <location>
- (make-location file line column)
- location?
- (file location-file) ; file name
- (line location-line) ; 1-indexed line
- (column location-column)) ; 0-indexed column
-
-(define (location file line column)
- "Return the <location> object for the given FILE, LINE, and COLUMN."
- (and line column file
- (make-location file line column)))
-
-(define (source-properties->location loc)
- "Return a location object based on the info in LOC, an alist as returned
-by Guile's `source-properties', `frame-source', `current-source-location',
-etc."
- ;; In accordance with the GCS, start line and column numbers at 1. Note
- ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
- (match loc
- ((('line . line) ('column . col) ('filename . file)) ;common case
- (and file line col
- (make-location file (+ line 1) col)))
- (#f
- #f)
- (_
- (let ((file (assq-ref loc 'filename))
- (line (assq-ref loc 'line))
- (col (assq-ref loc 'column)))
- (location file (and line (+ line 1)) col)))))
-
-(define (location->source-properties loc)
- "Return the source property association list based on the info in LOC,
-a location object."
- `((line . ,(and=> (location-line loc) 1-))
- (column . ,(location-column loc))
- (filename . ,(location-file loc))))
-
-(define-condition-type &error-location &error
- error-location?
- (location error-location)) ;<location>
-
(define-condition-type &fix-hint &condition
fix-hint?
(hint condition-fix-hint)) ;string
HCoop / jackhill / guix / guix.git / blobdiff