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.
 
 
 
 
 
 

716 lines
26 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
  4. ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix utils)
  21. #:use-module (guix config)
  22. #:use-module (srfi srfi-1)
  23. #:use-module (srfi srfi-9)
  24. #:use-module (srfi srfi-11)
  25. #:use-module (srfi srfi-26)
  26. #:use-module (srfi srfi-39)
  27. #:use-module (srfi srfi-60)
  28. #:use-module (rnrs bytevectors)
  29. #:use-module ((rnrs io ports) #:select (put-bytevector))
  30. #:use-module ((guix build utils) #:select (dump-port))
  31. #:use-module ((guix build syscalls) #:select (errno))
  32. #:use-module (ice-9 vlist)
  33. #:use-module (ice-9 format)
  34. #:autoload (ice-9 popen) (open-pipe*)
  35. #:autoload (ice-9 rdelim) (read-line)
  36. #:use-module (ice-9 regex)
  37. #:use-module (ice-9 match)
  38. #:use-module (ice-9 format)
  39. #:use-module (system foreign)
  40. #:export (bytevector->base16-string
  41. base16-string->bytevector
  42. %nixpkgs-directory
  43. nixpkgs-derivation
  44. nixpkgs-derivation*
  45. compile-time-value
  46. fcntl-flock
  47. memoize
  48. default-keyword-arguments
  49. substitute-keyword-arguments
  50. <location>
  51. location
  52. location?
  53. location-file
  54. location-line
  55. location-column
  56. source-properties->location
  57. gnu-triplet->nix-system
  58. %current-system
  59. %current-target-system
  60. version-compare
  61. version>?
  62. guile-version>?
  63. package-name->name+version
  64. string-tokenize*
  65. string-replace-substring
  66. file-extension
  67. file-sans-extension
  68. call-with-temporary-output-file
  69. with-atomic-file-output
  70. fold2
  71. fold-tree
  72. fold-tree-leaves
  73. filtered-port
  74. compressed-port
  75. decompressed-port
  76. call-with-decompressed-port
  77. compressed-output-port
  78. call-with-compressed-output-port))
  79. ;;;
  80. ;;; Compile-time computations.
  81. ;;;
  82. (define-syntax compile-time-value
  83. (syntax-rules ()
  84. "Evaluate the given expression at compile time. The expression must
  85. evaluate to a simple datum."
  86. ((_ exp)
  87. (let-syntax ((v (lambda (s)
  88. (let ((val exp))
  89. (syntax-case s ()
  90. (_ #`'#,(datum->syntax s val)))))))
  91. v))))
  92. ;;;
  93. ;;; Base 16.
  94. ;;;
  95. (define (bytevector->base16-string bv)
  96. "Return the hexadecimal representation of BV's contents."
  97. (define len
  98. (bytevector-length bv))
  99. (let-syntax ((base16-chars (lambda (s)
  100. (syntax-case s ()
  101. (_
  102. (let ((v (list->vector
  103. (unfold (cut > <> 255)
  104. (lambda (n)
  105. (format #f "~2,'0x" n))
  106. 1+
  107. 0))))
  108. v))))))
  109. (define chars base16-chars)
  110. (let loop ((i 0)
  111. (r '()))
  112. (if (= i len)
  113. (string-concatenate-reverse r)
  114. (loop (+ 1 i)
  115. (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))
  116. (define base16-string->bytevector
  117. (let ((chars->value (fold (lambda (i r)
  118. (vhash-consv (string-ref (number->string i 16)
  119. 0)
  120. i r))
  121. vlist-null
  122. (iota 16))))
  123. (lambda (s)
  124. "Return the bytevector whose hexadecimal representation is string S."
  125. (define bv
  126. (make-bytevector (quotient (string-length s) 2) 0))
  127. (string-fold (lambda (chr i)
  128. (let ((j (quotient i 2))
  129. (v (and=> (vhash-assv chr chars->value) cdr)))
  130. (if v
  131. (if (zero? (logand i 1))
  132. (bytevector-u8-set! bv j
  133. (arithmetic-shift v 4))
  134. (let ((w (bytevector-u8-ref bv j)))
  135. (bytevector-u8-set! bv j (logior v w))))
  136. (error "invalid hexadecimal character" chr)))
  137. (+ i 1))
  138. 0
  139. s)
  140. bv)))
  141. ;;;
  142. ;;; Filtering & pipes.
  143. ;;;
  144. (define (filtered-port command input)
  145. "Return an input port where data drained from INPUT is filtered through
  146. COMMAND (a list). In addition, return a list of PIDs that the caller must
  147. wait. When INPUT is a file port, it must be unbuffered; otherwise, any
  148. buffered data is lost."
  149. (let loop ((input input)
  150. (pids '()))
  151. (if (file-port? input)
  152. (match (pipe)
  153. ((in . out)
  154. (match (primitive-fork)
  155. (0
  156. (dynamic-wind
  157. (const #f)
  158. (lambda ()
  159. (close-port in)
  160. (close-port (current-input-port))
  161. (dup2 (fileno input) 0)
  162. (close-port (current-output-port))
  163. (dup2 (fileno out) 1)
  164. (catch 'system-error
  165. (lambda ()
  166. (apply execl (car command) command))
  167. (lambda args
  168. (format (current-error-port)
  169. "filtered-port: failed to execute '~{~a ~}': ~a~%"
  170. command (strerror (system-error-errno args))))))
  171. (lambda ()
  172. (primitive-_exit 1))))
  173. (child
  174. (close-port out)
  175. (values in (cons child pids))))))
  176. ;; INPUT is not a file port, so fork just for the sake of tunneling it
  177. ;; through a file port.
  178. (match (pipe)
  179. ((in . out)
  180. (match (primitive-fork)
  181. (0
  182. (dynamic-wind
  183. (const #t)
  184. (lambda ()
  185. (close-port in)
  186. (dump-port input out))
  187. (lambda ()
  188. (false-if-exception (close out))
  189. (primitive-_exit 0))))
  190. (child
  191. (close-port out)
  192. (loop in (cons child pids)))))))))
  193. (define (decompressed-port compression input)
  194. "Return an input port where INPUT is decompressed according to COMPRESSION,
  195. a symbol such as 'xz."
  196. (match compression
  197. ((or #f 'none) (values input '()))
  198. ('bzip2 (filtered-port `(,%bzip2 "-dc") input))
  199. ('xz (filtered-port `(,%xz "-dc") input))
  200. ('gzip (filtered-port `(,%gzip "-dc") input))
  201. (else (error "unsupported compression scheme" compression))))
  202. (define (compressed-port compression input)
  203. "Return an input port where INPUT is decompressed according to COMPRESSION,
  204. a symbol such as 'xz."
  205. (match compression
  206. ((or #f 'none) (values input '()))
  207. ('bzip2 (filtered-port `(,%bzip2 "-c") input))
  208. ('xz (filtered-port `(,%xz "-c") input))
  209. ('gzip (filtered-port `(,%gzip "-c") input))
  210. (else (error "unsupported compression scheme" compression))))
  211. (define (call-with-decompressed-port compression port proc)
  212. "Call PROC with a wrapper around PORT, a file port, that decompresses data
  213. read from PORT according to COMPRESSION, a symbol such as 'xz."
  214. (let-values (((decompressed pids)
  215. (decompressed-port compression port)))
  216. (dynamic-wind
  217. (const #f)
  218. (lambda ()
  219. (proc decompressed))
  220. (lambda ()
  221. (close-port decompressed)
  222. (unless (every (compose zero? cdr waitpid) pids)
  223. (error "decompressed-port failure" pids))))))
  224. (define (filtered-output-port command output)
  225. "Return an output port. Data written to that port is filtered through
  226. COMMAND and written to OUTPUT, an output file port. In addition, return a
  227. list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered
  228. data is lost."
  229. (match (pipe)
  230. ((in . out)
  231. (match (primitive-fork)
  232. (0
  233. (dynamic-wind
  234. (const #f)
  235. (lambda ()
  236. (close-port out)
  237. (close-port (current-input-port))
  238. (dup2 (fileno in) 0)
  239. (close-port (current-output-port))
  240. (dup2 (fileno output) 1)
  241. (catch 'system-error
  242. (lambda ()
  243. (apply execl (car command) command))
  244. (lambda args
  245. (format (current-error-port)
  246. "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
  247. command (strerror (system-error-errno args))))))
  248. (lambda ()
  249. (primitive-_exit 1))))
  250. (child
  251. (close-port in)
  252. (values out (list child)))))))
  253. (define (compressed-output-port compression output)
  254. "Return an output port whose input is compressed according to COMPRESSION,
  255. a symbol such as 'xz, and then written to OUTPUT. In addition return a list
  256. of PIDs to wait for."
  257. (match compression
  258. ((or #f 'none) (values output '()))
  259. ('bzip2 (filtered-output-port `(,%bzip2 "-c") output))
  260. ('xz (filtered-output-port `(,%xz "-c") output))
  261. ('gzip (filtered-output-port `(,%gzip "-c") output))
  262. (else (error "unsupported compression scheme" compression))))
  263. (define (call-with-compressed-output-port compression port proc)
  264. "Call PROC with a wrapper around PORT, a file port, that compresses data
  265. that goes to PORT according to COMPRESSION, a symbol such as 'xz."
  266. (let-values (((compressed pids)
  267. (compressed-output-port compression port)))
  268. (dynamic-wind
  269. (const #f)
  270. (lambda ()
  271. (proc compressed))
  272. (lambda ()
  273. (close-port compressed)
  274. (unless (every (compose zero? cdr waitpid) pids)
  275. (error "compressed-output-port failure" pids))))))
  276. ;;;
  277. ;;; Nixpkgs.
  278. ;;;
  279. (define %nixpkgs-directory
  280. (make-parameter
  281. ;; Capture the build-time value of $NIXPKGS.
  282. (or %nixpkgs
  283. (and=> (getenv "NIXPKGS")
  284. (lambda (val)
  285. ;; Bail out when passed an empty string, otherwise
  286. ;; `nix-instantiate' will sit there and attempt to read
  287. ;; from its standard input.
  288. (if (string=? val "")
  289. #f
  290. val))))))
  291. (define* (nixpkgs-derivation attribute #:optional (system (%current-system)))
  292. "Return the derivation path of ATTRIBUTE in Nixpkgs."
  293. (let* ((p (open-pipe* OPEN_READ (or (getenv "NIX_INSTANTIATE")
  294. %nix-instantiate)
  295. "-A" attribute (%nixpkgs-directory)
  296. "--argstr" "system" system))
  297. (l (read-line p))
  298. (s (close-pipe p)))
  299. (and (zero? (status:exit-val s))
  300. (not (eof-object? l))
  301. l)))
  302. (define-syntax-rule (nixpkgs-derivation* attribute)
  303. "Evaluate the given Nixpkgs derivation at compile-time."
  304. (compile-time-value (nixpkgs-derivation attribute)))
  305. ;;;
  306. ;;; Advisory file locking.
  307. ;;;
  308. (define %struct-flock
  309. ;; 'struct flock' from <fcntl.h>.
  310. (list short ; l_type
  311. short ; l_whence
  312. size_t ; l_start
  313. size_t ; l_len
  314. int)) ; l_pid
  315. (define F_SETLKW
  316. ;; On Linux-based systems, this is usually 7, but not always
  317. ;; (exceptions include SPARC.) On GNU/Hurd, it's 9.
  318. (compile-time-value
  319. (cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
  320. ((string-contains %host-type "linux") 7) ; *-linux-gnu
  321. (else 9)))) ; *-gnu*
  322. (define F_SETLK
  323. ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
  324. (compile-time-value
  325. (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
  326. ((string-contains %host-type "linux") 6) ; *-linux-gnu
  327. (else 8)))) ; *-gnu*
  328. (define F_xxLCK
  329. ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
  330. (compile-time-value
  331. (cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu
  332. ((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu
  333. ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
  334. (else #(1 2 3))))) ; *-gnu*
  335. (define fcntl-flock
  336. (let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
  337. (proc (pointer->procedure int ptr `(,int ,int *))))
  338. (lambda* (fd-or-port operation #:key (wait? #t))
  339. "Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION
  340. must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is
  341. true, block until the lock is acquired; otherwise, thrown an 'flock-error'
  342. exception if it's already taken."
  343. (define (operation->int op)
  344. (case op
  345. ((read-lock) (vector-ref F_xxLCK 0))
  346. ((write-lock) (vector-ref F_xxLCK 1))
  347. ((unlock) (vector-ref F_xxLCK 2))
  348. (else (error "invalid fcntl-flock operation" op))))
  349. (define fd
  350. (if (port? fd-or-port)
  351. (fileno fd-or-port)
  352. fd-or-port))
  353. ;; XXX: 'fcntl' is a vararg function, but here we happily use the
  354. ;; standard ABI; crossing fingers.
  355. (let ((err (proc fd
  356. (if wait?
  357. F_SETLKW ; lock & wait
  358. F_SETLK) ; non-blocking attempt
  359. (make-c-struct %struct-flock
  360. (list (operation->int operation)
  361. SEEK_SET
  362. 0 0 ; whole file
  363. 0)))))
  364. (or (zero? err)
  365. ;; Presumably we got EAGAIN or so.
  366. (throw 'flock-error (errno)))))))
  367. ;;;
  368. ;;; Miscellaneous.
  369. ;;;
  370. (define (memoize proc)
  371. "Return a memoizing version of PROC."
  372. (let ((cache (make-hash-table)))
  373. (lambda args
  374. (let ((results (hash-ref cache args)))
  375. (if results
  376. (apply values results)
  377. (let ((results (call-with-values (lambda ()
  378. (apply proc args))
  379. list)))
  380. (hash-set! cache args results)
  381. (apply values results)))))))
  382. (define (default-keyword-arguments args defaults)
  383. "Return ARGS augmented with any keyword/value from DEFAULTS for
  384. keywords not already present in ARGS."
  385. (let loop ((defaults defaults)
  386. (args args))
  387. (match defaults
  388. ((kw value rest ...)
  389. (loop rest
  390. (if (assoc-ref kw args)
  391. args
  392. (cons* kw value args))))
  393. (()
  394. args))))
  395. (define-syntax substitute-keyword-arguments
  396. (syntax-rules ()
  397. "Return a new list of arguments where the value for keyword arg KW is
  398. replaced by EXP. EXP is evaluated in a context where VAR is boud to the
  399. previous value of the keyword argument."
  400. ((_ original-args ((kw var) exp) ...)
  401. (let loop ((args original-args)
  402. (before '()))
  403. (match args
  404. ((kw var rest (... ...))
  405. (loop rest (cons* exp kw before)))
  406. ...
  407. ((x rest (... ...))
  408. (loop rest (cons x before)))
  409. (()
  410. (reverse before)))))))
  411. (define (gnu-triplet->nix-system triplet)
  412. "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
  413. returned by `config.guess'."
  414. (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
  415. =>
  416. (lambda (m)
  417. (string-append "i686-" (match:substring m 1))))
  418. (else triplet))))
  419. (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
  420. =>
  421. (lambda (m)
  422. ;; Nix omits `-gnu' for GNU/Linux.
  423. (string-append (match:substring m 1) "-linux")))
  424. ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
  425. =>
  426. (lambda (m)
  427. ;; Nix strip the version number from names such as `gnu0.3',
  428. ;; `darwin10.2.0', etc., and always strips the vendor part.
  429. (string-append (match:substring m 1) "-"
  430. (match:substring m 3))))
  431. (else triplet))))
  432. (define %current-system
  433. ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
  434. ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
  435. (make-parameter %system))
  436. (define %current-target-system
  437. ;; Either #f or a GNU triplet representing the target system we are
  438. ;; cross-building to.
  439. (make-parameter #f))
  440. (define version-compare
  441. (let ((strverscmp
  442. (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
  443. (error "could not find `strverscmp' (from GNU libc)"))))
  444. (pointer->procedure int sym (list '* '*)))))
  445. (lambda (a b)
  446. "Return '> when A denotes a newer version than B,
  447. '< when A denotes a older version than B,
  448. or '= when they denote equal versions."
  449. (let ((result (strverscmp (string->pointer a) (string->pointer b))))
  450. (cond ((positive? result) '>)
  451. ((negative? result) '<)
  452. (else '=))))))
  453. (define (version>? a b)
  454. "Return #t when A denotes a newer version than B."
  455. (eq? '> (version-compare a b)))
  456. (define (guile-version>? str)
  457. "Return #t if the running Guile version is greater than STR."
  458. ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
  459. ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
  460. (version>? (string-append (major-version) "."
  461. (minor-version) "."
  462. (micro-version))
  463. str))
  464. (define (package-name->name+version name)
  465. "Given NAME, a package name like \"foo-0.9.1b\", return two values:
  466. \"foo\" and \"0.9.1b\". When the version part is unavailable, NAME and
  467. #f are returned. The first hyphen followed by a digit is considered to
  468. introduce the version part."
  469. ;; See also `DrvName' in Nix.
  470. (define number?
  471. (cut char-set-contains? char-set:digit <>))
  472. (let loop ((chars (string->list name))
  473. (prefix '()))
  474. (match chars
  475. (()
  476. (values name #f))
  477. ((#\- (? number? n) rest ...)
  478. (values (list->string (reverse prefix))
  479. (list->string (cons n rest))))
  480. ((head tail ...)
  481. (loop tail (cons head prefix))))))
  482. (define (file-extension file)
  483. "Return the extension of FILE or #f if there is none."
  484. (let ((dot (string-rindex file #\.)))
  485. (and dot (substring file (+ 1 dot) (string-length file)))))
  486. (define (file-sans-extension file)
  487. "Return the substring of FILE without its extension, if any."
  488. (let ((dot (string-rindex file #\.)))
  489. (if dot
  490. (substring file 0 dot)
  491. file)))
  492. (define (string-tokenize* string separator)
  493. "Return the list of substrings of STRING separated by SEPARATOR. This is
  494. like `string-tokenize', but SEPARATOR is a string."
  495. (define (index string what)
  496. (let loop ((string string)
  497. (offset 0))
  498. (cond ((string-null? string)
  499. #f)
  500. ((string-prefix? what string)
  501. offset)
  502. (else
  503. (loop (string-drop string 1) (+ 1 offset))))))
  504. (define len
  505. (string-length separator))
  506. (let loop ((string string)
  507. (result '()))
  508. (cond ((index string separator)
  509. =>
  510. (lambda (offset)
  511. (loop (string-drop string (+ offset len))
  512. (cons (substring string 0 offset)
  513. result))))
  514. (else
  515. (reverse (cons string result))))))
  516. (define* (string-replace-substring str substr replacement
  517. #:optional
  518. (start 0)
  519. (end (string-length str)))
  520. "Replace all occurrences of SUBSTR in the START--END range of STR by
  521. REPLACEMENT."
  522. (match (string-length substr)
  523. (0
  524. (error "string-replace-substring: empty substring"))
  525. (substr-length
  526. (let loop ((start start)
  527. (pieces (list (substring str 0 start))))
  528. (match (string-contains str substr start end)
  529. (#f
  530. (string-concatenate-reverse
  531. (cons (substring str start) pieces)))
  532. (index
  533. (loop (+ index substr-length)
  534. (cons* replacement
  535. (substring str start index)
  536. pieces))))))))
  537. (define (call-with-temporary-output-file proc)
  538. "Call PROC with a name of a temporary file and open output port to that
  539. file; close the file and delete it when leaving the dynamic extent of this
  540. call."
  541. (let* ((directory (or (getenv "TMPDIR") "/tmp"))
  542. (template (string-append directory "/guix-file.XXXXXX"))
  543. (out (mkstemp! template)))
  544. (dynamic-wind
  545. (lambda ()
  546. #t)
  547. (lambda ()
  548. (proc template out))
  549. (lambda ()
  550. (false-if-exception (close out))
  551. (false-if-exception (delete-file template))))))
  552. (define (with-atomic-file-output file proc)
  553. "Call PROC with an output port for the file that is going to replace FILE.
  554. Upon success, FILE is atomically replaced by what has been written to the
  555. output port, and PROC's result is returned."
  556. (let* ((template (string-append file ".XXXXXX"))
  557. (out (mkstemp! template)))
  558. (with-throw-handler #t
  559. (lambda ()
  560. (let ((result (proc out)))
  561. (close out)
  562. (rename-file template file)
  563. result))
  564. (lambda (key . args)
  565. (false-if-exception (delete-file template))))))
  566. (define fold2
  567. (case-lambda
  568. ((proc seed1 seed2 lst)
  569. "Like `fold', but with a single list and two seeds."
  570. (let loop ((result1 seed1)
  571. (result2 seed2)
  572. (lst lst))
  573. (if (null? lst)
  574. (values result1 result2)
  575. (call-with-values
  576. (lambda () (proc (car lst) result1 result2))
  577. (lambda (result1 result2)
  578. (loop result1 result2 (cdr lst)))))))
  579. ((proc seed1 seed2 lst1 lst2)
  580. "Like `fold', but with a two lists and two seeds."
  581. (let loop ((result1 seed1)
  582. (result2 seed2)
  583. (lst1 lst1)
  584. (lst2 lst2))
  585. (if (or (null? lst1) (null? lst2))
  586. (values result1 result2)
  587. (call-with-values
  588. (lambda () (proc (car lst1) (car lst2) result1 result2))
  589. (lambda (result1 result2)
  590. (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
  591. (define (fold-tree proc init children roots)
  592. "Call (PROC NODE RESULT) for each node in the tree that is reachable from
  593. ROOTS, using INIT as the initial value of RESULT. The order in which nodes
  594. are traversed is not specified, however, each node is visited only once, based
  595. on an eq? check. Children of a node to be visited are generated by
  596. calling (CHILDREN NODE), the result of which should be a list of nodes that
  597. are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
  598. (let loop ((result init)
  599. (seen vlist-null)
  600. (lst roots))
  601. (match lst
  602. (() result)
  603. ((head . tail)
  604. (if (not (vhash-assq head seen))
  605. (loop (proc head result)
  606. (vhash-consq head #t seen)
  607. (match (children head)
  608. ((or () #f) tail)
  609. (children (append tail children))))
  610. (loop result seen tail))))))
  611. (define (fold-tree-leaves proc init children roots)
  612. "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
  613. (fold-tree
  614. (lambda (node result)
  615. (match (children node)
  616. ((or () #f) (proc node result))
  617. (else result)))
  618. init children roots))
  619. ;;;
  620. ;;; Source location.
  621. ;;;
  622. ;; A source location.
  623. (define-record-type <location>
  624. (make-location file line column)
  625. location?
  626. (file location-file) ; file name
  627. (line location-line) ; 1-indexed line
  628. (column location-column)) ; 0-indexed column
  629. (define location
  630. (memoize
  631. (lambda (file line column)
  632. "Return the <location> object for the given FILE, LINE, and COLUMN."
  633. (and line column file
  634. (make-location file line column)))))
  635. (define (source-properties->location loc)
  636. "Return a location object based on the info in LOC, an alist as returned
  637. by Guile's `source-properties', `frame-source', `current-source-location',
  638. etc."
  639. (let ((file (assq-ref loc 'filename))
  640. (line (assq-ref loc 'line))
  641. (col (assq-ref loc 'column)))
  642. ;; In accordance with the GCS, start line and column numbers at 1. Note
  643. ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
  644. (location file (and line (+ line 1)) col)))