/
util.rkt
106 lines (95 loc) · 3.26 KB
/
util.rkt
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
#lang typed/racket
(provide define-stxparams
set!
parameterize-syntax-ids
define-maskers
has-any-flag?
copy-bits
)
(require racket/stxparam
"ufx.rkt"
(for-syntax racket/fixnum))
(define-syntax-rule (define-stxparams #:errmsg msg id ...)
(begin
(define-syntax-parameter id
(lambda (stx)
(raise-syntax-error 'id msg)))
...))
(define-syntax (parameterize-syntax-ids stx)
(syntax-case stx ()
[(_ ([a b] ...) body ...)
(with-syntax ([ooo (quote-syntax ...)])
#'(syntax-parameterize ([a (lambda (stx)
(syntax-case stx ()
[(id val)
#'(set! b val)]
[id
(identifier? #'id)
#'b]
[else
#`(raise-syntax-error #f "Bad use?")]
))]
...)
body ...))]))
; Mask utils
(define-for-syntax (shift-amount x [accum 0])
(if (fx= 1 (fxand 1 x))
accum
(shift-amount (fxrshift x 1) (+ 1 accum))))
(define-syntax (define-masker outerstx)
(syntax-case outerstx ()
[(_ id bits)
(let* ([mask (fx+ 0 (syntax-e #'bits))]
[antimask (fxxor mask #xFFFF)]
[shift-count (shift-amount mask)])
#`(define-syntax (id stx)
(syntax-case stx ()
[(_ #:debug)
#'(list #,mask #,antimask #,shift-count)]
[(_ #:mask)
#'#,mask]
[(_ backing #:unshifted)
#'(ufxand #,mask backing)]
[(_ backing #:shifted)
#'(ufxrshift (ufxand #,mask backing) #,shift-count)]
[(_ backing #:set! val)
#'(set! backing (ufxior (ufxand backing #,antimask)
(ufxand #,mask (ufxlshift val #,shift-count))))]
#;[(_ backing #:with val)
#'(ufxior (ufxand backing #,antimask)
(ufxand #,mask (ufxlshift val #,shift-count)))]
)))]))
(define-syntax-rule (define-maskers [bits id] ...)
(begin (define-masker id bits)
...))
(define-syntax-rule (has-any-flag? id /flag? ...)
(not (ufx= 0 (ufxand id (ufxior* (/flag? id #:unshifted)
...)))))
(define-syntax-rule (copy-bits #:from src #:to dst /mask ...)
(let* ([mask (ufxior* (/mask #:mask)
...)]
; clear relevant bits:
[temp (ufxand dst (ufxnot mask))]
; copy bits
[temp (ufxior temp (ufxand src mask))])
(set! dst temp)))
(module+ test
(require typed/rackunit)
(define-masker /bit2 #b100)
(define-masker /bit1 #b010)
(let ([A : Fixnum 0]
[B : Fixnum 0])
(set! A #b1111)
(copy-bits #:from A #:to B /bit2 /bit1)
(check-equal? B #b0110)
(set! A 0)
(copy-bits #:from A #:to B /bit2 /bit1)
(check-equal? B #b0000)
(set! A #b1111)
(set! B #b1000)
(copy-bits #:from A #:to B /bit1)
(check-equal? B #b1010)
(set! A 0)
(copy-bits #:from A #:to B /bit1)
(check-equal? B #b1000)
))