array/array.rkt at master · rvs314/array · GitHub

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
#lang racket/base

(require racket/generic
         racket/sequence
         racket/flonum racket/fixnum racket/extflonum
         ffi/cvector
         ffi/vector
         (for-syntax racket/base racket/syntax syntax/parse))

(provide gen:array array?
         array-set! array-ref array-length array-copy! array-alloc
         array-empty? array-first array-last in-array
         array->list array->vector)

(begin-for-syntax
  ;; A type to register as an array: either a bare name, or a name with
  ;; options. #:copy? and #:in? say whether to use the type's own
  ;; `<type>-copy!` and `in-<type>`; without them, each is used whenever
  ;; it's bound. #:alloc replaces the default allocator, which calls
  ;; `make-<type>` with just a length.
  (define-syntax-class type-spec
    (pattern type:id
             #:attr copy? #f
             #:attr in? #f
             #:attr alloc #f)
    (pattern [type:id (~alt (~optional (~seq #:copy? copy?:boolean)
                                       #:too-many "repeated #:copy? flag")
                            (~optional (~seq #:in? in?:boolean)
                                       #:too-many "repeated #:in? flag")
                            (~optional (~seq #:alloc alloc:expr)
                                       #:too-many "repeated #:alloc option"))
                      ...])))

;; (define-generic-array name #:fast-defaults (type ...) #:defaults (type ...))
;; defines the generic interface gen:name, with methods named after `name`,
;; and registers each type as an instance of it.
(define-syntax (define-generic-array stx)
  (syntax-parse stx
    [(_ name:id
        #:fast-defaults (fast:type-spec ...)
        #:defaults (slow:type-spec ...))
     (define (method fs) (format-id #'name fs #'name))
     (with-syntax ([name-set!   (method "~a-set!")]
                   [name-ref    (method "~a-ref")]
                   [name-length (method "~a-length")]
                   [name-copy!  (method "~a-copy!")]
                   [name-alloc  (method "~a-alloc")]
                   [in-name     (method "in-~a")])
       (define (instance type copy? in? alloc)
         (define (fmt fs) (format-id type fs type))
         (define (use? flag fs)
           (if flag
               (syntax-e flag)
               (and (identifier-binding (fmt fs)) #t)))
         #`[#,(fmt "~a?")
            (define name-set!   #,(fmt "~a-set!"))
            (define name-ref    #,(fmt "~a-ref"))
            (define name-length #,(fmt "~a-length"))
            #,(if alloc
                  #`(define name-alloc #,alloc)
                  #`(define (name-alloc _ len) (#,(fmt "make-~a") len)))
            #,@(if (use? copy? "~a-copy!")
                   (list #`(define name-copy! #,(fmt "~a-copy!")))
                   '())
            #,@(if (use? in? "in-~a")
                   (list #`(define in-name #,(fmt "in-~a")))
                   '())])
       #`(define-generics name
           (name-set!   name idx value)
           (name-ref    name idx)
           (name-length name)
           (name-copy!  dest dest-start name [src-start] [src-end])
           (name-alloc  name len)
           (in-name     name)
           #:fallbacks
           [(define/generic len  name-length)
            (define/generic set! name-set!)
            (define/generic ref  name-ref)
            (define (name-copy! dest dest-start src
                                [src-start 0] [src-end (len src)])
              (for ([i (in-range src-start src-end)])
                (set! dest i (ref src i))))
            (define (in-name arr)
              (sequence-map
               (lambda (i) (ref arr i))
               (in-range (len arr))))]
           #:fast-defaults
           (#,@(map instance
                    (attribute fast.type)
                    (attribute fast.copy?)
                    (attribute fast.in?)
                    (attribute fast.alloc)))
           #:defaults
           (#,@(map instance
                    (attribute slow.type)
                    (attribute slow.copy?)
                    (attribute slow.in?)
                    (attribute slow.alloc)))))]))

(define-generic-array array
  #:fast-defaults (bytes vector string)
  #:defaults (flvector fxvector extflvector
              [cvector #:alloc (lambda (v len)
                                 (make-cvector (cvector-type v) len))]
              s8vector
              u16vector s16vector
              u32vector s32vector
              u64vector s64vector
              f32vector f64vector f80vector))

(define (array-empty? arr)
  (zero? (array-length arr)))

(define (array-first arr)
  (array-ref arr 0))

(define (array-last arr)
  (array-ref arr (sub1 (array-length arr))))

(define (array->list arr)
  (for/list ([x (in-array arr)]) x))

(define (array->vector arr)
  (for/vector #:length (array-length arr) ([x (in-array arr)]) x))

(module+ test
  (require rackunit (only-in ffi/unsafe _int))

  (check-equal? (array->vector "alphabet")
                '#(#\a #\l #\p #\h #\a #\b #\e #\t))

  (check-equal? (array->vector (u32vector 0 1 3 2 4))
                '#(0 1 3 2 4))

  (check-equal? (array->list (u8vector 0 1 32 2 2))
                '(0 1 32 2 2))

  (define foo (u8vector 2 40 21 3))
  (array-copy! foo 2 (u8vector 9 12))
  (check-equal? (u8vector 2 40 9 12) foo)

  (check-equal? (array-alloc foo 5)
                (u8vector 0 0 0 0 0))

  (define cv (array-alloc (cvector _int 1 2 3) 2))
  (check-equal? (cvector-length cv) 2)
  (check-equal? (cvector-type cv) _int))