mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

intmaps and intsets print with abbreviated key ranges

Browse source 
* module/language/cps/intset.scm (intset-key-ranges, range-string):
  (print-helper, print-intset, print-transient-intset): New helpers.
  Install as intset printers.
* module/language/cps/intmap.scm (intmap-key-ranges, range-string):
  (print-helper): New helpers.
  (print-intmap, print-transient-intmap): Call the new helpers.
This commit is contained in:
Andy Wingo 2015-05-19 10:19:02 +02:00
parent 1403df4140
commit 102e677b98
2 changed files with 79 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/language/cps/intmap.scm
View file

@ -629,10 +629,44 @@
(define (intmap->alist intmap)
(reverse (intmap-fold acons intmap '())))
(define (intmap-key-ranges intmap)
(call-with-values
(lambda ()
(intmap-fold (lambda (k v start end closed)
(cond
((not start) (values k k closed))
((= k (1+ end)) (values start k closed))
(else (values k k (acons start end closed)))))
intmap #f #f '()))
(lambda (start end closed)
(reverse (if start (acons start end closed) closed)))))
(define (range-string ranges)
(string-join (map (match-lambda
((start . start)
(format #f "~a" start))
((start . end)
(format #f "~a-~a" start end)))
ranges)
","))
(define (print-helper port tag intmap)
(let ((ranges (intmap-key-ranges intmap)))
(match ranges
(()
(format port "#<~a>" tag))
(((0 . _) . _)
(format port "#<~a ~a>" tag (range-string ranges)))
(((min . end) . ranges)
(let ((ranges (map (match-lambda
((start . end) (cons (- start min) (- end min))))
(acons min end ranges))))
(format port "#<~a ~a+~a>" tag min (range-string ranges)))))))
(define (print-intmap intmap port)
(format port "#<intmap ~a>" (intmap->alist intmap)))
(print-helper port "intmap" intmap))
(define (print-transient-intmap intmap port)
(format port "#<transient-intmap ~a>" (intmap->alist intmap)))
(print-helper port "transient-intmap" intmap))
(set-record-type-printer! <intmap> print-intmap)
(set-record-type-printer! <transient-intmap> print-transient-intmap)

43
module/language/cps/intset.scm
View file

@ -27,6 +27,7 @@
(define-module (language cps intset)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
#:export (empty-intset
intset?
@ -731,3 +732,45 @@
(let ((min* (round-down pos *leaf-bits*)))
(lp (finish-tail out min tail)
min* pos (ash 1 (- pos min*)))))))))
(define (intset-key-ranges intset)
(call-with-values
(lambda ()
(intset-fold (lambda (k start end closed)
(cond
((not start) (values k k closed))
((= k (1+ end)) (values start k closed))
(else (values k k (acons start end closed)))))
intset #f #f '()))
(lambda (start end closed)
(reverse (if start (acons start end closed) closed)))))
(define (range-string ranges)
(string-join (map (match-lambda
((start . start)
(format #f "~a" start))
((start . end)
(format #f "~a-~a" start end)))
ranges)
","))
(define (print-helper port tag intset)
(let ((ranges (intset-key-ranges intset)))
(match ranges
(()
(format port "#<~a>" tag))
(((0 . _) . _)
(format port "#<~a ~a>" tag (range-string ranges)))
(((min . end) . ranges)
(let ((ranges (map (match-lambda
((start . end) (cons (- start min) (- end min))))
(acons min end ranges))))
(format port "#<~a ~a+~a>" tag min (range-string ranges)))))))
(define (print-intset intset port)
(print-helper port "intset" intset))
(define (print-transient-intset intset port)
(print-helper port "transient-intset" intset))
(set-record-type-printer! <intset> print-intset)
(set-record-type-printer! <transient-intset> print-transient-intset)