#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
+ #:use-module (guix combinators)
#:use-module ((guix build utils) #:select (dump-port))
- #:use-module ((guix build syscalls) #:select (errno mkdtemp!))
+ #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
#:autoload (ice-9 popen) (open-pipe*)
#:use-module (ice-9 format)
#:use-module ((ice-9 iconv) #:select (bytevector->string))
#:use-module (system foreign)
+ #:re-export (memoize) ; for backwards compatibility
#:export (bytevector->base16-string
base16-string->bytevector
- compile-time-value
- fcntl-flock
- memoize
strip-keyword-arguments
default-keyword-arguments
substitute-keyword-arguments
ensure-keyword-arguments
+ current-source-directory
+
<location>
location
location?
location-line
location-column
source-properties->location
+ location->source-properties
nix-system->gnu-triplet
gnu-triplet->nix-system
call-with-temporary-output-file
call-with-temporary-directory
with-atomic-file-output
- fold2
- fold-tree
- fold-tree-leaves
- split
cache-directory
readlink*
edit-expression
canonical-newline-port))
\f
-;;;
-;;; Compile-time computations.
-;;;
-
-(define-syntax compile-time-value
- (syntax-rules ()
- "Evaluate the given expression at compile time. The expression must
-evaluate to a simple datum."
- ((_ exp)
- (let-syntax ((v (lambda (s)
- (let ((val exp))
- (syntax-case s ()
- (_ #`'#,(datum->syntax s val)))))))
- v))))
-
-\f
;;;
;;; Base 16.
;;;
\f
;;;
-;;; Advisory file locking.
+;;; Keyword arguments.
;;;
-(define %struct-flock
- ;; 'struct flock' from <fcntl.h>.
- (list short ; l_type
- short ; l_whence
- size_t ; l_start
- size_t ; l_len
- int)) ; l_pid
-
-(define F_SETLKW
- ;; On Linux-based systems, this is usually 7, but not always
- ;; (exceptions include SPARC.) On GNU/Hurd, it's 9.
- (compile-time-value
- (cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
- ((string-contains %host-type "linux") 7) ; *-linux-gnu
- (else 9)))) ; *-gnu*
-
-(define F_SETLK
- ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
- (compile-time-value
- (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
- ((string-contains %host-type "linux") 6) ; *-linux-gnu
- (else 8)))) ; *-gnu*
-
-(define F_xxLCK
- ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
- (compile-time-value
- (cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu
- ((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu
- ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
- (else #(1 2 3))))) ; *-gnu*
-
-(define fcntl-flock
- (let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
- (proc (pointer->procedure int ptr `(,int ,int *))))
- (lambda* (fd-or-port operation #:key (wait? #t))
- "Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION
-must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is
-true, block until the lock is acquired; otherwise, thrown an 'flock-error'
-exception if it's already taken."
- (define (operation->int op)
- (case op
- ((read-lock) (vector-ref F_xxLCK 0))
- ((write-lock) (vector-ref F_xxLCK 1))
- ((unlock) (vector-ref F_xxLCK 2))
- (else (error "invalid fcntl-flock operation" op))))
-
- (define fd
- (if (port? fd-or-port)
- (fileno fd-or-port)
- fd-or-port))
-
- ;; XXX: 'fcntl' is a vararg function, but here we happily use the
- ;; standard ABI; crossing fingers.
- (let ((err (proc fd
- (if wait?
- F_SETLKW ; lock & wait
- F_SETLK) ; non-blocking attempt
- (make-c-struct %struct-flock
- (list (operation->int operation)
- SEEK_SET
- 0 0 ; whole file
- 0)))))
- (or (zero? err)
-
- ;; Presumably we got EAGAIN or so.
- (throw 'flock-error (errno)))))))
-
-\f
-;;;
-;;; Miscellaneous.
-;;;
-
-(define (memoize proc)
- "Return a memoizing version of PROC."
- (let ((cache (make-hash-table)))
- (lambda args
- (let ((results (hash-ref cache args)))
- (if results
- (apply values results)
- (let ((results (call-with-values (lambda ()
- (apply proc args))
- list)))
- (hash-set! cache args results)
- (apply values results)))))))
-
(define (strip-keyword-arguments keywords args)
"Remove all of the keyword arguments listed in KEYWORDS from ARGS."
(let loop ((args args)
(#f
(loop rest kw/values (cons* value kw result))))))))
+\f
+;;;
+;;; System strings.
+;;;
+
(define* (nix-system->gnu-triplet
#:optional (system (%current-system)) (vendor "unknown"))
"Return a guess of the GNU triplet corresponding to Nix system
(with-throw-handler #t
(lambda ()
(let ((result (proc out)))
- (close out)
+ (fdatasync out)
+ (close-port out)
(rename-file template file)
result))
(lambda (key . args)
- (false-if-exception (delete-file template))))))
-
-(define fold2
- (case-lambda
- ((proc seed1 seed2 lst)
- "Like `fold', but with a single list and two seeds."
- (let loop ((result1 seed1)
- (result2 seed2)
- (lst lst))
- (if (null? lst)
- (values result1 result2)
- (call-with-values
- (lambda () (proc (car lst) result1 result2))
- (lambda (result1 result2)
- (loop result1 result2 (cdr lst)))))))
- ((proc seed1 seed2 lst1 lst2)
- "Like `fold', but with a two lists and two seeds."
- (let loop ((result1 seed1)
- (result2 seed2)
- (lst1 lst1)
- (lst2 lst2))
- (if (or (null? lst1) (null? lst2))
- (values result1 result2)
- (call-with-values
- (lambda () (proc (car lst1) (car lst2) result1 result2))
- (lambda (result1 result2)
- (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
-
-(define (fold-tree proc init children roots)
- "Call (PROC NODE RESULT) for each node in the tree that is reachable from
-ROOTS, using INIT as the initial value of RESULT. The order in which nodes
-are traversed is not specified, however, each node is visited only once, based
-on an eq? check. Children of a node to be visited are generated by
-calling (CHILDREN NODE), the result of which should be a list of nodes that
-are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
- (let loop ((result init)
- (seen vlist-null)
- (lst roots))
- (match lst
- (() result)
- ((head . tail)
- (if (not (vhash-assq head seen))
- (loop (proc head result)
- (vhash-consq head #t seen)
- (match (children head)
- ((or () #f) tail)
- (children (append tail children))))
- (loop result seen tail))))))
-
-(define (fold-tree-leaves proc init children roots)
- "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
- (fold-tree
- (lambda (node result)
- (match (children node)
- ((or () #f) (proc node result))
- (else result)))
- init children roots))
-
-(define (split lst e)
- "Return two values, a list containing the elements of the list LST that
-appear before the first occurence of the object E and a list containing the
-elements after E."
- (define (same? x)
- (equal? e x))
-
- (let loop ((rest lst)
- (acc '()))
- (match rest
- (()
- (values lst '()))
- (((? same?) . tail)
- (values (reverse acc) tail))
- ((head . tail)
- (loop tail (cons head acc))))))
+ (false-if-exception (delete-file template))
+ (close-port out)))))
(define (cache-directory)
"Return the cache directory for Guix, by default ~/.cache/guix."
(or (getenv "XDG_CONFIG_HOME")
- (and=> (getenv "HOME")
+ (and=> (or (getenv "HOME")
+ (passwd:dir (getpwuid (getuid))))
(cut string-append <> "/.cache/guix"))))
(define (readlink* file)
;;; Source location.
;;;
+(define (absolute-dirname file)
+ "Return the absolute name of the directory containing FILE, or #f upon
+failure."
+ (match (search-path %load-path file)
+ (#f #f)
+ ((? string? file)
+ ;; If there are relative names in %LOAD-PATH, FILE can be relative and
+ ;; needs to be canonicalized.
+ (if (string-prefix? "/" file)
+ (dirname file)
+ (canonicalize-path (dirname file))))))
+
+(define-syntax current-source-directory
+ (lambda (s)
+ "Return the absolute name of the current directory, or #f if it could not
+be determined."
+ (syntax-case s ()
+ ((_)
+ (match (assq 'filename (syntax-source s))
+ (('filename . (? string? file-name))
+ ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
+ ;; can be relative. In that case, we try to find out at run time
+ ;; the absolute file name by looking at %LOAD-PATH; doing this at
+ ;; run time rather than expansion time is necessary to allow files
+ ;; to be moved on the file system.
+ (cond ((not file-name)
+ #f) ;raising an error would upset Geiser users
+ ((string-prefix? "/" file-name)
+ (dirname file-name))
+ (else
+ #`(absolute-dirname #,file-name))))
+ (_
+ #f))))))
+
;; A source location.
(define-record-type <location>
(make-location file line column)
;; 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...
(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))))
HCoop / jackhill / guix / guix.git / blobdiff