mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 08:20:20 +02:00
Code Activity

Default "meet" operator is meet-error for intmap

Browse source 
* module/language/cps/intmap.scm (meet-error): New helper.
  (intmap-add, intmap-union, intmap-intersect): The "meet" argument is
  optional and defaults to meet-error.
This commit is contained in:
Andy Wingo 2015-03-26 13:32:46 +01:00
parent 50fcdfece3
commit 33ab2838de
1 changed files with 7 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;; Functional name maps ;;; Functional name maps
;;; Copyright (C) 2014 Free Software Foundation, Inc. ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software: you can redistribute it and/or modify ;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as ;;; it under the terms of the GNU Lesser General Public License as
@ -102,7 +102,10 @@
;; Shouldn't be reached... ;; Shouldn't be reached...
(else empty-intmap))))) (else empty-intmap)))))
(define (intmap-add bs i val meet) (define (meet-error old new)
(error "Multiple differing values and no meet procedure defined" old new))
(define* (intmap-add bs i val #:optional (meet meet-error))
(define (adjoin i shift root) (define (adjoin i shift root)
(cond (cond
((zero? shift) ((zero? shift)
@ -209,7 +212,7 @@
(let ((i (visit-node root shift i))) (let ((i (visit-node root shift i)))
(and i (+ min i)))))))) (and i (+ min i))))))))
(define (intmap-union a b meet) (define* (intmap-union a b #:optional (meet meet-error))
;; Union A and B from index I; the result will be fresh. ;; Union A and B from index I; the result will be fresh.
(define (union-branches/fresh shift a b i fresh) (define (union-branches/fresh shift a b i fresh)
(let lp ((i 0)) (let lp ((i 0))
@ -288,7 +291,7 @@
((eq? root b-root) b) ((eq? root b-root) b)
(else (make-intmap a-min a-shift root))))))))) (else (make-intmap a-min a-shift root)))))))))
(define (intmap-intersect a b meet) (define* (intmap-intersect a b #:optional (meet meet-error))
;; Intersect A and B from index I; the result will be fresh. ;; Intersect A and B from index I; the result will be fresh.
(define (intersect-branches/fresh shift a b i fresh) (define (intersect-branches/fresh shift a b i fresh)
(let lp ((i 0)) (let lp ((i 0))