(module srfi-4-comprehensions mzscheme
(require (lib "42.ss" "srfi")
(lib "4.ss" "srfi"))
(provide :s8vector :u8vector :s16vector :u16vector :s32vector
:u32vector :s64vector :u64vector :f64vector :f32vector
s8vector-ec u8vector-ec s16vector-ec u16vector-ec s32vector-ec
u32vector-ec s64vector-ec u64vector-ec f64vector-ec f32vector-ec
s8vector-of-length-ec u8vector-of-length-ec s16vector-of-length-ec
u16vector-of-length-ec s32vector-of-length-ec
u32vector-of-length-ec s64vector-of-length-ec u64vector-of-length-ec
f64vector-of-length-ec f32vector-of-length-ec)
(provide (all-from (lib "42.ss" "srfi"))
(all-from (lib "4.ss" "srfi")))
(define-for-syntax symbol-append
(case-lambda
((s) s)
((s1 s2 . ss)
(apply symbol-append (string->symbol (string-append (symbol->string s1) (symbol->string s2))) ss))))
(define-syntax make/prefix
(lambda (stx)
(syntax-case stx ()
((make-prefix-generator prefix)
(let ((pre-sym (syntax-object->datum (syntax prefix))))
(with-syntax ((vlength (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-length)))
(vref (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-ref)))
(vgen (datum->syntax-object (syntax prefix) (symbol-append ': pre-sym 'vector)))
(vfilter (datum->syntax-object (syntax prefix) (symbol-append 'ec-: pre-sym 'vector-filter)))
(vmake (datum->syntax-object (syntax prefix) (symbol-append 'make- pre-sym 'vector)))
(vset! (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-set!)))
(v->list (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector->list)))
(list->v (datum->syntax-object (syntax prefix) (symbol-append 'list-> pre-sym 'vector)))
(v-ec (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-ec)))
(v-of-length-ec (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-of-length-ec))))
(syntax
(begin
(define-syntax vgen
(syntax-rules (index)
((vgen cc var arg)
(vgen cc var (index i) arg) )
((vgen cc var (index i) arg)
(:do cc
(let ((vec arg) (len 0))
(set! len (vlength vec)))
((i 0))
(< i len)
(let ((var (vref vec i))))
#t
((+ i 1)) ))
((vgen cc var (index i) arg1 arg2 arg (... ...))
(:parallel cc (vgen cc var arg1 arg2 arg (... ...)) (:integers i)) )
((vgen cc var arg1 arg2 arg (... ...))
(:do cc
(let ((vec #f)
(len 0)
(vecs (vfilter (list arg1 arg2 arg (... ...)))) ))
((k 0))
(if (< k len)
#t
(if (null? vecs)
#f
(begin (set! vec (car vecs))
(set! vecs (cdr vecs))
(set! len (vlength vec))
(set! k 0)
#t )))
(let ((var (vref vec k))))
#t
((+ k 1)) ))))
(define (vfilter vecs)
(if (null? vecs)
'()
(if (zero? (vlength (car vecs)))
(vfilter (cdr vecs))
(cons (car vecs) (vfilter (cdr vecs))) )))
(define-syntax v-ec
(syntax-rules ()
((v-ec etc1 etc (... ...))
(list->v (list-ec etc1 etc (... ...))) )))
(define-syntax v-of-length-ec
(syntax-rules (nested)
((v-of-length-ec k (nested q1 (... ...)) q etc1 etc (... ...))
(v-of-length-ec k (nested q1 (... ...) q) etc1 etc (... ...)) )
((v-of-length-ec k q1 q2 etc1 etc (... ...))
(v-of-length-ec k (nested q1 q2) etc1 etc (... ...)) )
((v-of-length-ec k expression)
(v-of-length-ec k (nested) expression) )
((v-of-length-ec k qualifier expression)
(let ((len k))
(let ((vec (vmake len))
(i 0) )
(do-ec qualifier
(if (< i len)
(begin (vset! vec i expression)
(set! i (+ i 1)) )
(error "vector is too short for the comprehension") ))
(if (= i len)
vec
(error "vector is too long for the comprehension") ))))))))))))))
(make/prefix s8)
(make/prefix u8)
(make/prefix s16)
(make/prefix u16)
(make/prefix s32)
(make/prefix u32)
(make/prefix s64)
(make/prefix u64)
(make/prefix f32)
(make/prefix f64))