Changeset 14560 in project


Ignore:
Timestamp:
05/08/09 04:00:09 (11 years ago)
Author:
Ivan Raikov
Message:

srfi-4-comprehensions ported to Chicken 4

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-4-comprehensions/srfi-4-comprehensions.scm

    r14553 r14560  
    3333(module srfi-4-comprehensions
    3434  (:s8vector :u8vector :s16vector :u16vector :s32vector
    35            :u32vector :s64vector :u64vector :f64vector :f32vector
     35   :u32vector :f64vector :f32vector
     36;   :s64vector :u64vector
    3637           
    37            s8vector-ec u8vector-ec s16vector-ec u16vector-ec s32vector-ec
    38            u32vector-ec f64vector-ec f32vector-ec
     38   s8vector-ec u8vector-ec s16vector-ec u16vector-ec s32vector-ec
     39   u32vector-ec f64vector-ec f32vector-ec
    3940           
    40            s8vector-of-length-ec u8vector-of-length-ec s16vector-of-length-ec
    41            u16vector-of-length-ec s32vector-of-length-ec
    42            u32vector-of-length-ec
    43            f64vector-of-length-ec f32vector-of-length-ec)
     41   s8vector-of-length-ec u8vector-of-length-ec s16vector-of-length-ec
     42   u16vector-of-length-ec s32vector-of-length-ec
     43   u32vector-of-length-ec
     44   f64vector-of-length-ec f32vector-of-length-ec)
    4445
    45   (import scheme chicken )
    46 
     46  (import scheme chicken srfi-4 srfi-13)
    4747  (require-extension srfi-42)
    4848
    49  
    50   (define-for-syntax symbol-append
    51     (case-lambda
    52       ((s) s)
    53       ((s1 s2 . ss)
    54        (apply symbol-append (string->symbol (string-append (symbol->string s1) (symbol->string s2))) ss))))
    55  
    5649  (define-syntax make/prefix
    57     (lambda (stx)
    58       (syntax-case stx ()
    59         ((make-prefix-generator prefix)
    60          (let ((pre-sym (syntax-object->datum (syntax prefix))))
    61            (with-syntax ((vlength (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-length)))
    62                          (vref (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-ref)))
    63                          (vgen (datum->syntax-object (syntax prefix) (symbol-append ': pre-sym 'vector)))
    64                          (vfilter (datum->syntax-object (syntax prefix) (symbol-append 'ec-: pre-sym 'vector-filter)))
    65                          (vmake (datum->syntax-object (syntax prefix) (symbol-append 'make- pre-sym 'vector)))
    66                          (vset! (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-set!)))
    67                          (v->list (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector->list)))
    68                          (list->v (datum->syntax-object (syntax prefix) (symbol-append 'list-> pre-sym 'vector)))
    69                          (v-ec (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-ec)))
    70                          (v-of-length-ec (datum->syntax-object (syntax prefix) (symbol-append pre-sym 'vector-of-length-ec))))
    71              (syntax
    72               (begin 
    73                 (define-syntax vgen
    74                   (syntax-rules (index)
    75                     ((vgen cc var arg)
    76                      (vgen cc var (index i) arg) )
    77                     ((vgen cc var (index i) arg)
    78                      (:do cc
    79                           (let ((vec arg) (len 0))
    80                             (set! len (vlength vec)))
    81                           ((i 0))
    82                           (< i len)
    83                           (let ((var (vref vec i))))
    84                           #t
    85                           ((+ i 1)) ))
    86                     ((vgen cc var (index i) arg1 arg2 arg (... ...))
    87                      (:parallel cc (vgen cc var arg1 arg2 arg (... ...)) (:integers i)) )
    88                     ((vgen cc var arg1 arg2 arg (... ...))
    89                      (:do cc
    90                           (let ((vec #f)
    91                                 (len 0)
    92                                 (vecs (vfilter (list arg1 arg2 arg (... ...)))) ))
    93                           ((k 0))
    94                           (if (< k len)
    95                               #t
    96                               (if (null? vecs)
    97                                   #f
    98                                   (begin (set! vec (car vecs))
    99                                          (set! vecs (cdr vecs))
    100                                          (set! len (vlength vec))
    101                                          (set! k 0)
    102                                          #t )))
    103                           (let ((var (vref vec k))))
    104                           #t
    105                           ((+ k 1)) ))))
    106                 (define (vfilter vecs)
    107                   (if (null? vecs)
    108                       '()
    109                       (if (zero? (vlength (car vecs)))
    110                           (vfilter (cdr vecs))
    111                           (cons (car vecs) (vfilter (cdr vecs))) )))
    112                 (define-syntax v-ec
    113                   (syntax-rules ()
    114                     ((v-ec etc1 etc (... ...))
    115                      (list->v (list-ec etc1 etc (... ...))) )))
    116                 (define-syntax v-of-length-ec
    117                   (syntax-rules (nested)
    118                     ((v-of-length-ec k (nested q1 (... ...)) q etc1 etc (... ...))
    119                      (v-of-length-ec k (nested q1 (... ...) q) etc1 etc (... ...)) )
    120                     ((v-of-length-ec k q1 q2             etc1 etc (... ...))
    121                      (v-of-length-ec k (nested q1 q2)    etc1 etc (... ...)) )
    122                     ((v-of-length-ec k expression)
    123                      (v-of-length-ec k (nested) expression) )
    124                     ((v-of-length-ec k qualifier expression)
    125                      (let ((len k))
    126                        (let ((vec (vmake len))
    127                              (i 0) )
    128                          (do-ec qualifier
    129                                 (if (< i len)
    130                                     (begin (vset! vec i expression)
    131                                            (set! i (+ i 1)) )
    132                                     (error "vector is too short for the comprehension") ))
    133                          (if (= i len)
    134                              vec
    135                              (error "vector is too long for the comprehension") ))))))))))))))
     50    (lambda (x r c)
     51      (let* ((pre-sym  (->string (cadr x)))
     52             (vlength  (string->symbol (string-append pre-sym "vector-length")))
     53             (vref     (string->symbol (string-append pre-sym "vector-ref")))
     54             (vgen     (string->symbol (string-append ":" pre-sym "vector")))
     55             (vfilter  (string->symbol (string-append "ec-:" pre-sym "vector-filter")))
     56             (vmake    (string->symbol (string-append "make-" pre-sym "vector")))
     57             (vset!    (string->symbol (string-append pre-sym "vector-set!")))
     58             (list->v  (string->symbol (string-append "list->" pre-sym "vector")))
     59             (v-ec     (string->symbol (string-append pre-sym "vector-ec")))
     60             (v-of-length-ec (string->symbol (string-append pre-sym "vector-of-length-ec"))))
     61        `(begin
     62           (define-syntax ,vgen
     63             (syntax-rules (index)
     64               ((,vgen cc var arg)
     65                (,vgen cc var (index i) arg) )
     66               ((,vgen cc var (index i) arg)
     67                (:do cc
     68                     (let ((vec arg) (len 0))
     69                       (set! len (,vlength vec)))
     70                     ((i 0))
     71                     (< i len)
     72                     (let ((var (,vref vec i))))
     73                     #t
     74                     ((+ i 1)) ))
     75               ((,vgen cc var (index i) arg1 arg2 arg (... ...))
     76                (:parallel cc (,vgen cc var arg1 arg2 arg (... ...)) (:integers i)) )
     77               ((,vgen cc var arg1 arg2 arg (... ...))
     78                (:do cc
     79                     (let ((vec #f)
     80                           (len 0)
     81                           (vecs (,vfilter (list arg1 arg2 arg (... ...)))) ))
     82                     ((k 0))
     83                     (if (< k len)
     84                         #t
     85                         (if (null? vecs)
     86                             #f
     87                             (begin (set! vec (car vecs))
     88                                    (set! vecs (cdr vecs))
     89                                    (set! len (,vlength vec))
     90                                    (set! k 0)
     91                                    #t )))
     92                     (let ((var (,vref vec k))))
     93                     #t
     94                     ((+ k 1)) ))
     95               ))
    13696
    137   (make/prefix s8)
    138   (make/prefix u8)
    139   (make/prefix s16)
    140   (make/prefix u16)
    141   (make/prefix s32)
    142   (make/prefix u32)
    143   (make/prefix s64)
    144   (make/prefix u64)
    145   (make/prefix f32)
    146   (make/prefix f64)
     97           (define (,vfilter vecs)
     98             (if (null? vecs)
     99                 '()
     100                 (if (zero? (,vlength (car vecs)))
     101                     (,vfilter (cdr vecs))
     102                     (cons (car vecs) (,vfilter (cdr vecs))) )))
     103
     104           (define-syntax ,v-ec
     105             (syntax-rules ()
     106               ((v-ec etc1 etc (... ...))
     107                (,list->v (list-ec etc1 etc (... ...))) )))
     108
     109           (define-syntax ,v-of-length-ec
     110             (syntax-rules (nested)
     111               ((v-of-length-ec k (nested q1 (... ...)) q etc1 etc (... ...))
     112                (v-of-length-ec k (nested q1 (... ...) q) etc1 etc (... ...)) )
     113               ((v-of-length-ec k q1 q2             etc1 etc (... ...))
     114                (v-of-length-ec k (nested q1 q2)    etc1 etc (... ...)) )
     115               ((v-of-length-ec k expression)
     116                (v-of-length-ec k (nested) expression) )
     117               ((v-of-length-ec k qualifier expression)
     118                (let ((len k))
     119                  (let ((vec (,vmake len))
     120                        (i 0) )
     121                    (do-ec qualifier
     122                           (if (< i len)
     123                               (begin (,vset! vec i expression)
     124                                      (set! i (+ i 1)) )
     125                               (error "vector is too short for the comprehension") ))
     126                    (if (= i len)
     127                        vec
     128                        (error "vector is too long for the comprehension") ))))))
     129           )
     130        )))
     131
     132   (make/prefix s8)
     133   (make/prefix u8)
     134   (make/prefix s16)
     135   (make/prefix u16)
     136   (make/prefix s32)
     137   (make/prefix u32)
     138   (make/prefix f32)
     139   (make/prefix f64)
     140;   (make/prefix s64)
     141;   (make/prefix u64)
    147142)
Note: See TracChangeset for help on using the changeset viewer.