From 9d5fda76bbe7edd954d2a5112f453b9a6f625cf1 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Wed, 11 May 2016 19:59:47 +0200 Subject: Initial commit. --- src/cuirass/base.scm | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 src/cuirass/base.scm (limited to 'src') diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm new file mode 100644 index 0000000..c7c23e2 --- /dev/null +++ b/src/cuirass/base.scm @@ -0,0 +1,61 @@ +;;;; base.scm - Cuirass base module +;;; +;;; Copyright © 2012, 2016 Ludovic Courtès +;;; +;;; This file is part of Cuirass. +;;; +;;; Cuirass is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Cuirass is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Cuirass. If not, see . + +(define-module (cuirass base) + #:use-module (ice-9 format) + #:use-module (srfi srfi-19) + #:export (guix-variable + with-directory-excursion + call-with-time-display)) + +(define (guix-variable module name) + "Dynamically link variable NAME under Guix module MODULE and return it. +Note: this is used instead of `@', because when using `@' in an uncompiled +file, Guile tries to load the module directly as it reads the source, which +fails in our case, leading to the creation of empty (guix ...) modules." + (let ((m (resolve-interface `(guix ,module)))) + (module-ref m name))) + +(define-syntax-rule (with-directory-excursion dir body ...) + "Run BODY with DIR as the process's current directory." + (let ((init (getcwd))) + (dynamic-wind + (lambda () + (chdir dir)) + (lambda () + body ...) + (lambda () + (chdir init))))) + +(define (call-with-time thunk kont) + "Call THUNK and pass KONT the elapsed time followed by THUNK's return +values." + (let* ((start (current-time time-monotonic)) + (result (call-with-values thunk list)) + (end (current-time time-monotonic))) + (apply kont (time-difference end start) result))) + +(define (call-with-time-display thunk) + "Call THUNK and write to the current output port its duration." + (call-with-time thunk + (lambda (time . results) + (format #t "~,3f seconds~%" + (+ (time-second time) + (/ (time-nanosecond time) 1e9))) + (apply values results)))) -- cgit v1.2.3