Changeset 33787 in project


Ignore:
Timestamp:
01/01/17 19:04:45 (3 years ago)
Author:
juergen
Message:

basic-sequences 2.0 with tagged-vectors

Location:
release/4/basic-sequences
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/basic-sequences/tags/2.0/basic-sequences.scm

    r33524 r33787  
    3636  (seq-db seq-null? seq? seq-of seq-ref seq-tail seq-maker seq-exception
    3737   seq-car seq-cdr seq-random-access? basic-sequences
     38   thunk thunk? tagged-vector-of
     39   tagged-vector tagged-vector? tagged-vector-ref tagged-vector-tail
    3840   cons* list-of pseudo-list-of vector-of symbol-dispatcher)
    3941  (import scheme
    40           (only chicken case-lambda receive condition-case error subvector print)
     42          (only chicken case-lambda receive condition-case define-inline
     43                define-values gensym string->keyword assert fixnum?
     44                fx+ fx- fx= fx> fx< fx>= error subvector print)
    4145          (only data-structures chop conjoin disjoin list-of?)
    4246          (only simple-exceptions raise make-exception))
     
    4650(define seq-exception
    4751  (make-exception "sequence exception" 'sequence))
     52
     53;;; helpers
     54;;; -------
     55(define-inline (1+ n) (fx+ n 1))
     56(define-inline (1- n) (fx- n 1))
     57(define-inline (0= n) (fx= n 0))
     58(define-inline (0<= n) (fx>= n 0))
     59
     60
     61(define-syntax thunk
     62  (syntax-rules ()
     63    ((_ xpr . xprs)
     64     (lambda () xpr . xprs))))
     65
     66(define (thunk? xpr)
     67  (let ((type (gensym 'thunk)))
     68    (and (procedure? xpr)
     69         (if (eq? (condition-case (xpr)
     70                    ((exn arity) type))
     71                  type)
     72           #f #t))))
     73
     74(define (tagged-vector? xpr)
     75  (and (vector? xpr)
     76       (fx>= (vector-length xpr) 1)
     77       (condition-case (thunk? (vector-ref xpr 0))
     78         ((exn sequence) #t))))
     79
     80(define (tagged-vector kw . args)
     81  (let ((result (make-vector (1+ (length args)))))
     82    (vector-set! result 0 (thunk kw))
     83    (do ((args args (cdr args))
     84         (k 1 (1+ k)))
     85      ((null? args) result)
     86      (vector-set! result k (car args)))))
     87
     88(define (tagged-vector-ref tv k)
     89  (if (0= k)
     90    ((vector-ref tv k))
     91    (vector-ref tv k)))
     92
     93(define (tagged-vector-tail tv k)
     94  (cond
     95    ((fx= k (vector-length tv))
     96     (vector (thunk
     97               (raise
     98                 (seq-exception 'tagged-vector-tail
     99                                "can't access null tagged vector")))))
     100    ((0= k) tv)
     101    (else
     102      (let* ((tail (subvector tv k))
     103             (len (vector-length tail))
     104             (result (make-vector (1+ len))))
     105        (vector-set! result 0 (vector-ref tv 0))
     106        (do ((i 0 (1+ i)))
     107          ((fx= i len) result)
     108          (vector-set! result (1+ i) (vector-ref tail i)))))))
    48109
    49110;;; (seq-ref seq k)
     
    52113;;; the second returned value is needed in seq-null?
    53114(define (seq-ref seq k)
     115  (assert (0<= k) 'seq-ref)
    54116  (values
    55117    (cond
     
    61123      ((pair? seq)
    62124       (condition-case
    63          (if (< k 0)
    64            (raise (seq-exception 'seq-ref "out-of-range" seq k))
    65            (let loop ((pl seq) (n k))
    66              (if (pair? pl)
    67                (if (zero? n)
    68                  (car pl)
    69                  (loop (cdr pl) (- n 1)))
    70                (raise (seq-exception 'seq-ref
    71                                      "out of range" seq k)))))))
     125         (let loop ((pl seq) (n k))
     126           (if (pair? pl)
     127             (if (0= n)
     128               (car pl)
     129               (loop (cdr pl) (1- n)))
     130             (raise (seq-exception 'seq-ref
     131                                   "out of range" seq k))))))
     132      ((tagged-vector? seq)
     133       (condition-case (tagged-vector-ref seq k)
     134         ((exn)
     135          (raise (seq-exception 'seq-ref "out of range" seq k)))))
    72136      ((vector? seq)
    73137       (condition-case (vector-ref seq k)
     
    95159;;; access to the tail of a sequence
    96160(define (seq-tail seq k)
     161  (assert (0<= k) 'seq-tail)
    97162  (cond
    98163    ((list? seq)
    99164     (condition-case (list-tail seq k)
    100165       ((exn) (raise (seq-exception 'seq-tail
    101                                          "out of range" seq k)))))
     166                                           "out of range" seq k)))))
    102167    ((pair? seq)
    103168     (condition-case
    104        (if (< k 0)
    105          (raise (seq-exception 'seq-tail
    106                                     "out-of-range" seq k))
    107          (let loop ((pl seq) (n k))
    108            (if (pair? pl)
    109              (if (zero? n)
    110                pl
    111                (loop (cdr pl) (- n 1)))
    112              (if (> n 0)
    113                (raise (seq-exception 'seq-tail
    114                                           "out-of-range" seq k))
    115                pl))))))
     169       (let loop ((pl seq) (n k))
     170         (if (pair? pl)
     171           (if (0= n)
     172             pl
     173             (loop (cdr pl) (1- n)))
     174           (if (fx> n 0)
     175             (raise (seq-exception 'seq-tail
     176                                   "out-of-range" seq k))
     177             pl)))))
     178    ((tagged-vector? seq)
     179     (condition-case (tagged-vector-tail seq k)
     180       ((exn)
     181        (raise (seq-exception 'seq-tail
     182                              "out of range" seq k)))))
    116183    ((vector? seq)
    117184     (condition-case (subvector seq k)
    118        ((exn) (raise (seq-exception 'seq-tail
    119                                          "out of range" seq k)))))
     185       ((exn)
     186        (raise (seq-exception 'seq-tail
     187                              "out of range" seq k)))))
    120188    ((string? seq)
    121189     (condition-case (substring seq k)
    122        ((exn) (raise (seq-exception 'seq-tail
    123                                          "out of range" seq k)))))
     190       ((exn)
     191        (raise (seq-exception 'seq-tail
     192                              "out of range" seq k)))))
    124193    (else
    125194      (let loop ((db (seq-db)))
     
    135204    ((list? seq) list)
    136205    ((pair? seq) cons*)
     206    ((tagged-vector? seq) tagged-vector)
    137207    ((vector? seq) vector)
    138208    ((string? seq) string)
     
    152222    ((list? seq) #f)
    153223    ((pair? seq) #f)
     224    ((tagged-vector? seq) #t)
    154225    ((vector? seq) #t)
    155226    ((string? seq) #t)
     
    241312  (or (list? xpr)
    242313      (pair? xpr)
     314      (tagged-vector? xpr)
    243315      (vector? xpr)
    244316      (string? xpr)
     
    259331                    #t)
    260332                   ((ok? (seq-ref xpr n))
    261                     (loop (+ n 1)))
     333                    (loop (1+ n)))
    262334                   (else #f)))))))
    263335    )
     
    304376               (let loop ((n 0))
    305377                 (cond
    306                    ((= n (vector-length vec))
     378                   ((fx= n (vector-length vec))
    307379                    #t)
    308380                   ((ok? (vector-ref vec n))
    309                     (loop (+ n 1)))
     381                    (loop (1+ n)))
    310382                   (else #f)))))))
    311383    )
    312384    (vector-of? (apply conjoin oks?))))
     385
     386;;; (tagged-vector-of ok? ...)
     387;;; --------------------------
     388;;; returns a vector predicate which checks all ok? arguments
     389(define (tagged-vector-of . oks?)
     390  (lambda (xpr)
     391    (and (tagged-vector? xpr)
     392         ((apply vector-of oks?)
     393          (subvector xpr 1)))))
    313394
    314395;;; (symbol-dispatcher alist)
     
    399480      (vector-of ok? ...)
    400481      "generates a vector predicate which checks all of its arguments")
     482    (tagged-vector
     483      procedure:
     484      (tagged-vector kw arg ...)
     485      "generates a tagged vector with keyword kw and args arg ...")
     486    (tagged-vector?
     487      procedure:
     488      (tagged-vector? xpr)
     489      "type predicate")
     490    (tagged-vector-of
     491      procedure:
     492      (tagged-vector-of ok? ...)
     493      "generates a tagged vector predicate which checks all of its arguments")
     494    (tagged-vector-ref
     495      procedure:
     496      (tagged-vector-ref tv k)
     497      "access to kth item of tagged vector tv")
     498    (tagged-vector-tail
     499      procedure:
     500      (tagged-vector-tail tv k)
     501      "returns a tagged subvector of tv starting at k")
     502    (thunk
     503      macro:
     504      (thunk xpr ....)
     505      "generates a thunk with body xpr ....")
     506    (thunk?
     507      procedure:
     508      (thunk? xpr)
     509      "checks if xpr is a thunk, i.e. a nullary procedure")
    401510    (symbol-dispatcher
    402511      procedure:
     
    407516  ) ; basic-sequences
    408517
    409 ;(import basic-sequences)
    410 ;
    411 ;(use arrays)
    412 ;(seq-db array? ra?: #t ref: array-ref tail: array-tail maker: array)
    413 ;(define (seq-head seq n)
    414 ;  (let loop ((k 0) (result '()))
    415 ;    (if (= k n)
    416 ;      (apply (seq-maker seq) (reverse result))
    417 ;      (loop (+ k 1) (cons (seq-ref seq k) result)))))
    418 ;(define (seq-length seq)
    419 ;  (let loop ((k 0))
    420 ;    (if (seq-null? (seq-tail seq k))
    421 ;      k
    422 ;      (loop (+ k 1)))))
    423 ;
  • release/4/basic-sequences/tags/2.0/basic-sequences.setup

    r33524 r33787  
    77 'basic-sequences
    88 '("basic-sequences.so" "basic-sequences.import.so")
    9  '((version "1.0")))
     9 '((version "2.0")))
  • release/4/basic-sequences/tags/2.0/tests/run.scm

    r33524 r33787  
    33        simple-tests
    44        (only arrays array array? array-ref array-tail array->list))
     5
     6(define-test (tagged-vectors?)
     7  (check
     8    (eq? ((thunk x:)) x:)
     9    (thunk? (thunk 1 2 3))
     10    (define tv (tagged-vector x: 0 1 2 3))
     11    (eq? (tagged-vector-ref tv 0) x:)
     12    (define null (tagged-vector x:))
     13    (tagged-vector? null)
     14    (seq? null)
     15    (not (seq-null? null))
     16    (define tv0 (tagged-vector-tail tv 0))
     17    (define tv1 (tagged-vector-tail tv 1))
     18    (define tv2 (tagged-vector-tail tv 2))
     19    (define tv3 (tagged-vector-tail tv 3))
     20    (eq? (tagged-vector-ref tv3 0) x:)
     21    (define tv4 (tagged-vector-tail tv 4))
     22    (tagged-vector? tv4)
     23    (not (seq-null? tv4))
     24    (define tv5 (tagged-vector-tail tv 5))
     25    (seq-null? tv5)
     26    (not (condition-case (tagged-vector-ref tv5 0)
     27           ((exn sequence) #f)))
     28    ))
    529
    630(define-test (sequences?)
     
    4670(compound-test (SEQUNCES)
    4771  (sequences?)
     72  (tagged-vectors?)
    4873  )
  • release/4/basic-sequences/trunk/basic-sequences.scm

    r33524 r33787  
    3636  (seq-db seq-null? seq? seq-of seq-ref seq-tail seq-maker seq-exception
    3737   seq-car seq-cdr seq-random-access? basic-sequences
     38   thunk thunk? tagged-vector-of
     39   tagged-vector tagged-vector? tagged-vector-ref tagged-vector-tail
    3840   cons* list-of pseudo-list-of vector-of symbol-dispatcher)
    3941  (import scheme
    40           (only chicken case-lambda receive condition-case error subvector print)
     42          (only chicken case-lambda receive condition-case define-inline
     43                define-values gensym string->keyword assert fixnum?
     44                fx+ fx- fx= fx> fx< fx>= error subvector print)
    4145          (only data-structures chop conjoin disjoin list-of?)
    4246          (only simple-exceptions raise make-exception))
     
    4650(define seq-exception
    4751  (make-exception "sequence exception" 'sequence))
     52
     53;;; helpers
     54;;; -------
     55(define-inline (1+ n) (fx+ n 1))
     56(define-inline (1- n) (fx- n 1))
     57(define-inline (0= n) (fx= n 0))
     58(define-inline (0<= n) (fx>= n 0))
     59
     60
     61(define-syntax thunk
     62  (syntax-rules ()
     63    ((_ xpr . xprs)
     64     (lambda () xpr . xprs))))
     65
     66(define (thunk? xpr)
     67  (let ((type (gensym 'thunk)))
     68    (and (procedure? xpr)
     69         (if (eq? (condition-case (xpr)
     70                    ((exn arity) type))
     71                  type)
     72           #f #t))))
     73
     74(define (tagged-vector? xpr)
     75  (and (vector? xpr)
     76       (fx>= (vector-length xpr) 1)
     77       (condition-case (thunk? (vector-ref xpr 0))
     78         ((exn sequence) #t))))
     79
     80(define (tagged-vector kw . args)
     81  (let ((result (make-vector (1+ (length args)))))
     82    (vector-set! result 0 (thunk kw))
     83    (do ((args args (cdr args))
     84         (k 1 (1+ k)))
     85      ((null? args) result)
     86      (vector-set! result k (car args)))))
     87
     88(define (tagged-vector-ref tv k)
     89  (if (0= k)
     90    ((vector-ref tv k))
     91    (vector-ref tv k)))
     92
     93(define (tagged-vector-tail tv k)
     94  (cond
     95    ((fx= k (vector-length tv))
     96     (vector (thunk
     97               (raise
     98                 (seq-exception 'tagged-vector-tail
     99                                "can't access null tagged vector")))))
     100    ((0= k) tv)
     101    (else
     102      (let* ((tail (subvector tv k))
     103             (len (vector-length tail))
     104             (result (make-vector (1+ len))))
     105        (vector-set! result 0 (vector-ref tv 0))
     106        (do ((i 0 (1+ i)))
     107          ((fx= i len) result)
     108          (vector-set! result (1+ i) (vector-ref tail i)))))))
    48109
    49110;;; (seq-ref seq k)
     
    52113;;; the second returned value is needed in seq-null?
    53114(define (seq-ref seq k)
     115  (assert (0<= k) 'seq-ref)
    54116  (values
    55117    (cond
     
    61123      ((pair? seq)
    62124       (condition-case
    63          (if (< k 0)
    64            (raise (seq-exception 'seq-ref "out-of-range" seq k))
    65            (let loop ((pl seq) (n k))
    66              (if (pair? pl)
    67                (if (zero? n)
    68                  (car pl)
    69                  (loop (cdr pl) (- n 1)))
    70                (raise (seq-exception 'seq-ref
    71                                      "out of range" seq k)))))))
     125         (let loop ((pl seq) (n k))
     126           (if (pair? pl)
     127             (if (0= n)
     128               (car pl)
     129               (loop (cdr pl) (1- n)))
     130             (raise (seq-exception 'seq-ref
     131                                   "out of range" seq k))))))
     132      ((tagged-vector? seq)
     133       (condition-case (tagged-vector-ref seq k)
     134         ((exn)
     135          (raise (seq-exception 'seq-ref "out of range" seq k)))))
    72136      ((vector? seq)
    73137       (condition-case (vector-ref seq k)
     
    95159;;; access to the tail of a sequence
    96160(define (seq-tail seq k)
     161  (assert (0<= k) 'seq-tail)
    97162  (cond
    98163    ((list? seq)
    99164     (condition-case (list-tail seq k)
    100165       ((exn) (raise (seq-exception 'seq-tail
    101                                          "out of range" seq k)))))
     166                                           "out of range" seq k)))))
    102167    ((pair? seq)
    103168     (condition-case
    104        (if (< k 0)
    105          (raise (seq-exception 'seq-tail
    106                                     "out-of-range" seq k))
    107          (let loop ((pl seq) (n k))
    108            (if (pair? pl)
    109              (if (zero? n)
    110                pl
    111                (loop (cdr pl) (- n 1)))
    112              (if (> n 0)
    113                (raise (seq-exception 'seq-tail
    114                                           "out-of-range" seq k))
    115                pl))))))
     169       (let loop ((pl seq) (n k))
     170         (if (pair? pl)
     171           (if (0= n)
     172             pl
     173             (loop (cdr pl) (1- n)))
     174           (if (fx> n 0)
     175             (raise (seq-exception 'seq-tail
     176                                   "out-of-range" seq k))
     177             pl)))))
     178    ((tagged-vector? seq)
     179     (condition-case (tagged-vector-tail seq k)
     180       ((exn)
     181        (raise (seq-exception 'seq-tail
     182                              "out of range" seq k)))))
    116183    ((vector? seq)
    117184     (condition-case (subvector seq k)
    118        ((exn) (raise (seq-exception 'seq-tail
    119                                          "out of range" seq k)))))
     185       ((exn)
     186        (raise (seq-exception 'seq-tail
     187                              "out of range" seq k)))))
    120188    ((string? seq)
    121189     (condition-case (substring seq k)
    122        ((exn) (raise (seq-exception 'seq-tail
    123                                          "out of range" seq k)))))
     190       ((exn)
     191        (raise (seq-exception 'seq-tail
     192                              "out of range" seq k)))))
    124193    (else
    125194      (let loop ((db (seq-db)))
     
    135204    ((list? seq) list)
    136205    ((pair? seq) cons*)
     206    ((tagged-vector? seq) tagged-vector)
    137207    ((vector? seq) vector)
    138208    ((string? seq) string)
     
    152222    ((list? seq) #f)
    153223    ((pair? seq) #f)
     224    ((tagged-vector? seq) #t)
    154225    ((vector? seq) #t)
    155226    ((string? seq) #t)
     
    241312  (or (list? xpr)
    242313      (pair? xpr)
     314      (tagged-vector? xpr)
    243315      (vector? xpr)
    244316      (string? xpr)
     
    259331                    #t)
    260332                   ((ok? (seq-ref xpr n))
    261                     (loop (+ n 1)))
     333                    (loop (1+ n)))
    262334                   (else #f)))))))
    263335    )
     
    304376               (let loop ((n 0))
    305377                 (cond
    306                    ((= n (vector-length vec))
     378                   ((fx= n (vector-length vec))
    307379                    #t)
    308380                   ((ok? (vector-ref vec n))
    309                     (loop (+ n 1)))
     381                    (loop (1+ n)))
    310382                   (else #f)))))))
    311383    )
    312384    (vector-of? (apply conjoin oks?))))
     385
     386;;; (tagged-vector-of ok? ...)
     387;;; --------------------------
     388;;; returns a vector predicate which checks all ok? arguments
     389(define (tagged-vector-of . oks?)
     390  (lambda (xpr)
     391    (and (tagged-vector? xpr)
     392         ((apply vector-of oks?)
     393          (subvector xpr 1)))))
    313394
    314395;;; (symbol-dispatcher alist)
     
    399480      (vector-of ok? ...)
    400481      "generates a vector predicate which checks all of its arguments")
     482    (tagged-vector
     483      procedure:
     484      (tagged-vector kw arg ...)
     485      "generates a tagged vector with keyword kw and args arg ...")
     486    (tagged-vector?
     487      procedure:
     488      (tagged-vector? xpr)
     489      "type predicate")
     490    (tagged-vector-of
     491      procedure:
     492      (tagged-vector-of ok? ...)
     493      "generates a tagged vector predicate which checks all of its arguments")
     494    (tagged-vector-ref
     495      procedure:
     496      (tagged-vector-ref tv k)
     497      "access to kth item of tagged vector tv")
     498    (tagged-vector-tail
     499      procedure:
     500      (tagged-vector-tail tv k)
     501      "returns a tagged subvector of tv starting at k")
     502    (thunk
     503      macro:
     504      (thunk xpr ....)
     505      "generates a thunk with body xpr ....")
     506    (thunk?
     507      procedure:
     508      (thunk? xpr)
     509      "checks if xpr is a thunk, i.e. a nullary procedure")
    401510    (symbol-dispatcher
    402511      procedure:
     
    407516  ) ; basic-sequences
    408517
    409 ;(import basic-sequences)
    410 ;
    411 ;(use arrays)
    412 ;(seq-db array? ra?: #t ref: array-ref tail: array-tail maker: array)
    413 ;(define (seq-head seq n)
    414 ;  (let loop ((k 0) (result '()))
    415 ;    (if (= k n)
    416 ;      (apply (seq-maker seq) (reverse result))
    417 ;      (loop (+ k 1) (cons (seq-ref seq k) result)))))
    418 ;(define (seq-length seq)
    419 ;  (let loop ((k 0))
    420 ;    (if (seq-null? (seq-tail seq k))
    421 ;      k
    422 ;      (loop (+ k 1)))))
    423 ;
  • release/4/basic-sequences/trunk/basic-sequences.setup

    r33524 r33787  
    77 'basic-sequences
    88 '("basic-sequences.so" "basic-sequences.import.so")
    9  '((version "1.0")))
     9 '((version "2.0")))
  • release/4/basic-sequences/trunk/tests/run.scm

    r33524 r33787  
    33        simple-tests
    44        (only arrays array array? array-ref array-tail array->list))
     5
     6(define-test (tagged-vectors?)
     7  (check
     8    (eq? ((thunk x:)) x:)
     9    (thunk? (thunk 1 2 3))
     10    (define tv (tagged-vector x: 0 1 2 3))
     11    (eq? (tagged-vector-ref tv 0) x:)
     12    (define null (tagged-vector x:))
     13    (tagged-vector? null)
     14    (seq? null)
     15    (not (seq-null? null))
     16    (define tv0 (tagged-vector-tail tv 0))
     17    (define tv1 (tagged-vector-tail tv 1))
     18    (define tv2 (tagged-vector-tail tv 2))
     19    (define tv3 (tagged-vector-tail tv 3))
     20    (eq? (tagged-vector-ref tv3 0) x:)
     21    (define tv4 (tagged-vector-tail tv 4))
     22    (tagged-vector? tv4)
     23    (not (seq-null? tv4))
     24    (define tv5 (tagged-vector-tail tv 5))
     25    (seq-null? tv5)
     26    (not (condition-case (tagged-vector-ref tv5 0)
     27           ((exn sequence) #f)))
     28    ))
    529
    630(define-test (sequences?)
     
    4670(compound-test (SEQUNCES)
    4771  (sequences?)
     72  (tagged-vectors?)
    4873  )
Note: See TracChangeset for help on using the changeset viewer.