Changeset 38868 in project


Ignore:
Timestamp:
08/21/20 18:11:59 (5 weeks ago)
Author:
juergen
Message:

callable-sequences 1.1 with recursive make-callable*

Location:
release/5/callable-sequences
Files:
3 edited
4 copied

Legend:

Unmodified
Added
Removed

  • release/5/callable-sequences/tags/1.1/callable-sequences.egg

    r38851 r38868  
    33((synopsis "sequential- and random-access sequences as procedures")
    44 (category data)
    5  (version "1.0.0")
     5 (version "1.1")
    66 (license "BSD")
    77 (test-dependencies simple-tests)

  • release/5/callable-sequences/tags/1.1/callable-sequences.scm

    r38851 r38868  
    44  make-ras-callable
    55  make-callable
     6  make-callable*
    67  callable-sas?
    78  callable-ras?
    … …  
    154155                                               cdr
    155156                                               null?)))
     157        (cons pair?
     158              (lambda (seq) (make-sas-callable seq
     159                                               cons
     160                                               car
     161                                               cdr
     162                                               atom?)))
    156163        (cons vector?
    157164              (lambda (seq) (make-ras-callable seq
    … …  
    167174                                               string-length)))
    168175        (cons any?
    169               (lambda (seq) (make-sas-callable seq
    170                                                cons
    171                                                car
    172                                                cdr
    173                                                atom?)))
     176              (lambda (seq) (error 'make-callable
     177                                   "not a sequence"
     178                                   seq)))
    174179        ))
    175180    (db standard-db)
    … …  
    180185       db)
    181186      ((seq)
    182        (let loop ((db db))
    183          (if ((caar db) seq)
    184            ((cdar db) seq)
    185            (loop (cdr db)))))
    186       ((seq? seq-maker?)
    187        ;; add new sequence type before trailing catch all pair
    188        (set! db
    189          (let recur ((db db))
    190            (if (null? (cdr db))
    191              (list (cons seq? seq-maker?) (car db))
    192              (cons (car db) (recur (cdr db))))))
    193        db)
     187       (make-callable seq #f)) ; not recursive
     188      ((x y)
     189       (cond
     190         ((boolean? y)
     191          (let ((seq x) (recursive? y))
     192            (if recursive?
     193              (let* ((sequence?
     194                      (lambda (seq)
     195                        (let ((tests (map car (cdr (reverse db)))))
     196                          (if (memv #t (map (lambda (fn) (fn seq))
     197                                            tests))
     198                            #t #f))))
     199                     (cseq (make-callable seq))
     200                     (len (callable-length cseq)))
     201                ;(print (map sequence? '(() #() (a . b) "" #f)))
     202                (make-callable
     203                  (let recur ((i 0))
     204                    (cond
     205                      ((= i len)
     206                       (callable-data (cseq i #f)))
     207                      ((sequence? (cseq i))
     208                       (cons (make-callable (cseq i) #t) (recur (+ i 1))))
     209                      ((pair? (cseq i))
     210                       (cons (make-callable (cseq i) #t) (recur (+ i 1))))
     211                      (else
     212                        (cons (cseq i) (recur (+ i 1))))))))
     213              (let loop ((db db))
     214                (if ((caar db) seq)
     215                  ((cdar db) seq)
     216                  (loop (cdr db)))))))
     217         ((and (procedure? x) (procedure? y))
     218          (let ((seq? x) (seq-maker y))
     219            ;; add new predicate-maker-pair as the next to last item
     220            (set! db
     221              (let recur ((db db))
     222                (if (null? (cdr db))
     223                  (list (cons seq? seq-maker) (car db))
     224                  (cons (car db) (recur (cdr db))))))
     225            db))
     226         (else (error 'make-callable
     227                      "type mismatch" x y))))
    194228      )))
    195229
     230(define (make-callable* seq)
     231  (make-callable seq #t))
    196232
    197233(define (callable? xpr)
    … …  
    242278            (print "  and the third inserts a new item to the local")
    243279            (print "  database in next to last position"))
     280           ((make-callable*)
     281            (print "  procdure:")
     282            (print "  (make-callable* seq)")
     283            (print "  recursive version of (make-callable seq"))
    244284           ((callable-sas?)
    245285            (print "  procedure:")
    … …  
    271311) ; module
    272312
    273 ;(import callable-sequences simple-tests)
     313(import callable-sequences simple-tests)
     314;(define nil (make-callable '()))
    274315;(define vec (make-callable #(0 1 2 3 4 5)))
    275316;(define str (make-callable "012345"))
    276317;(define lst (make-callable '(0 1 2 3 4 5)))
    277318;(define pair (make-callable '(0 1 2 3 4 5 . 6)))
    278 ;(make-callable boolean? identity)
     319;(ppp (make-callable)
     320;     (make-callable boolean? identity)
     321;     )
     322(define ls* (make-callable* '(a (b c))))
     323(define pl* (make-callable* '(a (b . c))))
     324(define lv* (make-callable* '(a #(b c))))
     325(define vp* (make-callable* (vector 'a '(b . c))))
     326(define vs* (make-callable* (vector 'a "bc")))
     327(ppp (ls* 0)
     328     ((ls* 1) 1)
     329     (((ls* 1) 2 #f))
     330     ((pl* 1) 0)
     331     (((pl* 1) 1 #f))
     332     ((lv* 1) 1)
     333     ((vp* 1) 0)
     334     (((vp* 1) 1 #f))
     335     ((vs* 1) 0)
     336     ((vs* 1) 1)
     337     (((vs* 1) 2 #f))
     338     )

  • release/5/callable-sequences/tags/1.1/tests/run.scm

    r38851 r38868  
    147147;(callables?)
    148148
    149 (check-all CALLABLES (callables?))
     149(define-checks (recursives? verbose?
     150                            pl*
     151                            (make-callable* '(a (b . c)))
     152                            ls*
     153                            (make-callable* '(a (b c)))
     154                            lv*
     155                            (make-callable* '(a #(b c)))
     156                            vp*
     157                            (make-callable* (vector 'a '(b . c)))
     158                            vs*
     159                            (make-callable* (vector 'a "bc"))
     160                            lv**
     161                            (make-callable* '(a (b #(c d) e) f)))
     162  (ls* 0)
     163  'a
     164  ((ls* 1) 1)
     165  'c
     166  (((ls* 1) 2 #f))
     167  '()
     168  ((pl* 1) 0)
     169  'b
     170  (((pl* 1) 1 #f))
     171  'c
     172  ((lv* 1) 1)
     173  'c
     174  ((vp* 1) 0)
     175  'b
     176  (((vp* 1) 1 #f))
     177  'c
     178  ((vs* 1) 0)
     179  #\b
     180  ((vs* 1) 1)
     181  #\c
     182  (((vs* 1) 2 #f))
     183  ""
     184  (lv** 0)
     185  'a
     186  ((lv** 1) 0)
     187  'b
     188  (((lv** 1) 1) 0)
     189  'c
     190  (((lv** 1) 1) 1)
     191  'd
     192  (lv** 2)
     193  'f
     194  ((lv** 1) 2)
     195  'e
     196  )
     197;(recursives?)
     198
     199(check-all CALLABLES (callables?) (recursives?))
     200

  • release/5/callable-sequences/trunk/callable-sequences.egg

    r38851 r38868  
    33((synopsis "sequential- and random-access sequences as procedures")
    44 (category data)
    5  (version "1.0.0")
     5 (version "1.1")
    66 (license "BSD")
    77 (test-dependencies simple-tests)

  • release/5/callable-sequences/trunk/callable-sequences.scm

    r38851 r38868  
    44  make-ras-callable
    55  make-callable
     6  make-callable*
    67  callable-sas?
    78  callable-ras?
    … …  
    154155                                               cdr
    155156                                               null?)))
     157        (cons pair?
     158              (lambda (seq) (make-sas-callable seq
     159                                               cons
     160                                               car
     161                                               cdr
     162                                               atom?)))
    156163        (cons vector?
    157164              (lambda (seq) (make-ras-callable seq
    … …  
    167174                                               string-length)))
    168175        (cons any?
    169               (lambda (seq) (make-sas-callable seq
    170                                                cons
    171                                                car
    172                                                cdr
    173                                                atom?)))
     176              (lambda (seq) (error 'make-callable
     177                                   "not a sequence"
     178                                   seq)))
    174179        ))
    175180    (db standard-db)
    … …  
    180185       db)
    181186      ((seq)
    182        (let loop ((db db))
    183          (if ((caar db) seq)
    184            ((cdar db) seq)
    185            (loop (cdr db)))))
    186       ((seq? seq-maker?)
    187        ;; add new sequence type before trailing catch all pair
    188        (set! db
    189          (let recur ((db db))
    190            (if (null? (cdr db))
    191              (list (cons seq? seq-maker?) (car db))
    192              (cons (car db) (recur (cdr db))))))
    193        db)
     187       (make-callable seq #f)) ; not recursive
     188      ((x y)
     189       (cond
     190         ((boolean? y)
     191          (let ((seq x) (recursive? y))
     192            (if recursive?
     193              (let* ((sequence?
     194                      (lambda (seq)
     195                        (let ((tests (map car (cdr (reverse db)))))
     196                          (if (memv #t (map (lambda (fn) (fn seq))
     197                                            tests))
     198                            #t #f))))
     199                     (cseq (make-callable seq))
     200                     (len (callable-length cseq)))
     201                ;(print (map sequence? '(() #() (a . b) "" #f)))
     202                (make-callable
     203                  (let recur ((i 0))
     204                    (cond
     205                      ((= i len)
     206                       (callable-data (cseq i #f)))
     207                      ((sequence? (cseq i))
     208                       (cons (make-callable (cseq i) #t) (recur (+ i 1))))
     209                      ((pair? (cseq i))
     210                       (cons (make-callable (cseq i) #t) (recur (+ i 1))))
     211                      (else
     212                        (cons (cseq i) (recur (+ i 1))))))))
     213              (let loop ((db db))
     214                (if ((caar db) seq)
     215                  ((cdar db) seq)
     216                  (loop (cdr db)))))))
     217         ((and (procedure? x) (procedure? y))
     218          (let ((seq? x) (seq-maker y))
     219            ;; add new predicate-maker-pair as the next to last item
     220            (set! db
     221              (let recur ((db db))
     222                (if (null? (cdr db))
     223                  (list (cons seq? seq-maker) (car db))
     224                  (cons (car db) (recur (cdr db))))))
     225            db))
     226         (else (error 'make-callable
     227                      "type mismatch" x y))))
    194228      )))
    195229
     230(define (make-callable* seq)
     231  (make-callable seq #t))
    196232
    197233(define (callable? xpr)
    … …  
    242278            (print "  and the third inserts a new item to the local")
    243279            (print "  database in next to last position"))
     280           ((make-callable*)
     281            (print "  procdure:")
     282            (print "  (make-callable* seq)")
     283            (print "  recursive version of (make-callable seq"))
    244284           ((callable-sas?)
    245285            (print "  procedure:")
    … …  
    271311) ; module
    272312
    273 ;(import callable-sequences simple-tests)
     313(import callable-sequences simple-tests)
     314;(define nil (make-callable '()))
    274315;(define vec (make-callable #(0 1 2 3 4 5)))
    275316;(define str (make-callable "012345"))
    276317;(define lst (make-callable '(0 1 2 3 4 5)))
    277318;(define pair (make-callable '(0 1 2 3 4 5 . 6)))
    278 ;(make-callable boolean? identity)
     319;(ppp (make-callable)
     320;     (make-callable boolean? identity)
     321;     )
     322(define ls* (make-callable* '(a (b c))))
     323(define pl* (make-callable* '(a (b . c))))
     324(define lv* (make-callable* '(a #(b c))))
     325(define vp* (make-callable* (vector 'a '(b . c))))
     326(define vs* (make-callable* (vector 'a "bc")))
     327(ppp (ls* 0)
     328     ((ls* 1) 1)
     329     (((ls* 1) 2 #f))
     330     ((pl* 1) 0)
     331     (((pl* 1) 1 #f))
     332     ((lv* 1) 1)
     333     ((vp* 1) 0)
     334     (((vp* 1) 1 #f))
     335     ((vs* 1) 0)
     336     ((vs* 1) 1)
     337     (((vs* 1) 2 #f))
     338     )

  • release/5/callable-sequences/trunk/tests/run.scm

    r38851 r38868  
    147147;(callables?)
    148148
    149 (check-all CALLABLES (callables?))
     149(define-checks (recursives? verbose?
     150                            pl*
     151                            (make-callable* '(a (b . c)))
     152                            ls*
     153                            (make-callable* '(a (b c)))
     154                            lv*
     155                            (make-callable* '(a #(b c)))
     156                            vp*
     157                            (make-callable* (vector 'a '(b . c)))
     158                            vs*
     159                            (make-callable* (vector 'a "bc"))
     160                            lv**
     161                            (make-callable* '(a (b #(c d) e) f)))
     162  (ls* 0)
     163  'a
     164  ((ls* 1) 1)
     165  'c
     166  (((ls* 1) 2 #f))
     167  '()
     168  ((pl* 1) 0)
     169  'b
     170  (((pl* 1) 1 #f))
     171  'c
     172  ((lv* 1) 1)
     173  'c
     174  ((vp* 1) 0)
     175  'b
     176  (((vp* 1) 1 #f))
     177  'c
     178  ((vs* 1) 0)
     179  #\b
     180  ((vs* 1) 1)
     181  #\c
     182  (((vs* 1) 2 #f))
     183  ""
     184  (lv** 0)
     185  'a
     186  ((lv** 1) 0)
     187  'b
     188  (((lv** 1) 1) 0)
     189  'c
     190  (((lv** 1) 1) 1)
     191  'd
     192  (lv** 2)
     193  'f
     194  ((lv** 1) 2)
     195  'e
     196  )
     197;(recursives?)
     198
     199(check-all CALLABLES (callables?) (recursives?))
     200
Note: See TracChangeset for help on using the changeset viewer.