scheme48 1.9-5 / usr / share / scheme48-1.9 / big / mask.scm

This file is indexed.

/usr/share/scheme48-1.9/big/mask.scm is in scheme48 1.9-5.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
; Part of Scheme 48 1.9.  See file COPYING for notices and license.

; Authors: Richard Kelsey, Jonathan Rees, Robert Ransom

; Boxed bit-masks.

; Mask-type operations
;  (make-mask-type name thing? int->thing thing->int size) -> mask-type
;  (mask-type? x) -> boolean
;
; Internal operations
;  (mask? x)
;  (mask-type mask)
;  (mask-has-type? mask mask-type)
;  (integer->mask mask-type integer)
;  (list->mask mask-type list)
;
; Generic operations
;  (mask->integer mask)
;  (mask->list mask) -> things
;  (mask-member? mask x)
;  (mask-set mask . things)
;  (mask-clear mask . things)
;  (mask-union ...)
;  (mask-intersection ...)
;  (mask-subtract x y)

; Mask-types 

(define-record-type mask-type :mask-type
  (make-mask-type name element? integer->element element->integer size)
  mask-type?
  (name mask-type-name)
  (element? mask-type-element?)
  (integer->element mask-type-integer->element)
  (element->integer mask-type-element->integer)
  (size mask-type-size))
  
(define-record-discloser :mask-type
  (lambda (mt)
    (list 'mask-type (mask-type-name mt))))

; Masks - the type and an integer representing the contents.

(define-record-type mask :mask
  (make-mask type contents)
  mask?
  (type mask-type)
  (contents mask->integer))

(define-record-discloser :mask
  (lambda (m)
    (list (mask-type-name (mask-type m))
	  (string-append "#x"
			 (number->string (mask->integer m) 16)))))

(define (mask-has-type? mask type)
  (if (mask-type? type)
      (eq? (mask-type mask)
	   type)
      (assertion-violation 'mask-has-type? "argument is not a mask"
			   mask type)))

(define (integer->mask type integer)
  (if (and (mask-type? type)
	   (integer? integer)
	   (<= 0 integer))	; no infinite masks
      (make-mask type integer)
      (assertion-violation 'integer->mask "argument type error"
			   type integer)))

(define (list->mask type things)
  (make-mask type (list->integer type things)))

(define (list->integer type things)
  (let ((elt->int (mask-type-element->integer type)))
    (do ((things things (cdr things))
	 (m 0 (bitwise-ior m (arithmetic-shift 1 (elt->int (car things))))))
	((null? things)
	 m))))
		    
; Return a list of the elements of the mask.  This would be faster for bignums
; if we broke off fixnum-sized chunks.

(define (mask->list mask)
  (let ((int->elt (mask-type-integer->element (mask-type mask))))
    (do ((mask (mask->integer mask) (arithmetic-shift mask -1))
	 (i 0 (+ i 1))
	 (elts '() (if (odd? mask)
		       (cons (int->elt i) elts)
		       elts)))
	((= 0 mask)
	 (reverse elts)))))

;----------------
; Operations on masks

(define (mask-member? mask thing)
  (not (= 0 (bitwise-and (mask->integer mask)
			 (arithmetic-shift 1
					   ((mask-type-element->integer
					     (mask-type mask))
					    thing))))))

(define (mask-set mask . things)
  (if (null? things)
      mask
      (make-mask (mask-type mask)
		 (bitwise-ior (mask->integer mask)
			      (list->integer (mask-type mask)
					     things)))))

(define (mask-clear mask . things)
  (if (null? things)
      mask
      (make-mask (mask-type mask)
		 (bitwise-and (mask->integer mask)
			      (bitwise-not (list->integer (mask-type mask)
							  things))))))
; Union and intersection

(define (mask-union mask . more-masks)
  (mask-binop mask more-masks bitwise-ior 'mask-union))

(define (mask-intersection mask . more-masks)
  (mask-binop mask more-masks bitwise-and 'mask-intersection))

(define (mask-binop mask more-masks bitwise-op mask-op)
  (if (and (mask? mask)
	   (let ((type (mask-type mask)))
	     (every (lambda (mask)
		      (and (mask? mask)
			   (eq? (mask-type mask) type)))
		    more-masks)))
      (make-mask (mask-type mask)
		 (apply bitwise-op
			(mask->integer mask)
			(map mask->integer more-masks)))
      (apply assertion-violation mask-op "argument is not a mask" mask more-masks)))
			
; Subtraction

(define (mask-subtract x y)
  (if (and (mask? x)
	   (mask? y)
	   (eq? (mask-type x)
		(mask-type y)))
      (make-mask (mask-type x)
		 (bitwise-and (mask->integer x)
			      (bitwise-not (mask->integer y))))
      (assertion-violation 'mask-subtract "invalid arguments" x y)))

; Negation
; This is legal only for masks with a size limit.

(define (mask-negate mask)
  (if (and (mask? mask)
	   (mask-type-size (mask-type mask)))
      (let ((type (mask-type mask)))
	(make-mask type
		   (bitwise-and (bitwise-not (mask->integer mask))
				(- (arithmetic-shift 1 (mask-type-size type))
				   1))))
      (assertion-violation 'mask-negate "invalid mask" mask)))

APT Browse - Built by Thomas Orozco.