You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

648 lines
26 KiB

  1. ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
  2. ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of Guix.
  5. ;;;
  6. ;;; Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix utils)
  19. #:use-module (srfi srfi-1)
  20. #:use-module (srfi srfi-9)
  21. #:use-module (srfi srfi-26)
  22. #:use-module (srfi srfi-39)
  23. #:use-module (srfi srfi-60)
  24. #:use-module (rnrs bytevectors)
  25. #:use-module ((rnrs io ports) #:select (put-bytevector))
  26. #:use-module (ice-9 vlist)
  27. #:use-module (ice-9 format)
  28. #:autoload (ice-9 popen) (open-pipe*)
  29. #:autoload (ice-9 rdelim) (read-line)
  30. #:use-module (ice-9 regex)
  31. #:use-module (ice-9 match)
  32. #:use-module (ice-9 format)
  33. #:autoload (system foreign) (pointer->procedure)
  34. #:export (bytevector-quintet-length
  35. bytevector->base32-string
  36. bytevector->nix-base32-string
  37. bytevector->base16-string
  38. base32-string->bytevector
  39. nix-base32-string->bytevector
  40. base16-string->bytevector
  41. sha256
  42. %nixpkgs-directory
  43. nixpkgs-derivation
  44. nixpkgs-derivation*
  45. define-record-type*
  46. compile-time-value
  47. memoize
  48. location
  49. location?
  50. location-file
  51. location-line
  52. location-column
  53. source-properties->location
  54. gnu-triplet->nix-system
  55. %current-system))
  56. ;;;
  57. ;;; Compile-time computations.
  58. ;;;
  59. (define-syntax compile-time-value
  60. (syntax-rules ()
  61. "Evaluate the given expression at compile time. The expression must
  62. evaluate to a simple datum."
  63. ((_ exp)
  64. (let-syntax ((v (lambda (s)
  65. (let ((val exp))
  66. (syntax-case s ()
  67. (_ #`'#,(datum->syntax s val)))))))
  68. v))))
  69. ;;;
  70. ;;; Base 32.
  71. ;;;
  72. (define bytevector-quintet-ref
  73. (let* ((ref bytevector-u8-ref)
  74. (ref+ (lambda (bv offset)
  75. (let ((o (+ 1 offset)))
  76. (if (>= o (bytevector-length bv))
  77. 0
  78. (bytevector-u8-ref bv o)))))
  79. (ref0 (lambda (bv offset)
  80. (bit-field (ref bv offset) 3 8)))
  81. (ref1 (lambda (bv offset)
  82. (logior (ash (bit-field (ref bv offset) 0 3) 2)
  83. (bit-field (ref+ bv offset) 6 8))))
  84. (ref2 (lambda (bv offset)
  85. (bit-field (ref bv offset) 1 6)))
  86. (ref3 (lambda (bv offset)
  87. (logior (ash (bit-field (ref bv offset) 0 1) 4)
  88. (bit-field (ref+ bv offset) 4 8))))
  89. (ref4 (lambda (bv offset)
  90. (logior (ash (bit-field (ref bv offset) 0 4) 1)
  91. (bit-field (ref+ bv offset) 7 8))))
  92. (ref5 (lambda (bv offset)
  93. (bit-field (ref bv offset) 2 7)))
  94. (ref6 (lambda (bv offset)
  95. (logior (ash (bit-field (ref bv offset) 0 2) 3)
  96. (bit-field (ref+ bv offset) 5 8))))
  97. (ref7 (lambda (bv offset)
  98. (bit-field (ref bv offset) 0 5)))
  99. (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
  100. (lambda (bv index)
  101. "Return the INDEXth quintet of BV."
  102. (let ((p (vector-ref refs (modulo index 8))))
  103. (p bv (quotient (* index 5) 8))))))
  104. (define bytevector-quintet-ref-right
  105. (let* ((ref bytevector-u8-ref)
  106. (ref+ (lambda (bv offset)
  107. (let ((o (+ 1 offset)))
  108. (if (>= o (bytevector-length bv))
  109. 0
  110. (bytevector-u8-ref bv o)))))
  111. (ref0 (lambda (bv offset)
  112. (bit-field (ref bv offset) 0 5)))
  113. (ref1 (lambda (bv offset)
  114. (logior (bit-field (ref bv offset) 5 8)
  115. (ash (bit-field (ref+ bv offset) 0 2) 3))))
  116. (ref2 (lambda (bv offset)
  117. (bit-field (ref bv offset) 2 7)))
  118. (ref3 (lambda (bv offset)
  119. (logior (bit-field (ref bv offset) 7 8)
  120. (ash (bit-field (ref+ bv offset) 0 4) 1))))
  121. (ref4 (lambda (bv offset)
  122. (logior (bit-field (ref bv offset) 4 8)
  123. (ash (bit-field (ref+ bv offset) 0 1) 4))))
  124. (ref5 (lambda (bv offset)
  125. (bit-field (ref bv offset) 1 6)))
  126. (ref6 (lambda (bv offset)
  127. (logior (bit-field (ref bv offset) 6 8)
  128. (ash (bit-field (ref+ bv offset) 0 3) 2))))
  129. (ref7 (lambda (bv offset)
  130. (bit-field (ref bv offset) 3 8)))
  131. (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
  132. (lambda (bv index)
  133. "Return the INDEXth quintet of BV, assuming quintets start from the
  134. least-significant bits, contrary to what RFC 4648 describes."
  135. (let ((p (vector-ref refs (modulo index 8))))
  136. (p bv (quotient (* index 5) 8))))))
  137. (define (bytevector-quintet-length bv)
  138. "Return the number of quintets (including truncated ones) available in BV."
  139. (ceiling (/ (* (bytevector-length bv) 8) 5)))
  140. (define (bytevector-quintet-fold proc init bv)
  141. "Return the result of applying PROC to each quintet of BV and the result of
  142. the previous application or INIT."
  143. (define len
  144. (bytevector-quintet-length bv))
  145. (let loop ((i 0)
  146. (r init))
  147. (if (= i len)
  148. r
  149. (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
  150. (define (bytevector-quintet-fold-right proc init bv)
  151. "Return the result of applying PROC to each quintet of BV and the result of
  152. the previous application or INIT."
  153. (define len
  154. (bytevector-quintet-length bv))
  155. (let loop ((i len)
  156. (r init))
  157. (if (zero? i)
  158. r
  159. (let ((j (- i 1)))
  160. (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
  161. (define (make-bytevector->base32-string quintet-fold base32-chars)
  162. (lambda (bv)
  163. "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
  164. (let ((chars (quintet-fold (lambda (q r)
  165. (cons (vector-ref base32-chars q)
  166. r))
  167. '()
  168. bv)))
  169. (list->string (reverse chars)))))
  170. (define %nix-base32-chars
  171. ;; See `libutil/hash.cc'.
  172. #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
  173. #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
  174. #\p #\q #\r #\s #\v #\w #\x #\y #\z))
  175. (define %rfc4648-base32-chars
  176. #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
  177. #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
  178. #\2 #\3 #\4 #\5 #\6 #\7))
  179. (define bytevector->base32-string
  180. (make-bytevector->base32-string bytevector-quintet-fold
  181. %rfc4648-base32-chars))
  182. (define bytevector->nix-base32-string
  183. (make-bytevector->base32-string bytevector-quintet-fold-right
  184. %nix-base32-chars))
  185. (define bytevector-quintet-set!
  186. (let* ((setq! (lambda (bv offset start stop value)
  187. (let ((v (bytevector-u8-ref bv offset))
  188. (w (arithmetic-shift value start))
  189. (m (bitwise-xor (1- (expt 2 stop))
  190. (1- (expt 2 start)))))
  191. (bytevector-u8-set! bv offset
  192. (bitwise-merge m w v)))))
  193. (set0! (lambda (bv offset value)
  194. (setq! bv offset 3 8 value)))
  195. (set1! (lambda (bv offset value)
  196. (setq! bv offset 0 3 (bit-field value 2 5))
  197. (or (= (+ 1 offset) (bytevector-length bv))
  198. (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
  199. (set2! (lambda (bv offset value)
  200. (setq! bv offset 1 6 value)))
  201. (set3! (lambda (bv offset value)
  202. (setq! bv offset 0 1 (bit-field value 4 5))
  203. (or (= (+ 1 offset) (bytevector-length bv))
  204. (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
  205. (set4! (lambda (bv offset value)
  206. (setq! bv offset 0 4 (bit-field value 1 5))
  207. (or (= (+ 1 offset) (bytevector-length bv))
  208. (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1)))))
  209. (set5! (lambda (bv offset value)
  210. (setq! bv offset 2 7 value)))
  211. (set6! (lambda (bv offset value)
  212. (setq! bv offset 0 2 (bit-field value 3 5))
  213. (or (= (+ 1 offset) (bytevector-length bv))
  214. (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
  215. (set7! (lambda (bv offset value)
  216. (setq! bv offset 0 5 value)))
  217. (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
  218. (lambda (bv index value)
  219. "Set the INDEXth quintet of BV to VALUE."
  220. (let ((p (vector-ref sets (modulo index 8))))
  221. (p bv (quotient (* index 5) 8) (logand value #x1f))))))
  222. (define bytevector-quintet-set-right!
  223. (let* ((setq! (lambda (bv offset start stop value)
  224. (let ((v (bytevector-u8-ref bv offset))
  225. (w (arithmetic-shift value start))
  226. (m (bitwise-xor (1- (expt 2 stop))
  227. (1- (expt 2 start)))))
  228. (bytevector-u8-set! bv offset
  229. (bitwise-merge m w v)))))
  230. (set0! (lambda (bv offset value)
  231. (setq! bv offset 0 5 value)))
  232. (set1! (lambda (bv offset value)
  233. (setq! bv offset 5 8 (bit-field value 0 3))
  234. (or (= (+ 1 offset) (bytevector-length bv))
  235. (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
  236. (set2! (lambda (bv offset value)
  237. (setq! bv offset 2 7 value)))
  238. (set3! (lambda (bv offset value)
  239. (setq! bv offset 7 8 (bit-field value 0 1))
  240. (or (= (+ 1 offset) (bytevector-length bv))
  241. (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
  242. (set4! (lambda (bv offset value)
  243. (setq! bv offset 4 8 (bit-field value 0 4))
  244. (or (= (+ 1 offset) (bytevector-length bv))
  245. (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
  246. (set5! (lambda (bv offset value)
  247. (setq! bv offset 1 6 value)))
  248. (set6! (lambda (bv offset value)
  249. (setq! bv offset 6 8 (bit-field value 0 2))
  250. (or (= (+ 1 offset) (bytevector-length bv))
  251. (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
  252. (set7! (lambda (bv offset value)
  253. (setq! bv offset 3 8 value)))
  254. (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
  255. (lambda (bv index value)
  256. "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
  257. the least-significant bits."
  258. (let ((p (vector-ref sets (modulo index 8))))
  259. (p bv (quotient (* index 5) 8) (logand value #x1f))))))
  260. (define (base32-string-unfold f s)
  261. "Given procedure F which, when applied to a character, returns the
  262. corresponding quintet, return the bytevector corresponding to string S."
  263. (define len (string-length s))
  264. (let ((bv (make-bytevector (quotient (* len 5) 8))))
  265. (string-fold (lambda (chr index)
  266. (bytevector-quintet-set! bv index (f chr))
  267. (+ 1 index))
  268. 0
  269. s)
  270. bv))
  271. (define (base32-string-unfold-right f s)
  272. "Given procedure F which, when applied to a character, returns the
  273. corresponding quintet, return the bytevector corresponding to string S,
  274. starting from the right of S."
  275. (define len (string-length s))
  276. (let ((bv (make-bytevector (quotient (* len 5) 8))))
  277. (string-fold-right (lambda (chr index)
  278. (bytevector-quintet-set-right! bv index (f chr))
  279. (+ 1 index))
  280. 0
  281. s)
  282. bv))
  283. (define (make-base32-string->bytevector base32-string-unfold base32-chars)
  284. (let ((char->value (let loop ((i 0)
  285. (v vlist-null))
  286. (if (= i (vector-length base32-chars))
  287. v
  288. (loop (+ 1 i)
  289. (vhash-consv (vector-ref base32-chars i)
  290. i v))))))
  291. (lambda (s)
  292. "Return the binary representation of base32 string S as a bytevector."
  293. (base32-string-unfold (lambda (chr)
  294. (or (and=> (vhash-assv chr char->value) cdr)
  295. (error "invalid base32 character" chr)))
  296. s))))
  297. (define base32-string->bytevector
  298. (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
  299. (define nix-base32-string->bytevector
  300. (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
  301. ;;;
  302. ;;; Base 16.
  303. ;;;
  304. (define (bytevector->base16-string bv)
  305. "Return the hexadecimal representation of BV's contents."
  306. (define len
  307. (bytevector-length bv))
  308. (let-syntax ((base16-chars (lambda (s)
  309. (syntax-case s ()
  310. (_
  311. (let ((v (list->vector
  312. (unfold (cut > <> 255)
  313. (lambda (n)
  314. (format #f "~2,'0x" n))
  315. 1+
  316. 0))))
  317. v))))))
  318. (define chars base16-chars)
  319. (let loop ((i 0)
  320. (r '()))
  321. (if (= i len)
  322. (string-concatenate-reverse r)
  323. (loop (+ 1 i)
  324. (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))
  325. (define base16-string->bytevector
  326. (let ((chars->value (fold (lambda (i r)
  327. (vhash-consv (string-ref (number->string i 16)
  328. 0)
  329. i r))
  330. vlist-null
  331. (iota 16))))
  332. (lambda (s)
  333. "Return the bytevector whose hexadecimal representation is string S."
  334. (define bv
  335. (make-bytevector (quotient (string-length s) 2) 0))
  336. (string-fold (lambda (chr i)
  337. (let ((j (quotient i 2))
  338. (v (and=> (vhash-assv chr chars->value) cdr)))
  339. (if v
  340. (if (zero? (logand i 1))
  341. (bytevector-u8-set! bv j
  342. (arithmetic-shift v 4))
  343. (let ((w (bytevector-u8-ref bv j)))
  344. (bytevector-u8-set! bv j (logior v w))))
  345. (error "invalid hexadecimal character" chr)))
  346. (+ i 1))
  347. 0
  348. s)
  349. bv)))
  350. ;;;
  351. ;;; Hash.
  352. ;;;
  353. (define %libgcrypt
  354. ;; Name of the libgcrypt shared library.
  355. (compile-time-value (or (getenv "LIBGCRYPT") "libgcrypt")))
  356. (define sha256
  357. (cond
  358. ((compile-time-value
  359. (false-if-exception (dynamic-link %libgcrypt)))
  360. ;; Using libgcrypt.
  361. (let ((hash (pointer->procedure void
  362. (dynamic-func "gcry_md_hash_buffer"
  363. (dynamic-link %libgcrypt))
  364. `(,int * * ,size_t)))
  365. (sha256 8)) ; GCRY_MD_SHA256, as of 1.5.0
  366. (lambda (bv)
  367. "Return the SHA256 of BV as a bytevector."
  368. (let ((digest (make-bytevector (/ 256 8))))
  369. (hash sha256 (bytevector->pointer digest)
  370. (bytevector->pointer bv) (bytevector-length bv))
  371. digest))))
  372. ((compile-time-value
  373. (false-if-exception (resolve-interface '(chop hash))))
  374. ;; Using libchop.
  375. (let ((bytevector-hash (@ (chop hash) bytevector-hash))
  376. (hash-method/sha256 (@ (chop hash) hash-method/sha256)))
  377. (lambda (bv)
  378. "Return the SHA256 of BV as a bytevector."
  379. (bytevector-hash hash-method/sha256 bv))))
  380. (else
  381. ;; Slow, poor programmer's implementation that uses Coreutils.
  382. (lambda (bv)
  383. "Return the SHA256 of BV as a bytevector."
  384. (let ((in (pipe))
  385. (out (pipe))
  386. (pid (primitive-fork)))
  387. (if (= 0 pid)
  388. (begin ; child
  389. (close (cdr in))
  390. (close (car out))
  391. (close 0)
  392. (close 1)
  393. (dup2 (fileno (car in)) 0)
  394. (dup2 (fileno (cdr out)) 1)
  395. (execlp "sha256sum" "sha256sum"))
  396. (begin ; parent
  397. (close (car in))
  398. (close (cdr out))
  399. (put-bytevector (cdr in) bv)
  400. (close (cdr in)) ; EOF
  401. (let ((line (car (string-tokenize (read-line (car out))))))
  402. (close (car out))
  403. (and (and=> (status:exit-val (cdr (waitpid pid)))
  404. zero?)
  405. (base16-string->bytevector line))))))))))
  406. ;;;
  407. ;;; Nixpkgs.
  408. ;;;
  409. (define %nixpkgs-directory
  410. (make-parameter
  411. ;; Capture the build-time value of $NIXPKGS.
  412. (or (compile-time-value (getenv "NIXPKGS"))
  413. (getenv "NIXPKGS"))))
  414. (define* (nixpkgs-derivation attribute #:optional (system (%current-system)))
  415. "Return the derivation path of ATTRIBUTE in Nixpkgs."
  416. (let* ((p (open-pipe* OPEN_READ (or (getenv "NIX_INSTANTIATE")
  417. "nix-instantiate")
  418. "-A" attribute (%nixpkgs-directory)
  419. "--argstr" "system" system))
  420. (l (read-line p))
  421. (s (close-pipe p)))
  422. (and (zero? (status:exit-val s))
  423. (not (eof-object? l))
  424. l)))
  425. (define-syntax-rule (nixpkgs-derivation* attribute)
  426. "Evaluate the given Nixpkgs derivation at compile-time."
  427. (compile-time-value (nixpkgs-derivation attribute)))
  428. ;;;
  429. ;;; Miscellaneous.
  430. ;;;
  431. (define-syntax define-record-type*
  432. (lambda (s)
  433. "Define the given record type such that an additional \"syntactic
  434. constructor\" is defined, which allows instances to be constructed with named
  435. field initializers, à la SRFI-35, as well as default values."
  436. (define (make-syntactic-constructor type name ctor fields defaults)
  437. "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
  438. expects all of FIELDS to be initialized. DEFAULTS is the list of
  439. FIELD/DEFAULT-VALUE tuples."
  440. (with-syntax ((type type)
  441. (name name)
  442. (ctor ctor)
  443. (expected fields)
  444. (defaults defaults))
  445. #`(define-syntax name
  446. (lambda (s)
  447. (define (record-inheritance orig-record field+value)
  448. ;; Produce code that returns a record identical to
  449. ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
  450. ;; prevail.
  451. (define (field-inherited-value f)
  452. (and=> (find (lambda (x)
  453. (eq? f (car (syntax->datum x))))
  454. field+value)
  455. car))
  456. #`(make-struct type 0
  457. #,@(map (lambda (field index)
  458. (or (field-inherited-value field)
  459. #`(struct-ref #,orig-record
  460. #,index)))
  461. 'expected
  462. (iota (length 'expected)))))
  463. (syntax-case s (inherit #,@fields)
  464. ((_ (inherit orig-record) (field value) (... ...))
  465. #`(letrec* ((field value) (... ...))
  466. #,(record-inheritance #'orig-record
  467. #'((field value) (... ...)))))
  468. ((_ (field value) (... ...))
  469. (let ((fields (map syntax->datum #'(field (... ...))))
  470. (dflt (map (match-lambda
  471. ((f v)
  472. (list (syntax->datum f) v)))
  473. #'defaults)))
  474. (define (field-value f)
  475. (or (and=> (find (lambda (x)
  476. (eq? f (car (syntax->datum x))))
  477. #'((field value) (... ...)))
  478. car)
  479. (car (assoc-ref dflt (syntax->datum f)))))
  480. (let-syntax ((error*
  481. (syntax-rules ()
  482. ((_ fmt args (... ...))
  483. (syntax-violation 'name
  484. (format #f fmt args
  485. (... ...))
  486. s)))))
  487. (let ((fields (append fields (map car dflt))))
  488. (cond ((lset= eq? fields 'expected)
  489. #`(letrec* ((field value) (... ...))
  490. (ctor #,@(map field-value 'expected))))
  491. ((pair? (lset-difference eq? fields 'expected))
  492. (error* "extraneous field initializers ~a"
  493. (lset-difference eq? fields 'expected)))
  494. (else
  495. (error* "missing field initializers ~a"
  496. (lset-difference eq? 'expected
  497. fields)))))))))))))
  498. (define (field-default-value s)
  499. (syntax-case s (default)
  500. ((field (default val) _ ...)
  501. (list #'field #'val))
  502. ((field _ options ...)
  503. (field-default-value #'(field options ...)))
  504. (_ #f)))
  505. (syntax-case s ()
  506. ((_ type syntactic-ctor ctor pred
  507. (field get options ...) ...)
  508. #`(begin
  509. (define-record-type type
  510. (ctor field ...)
  511. pred
  512. (field get) ...)
  513. #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
  514. #'(field ...)
  515. (filter-map field-default-value
  516. #'((field options ...)
  517. ...))))))))
  518. (define (memoize proc)
  519. "Return a memoizing version of PROC."
  520. (let ((cache (make-hash-table)))
  521. (lambda args
  522. (let ((results (hash-ref cache args)))
  523. (if results
  524. (apply values results)
  525. (let ((results (call-with-values (lambda ()
  526. (apply proc args))
  527. list)))
  528. (hash-set! cache args results)
  529. (apply values results)))))))
  530. (define (gnu-triplet->nix-system triplet)
  531. "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
  532. returned by `config.guess'."
  533. (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
  534. =>
  535. (lambda (m)
  536. (string-append "i686-" (match:substring m 1))))
  537. (else triplet))))
  538. (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
  539. =>
  540. (lambda (m)
  541. ;; Nix omits `-gnu' for GNU/Linux.
  542. (string-append (match:substring m 1) "-linux")))
  543. ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
  544. =>
  545. (lambda (m)
  546. ;; Nix strip the version number from names such as `gnu0.3',
  547. ;; `darwin10.2.0', etc., and always strips the vendor part.
  548. (string-append (match:substring m 1) "-"
  549. (match:substring m 3))))
  550. (else triplet))))
  551. (define %current-system
  552. ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
  553. (make-parameter (gnu-triplet->nix-system %host-type)))
  554. ;;;
  555. ;;; Source location.
  556. ;;;
  557. ;; A source location.
  558. (define-record-type <location>
  559. (make-location file line column)
  560. location?
  561. (file location-file) ; file name
  562. (line location-line) ; 1-indexed line
  563. (column location-column)) ; 0-indexed column
  564. (define location
  565. (memoize
  566. (lambda (file line column)
  567. "Return the <location> object for the given FILE, LINE, and COLUMN."
  568. (and line column file
  569. (make-location file line column)))))
  570. (define (source-properties->location loc)
  571. "Return a location object based on the info in LOC, an alist as returned
  572. by Guile's `source-properties', `frame-source', `current-source-location',
  573. etc."
  574. (let ((file (assq-ref loc 'filename))
  575. (line (assq-ref loc 'line))
  576. (col (assq-ref loc 'column)))
  577. ;; In accordance with the GCS, start line and column numbers at 1.
  578. (location file (and line (+ line 1)) (and col (+ col 1)))))