Changeset 35271 in project


Ignore:
Timestamp:
03/10/18 16:01:06 (4 months ago)
Author:
juergen
Message:

generics 0.2 with added standard selectors

Location:
release/4/generics
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/generics/tags/0.2/generics.scm

    r35252 r35271  
    123123
    124124(module generic-helpers
    125   (generic-helpers named-lambda proc-name 1+ 1- 0<= mfx+ mfx*
    126                    reverse* rsplit-with rsplit-at repeat map*)
     125  (generic-helpers named-lambda proc-name 1+ 1- index? mfx+ mfx*
     126   project reverse* rsplit-with rsplit-at repeat map*)
    127127(import scheme
    128128        (only chicken case-lambda error print fx+ fx- fx* fx<=)
     
    165165      (map* fn xs)
    166166      "maps the items of the nested pseudo-list xs via function fn")
     167    (project
     168      procedure:
     169      (project k)
     170      "returns a procedure which selects the kth item of its argument"
     171      "argument list")
    167172    (1+
    168173      procedure:
     
    173178      (1- n)
    174179      "subtract 1 from fixnum n")
    175     (0<=
    176       procedure:
    177       (0<= n)
     180    (index?
     181      procedure:
     182      (index? n)
    178183      "is fixnum n greater or equal to 0")
    179184    (mfx+
     
    204209(define (1+ n) (fx+ n 1))
    205210(define (1- n) (fx- n 1))
    206 (define (0<= n) (fx<= 0 n))
     211(define (index? n) (fx<= 0 n))
    207212(define (mfx+ . nums)
    208213  (let loop ((nums nums) (result 0))
     
    329334      (else (fn pl)))))
    330335
     336;;; (project k)
     337;;; -----------
     338;;; returns a procedure, which chooses the kth item of its argument list
     339(define (project k)
     340  (lambda args (list-ref args k)))
     341
    331342) ; module generic-helpers
    332343
     
    335346            generic? generic-variadic? generic-arity
    336347            define-selector selector selector? selector-parents
    337             any?? define-method
    338             method-tree-item method-tree-item?
     348            selector-predicate any?? number?? integer?? fixnum?? index??
     349            flonum?? list?? vector?? string?? pseudo-list?? pair?? procedure??
     350            define-method method-tree-item method-tree-item?
    339351            method-tree? method-tree-depth method-tree-show
    340352            method-tree-dispatch method-tree-insert)
     
    342354(import scheme
    343355        (only chicken case-lambda receive condition-case define-values
    344               assert gensym error print fx< fx=)
    345         (only generic-helpers 1+ 1- 0<= reverse* map* proc-name)
     356              assert gensym error print fx< fx= fixnum? flonum?)
     357        (only generic-helpers 1+ 1- index? project reverse* map* proc-name)
    346358        (only simple-cells cell)
    347359        (only data-structures list-of?))
     
    393405    (selector
    394406      procedure:
    395       (selector pred parent??)
     407      (selector parent?? pred)
    396408      "makes a special predicate from predicate pred"
    397409      "and selector parent??, which might be #f")
    398410    (define-selector
    399411      macro:
    400       (define-selector name?? pred parent??)
     412      (define-selector name?? parent?? pred)
    401413      "defines a special predicate, name??,"
    402414      "frome its base pradicate, pred,"
     
    407419      (selector-parents sel??)
    408420      "returns the parents of selector sel??")
     421    (selector-predicate
     422      procedure:
     423      (selector-predicate sel??)
     424      "returns the selector's sel?? generating predicate")
    409425    (any??
    410426      procedure:
    411427      (any?? xpr)
    412428      "selector without parent which always returns #t")
     429    (number??
     430      procedure:
     431      (number?? xpr)
     432      "number selector")
     433    (integer??
     434      procedure:
     435      (integer?? xpr)
     436      "integer selector")
     437    (fixnum??
     438      procedure:
     439      (fixnum?? xpr)
     440      "fixnum selector")
     441    (flonum??
     442      procedure:
     443      (flonum?? xpr)
     444      "flonum selector")
     445    (list??
     446      procedure:
     447      (list?? xpr)
     448      "list selector")
     449    (pseudo-list??
     450      procedure:
     451      (pseudo-list?? xpr)
     452      "pseudo-list selector")
     453    (pair??
     454      procedure:
     455      (pair?? xpr)
     456      "pair selector")
     457    (vector??
     458      procedure:
     459      (vector?? xpr)
     460      "vector selector")
     461    (string??
     462      procedure:
     463      (string?? xpr)
     464      "string selector")
     465    (procedure??
     466      procedure:
     467      (procedure?? xpr)
     468      "procedure selector")
     469    (index??
     470      procedure:
     471      (index?? xpr)
     472      "non-negative fixnum selector")
    413473    (method-tree-item
    414474      procedure:
     
    456516;;;;;;;;; --------- ;;;;;;;;;;;
    457517
    458 ;;; (selector pred parent??)
     518;;; (selector parent?? pred)
    459519;;; ----------------------
    460520;;; makes a selector from predicate pred
     
    466526  (let ((type (gensym 'selector)))
    467527    (values
    468       (lambda (pred parent??)
     528      (lambda (parent?? pred)
    469529        (lambda args
    470530          (if (null? args)
    471             (values parent?? type)
     531            (values parent?? pred type)
    472532            (let recur ((args args))
    473533              (if (null? (cdr args))
     
    478538        (and (procedure? xpr)
    479539             (condition-case
    480                (receive (par typ) (xpr)
     540               (receive (par pre typ) (xpr)
    481541                 (eq? typ type))
    482542               ((exn) #f)))))))
    483543
    484 ;;; (define-selector name?? pred parent??)
     544;;; (define-selector name?? parent?? pred)
    485545;;; --------------------------------------
    486546;;; defines a special predicate, name??,
     
    495555(define-syntax define-selector
    496556  (syntax-rules ()
    497     ((_ name?? pred parent??)
     557    ((_ name?? parent?? pred)
    498558     (define (name?? . args)
    499        (apply (selector pred parent??) args)))))
     559       (apply (selector parent?? pred) args)))))
    500560
    501561;;; (selector-parents sel??)
     
    508568      (reverse result))))
    509569
     570;;; (selector-predicate sel??
     571;;; -------------------------
     572;;; returns the generating predicate of the selector sel??
     573(define (selector-predicate sel??)
     574  (call-with-values sel?? (project 1)))
     575
    510576;;; (any?? xpr)
    511577;;; -----------
    512578;;; selector without parent which always returns #t
    513 (define-selector any?? (lambda (xpr) #t) #f)
     579(define-selector any?? #f (lambda (xpr) #t))
     580
     581;;; (number?? xpr)
     582;;; --------------
     583;;; number selector
     584(define-selector number?? any?? number?)
     585
     586;;; (integer?? xpr)
     587;;; ---------------
     588;;; integer selector
     589(define-selector integer?? number?? integer?)
     590
     591;;; (fixnum?? xpr)
     592;;; --------------
     593;;; fixnum selector
     594(define-selector fixnum?? integer?? fixnum?)
     595
     596;;; (flonum?? xpr)
     597;;; --------------
     598;;; flonum selector
     599(define-selector flonum?? number?? flonum?)
     600
     601;;; (pair?? xpr)
     602;;; ------------
     603;;; pair selector
     604(define-selector pair?? any?? pair?)
     605
     606;;; (vector?? xpr)
     607;;; --------------
     608;;; vector selector
     609(define-selector vector?? pair?? vector?)
     610
     611;;; (string?? xpr)
     612;;; --------------
     613;;; string selector
     614(define-selector string?? vector?? string?)
     615
     616;;; (list?? xpr)
     617;;; ------------
     618;;; list selector
     619(define-selector list?? string?? list?)
     620
     621;;; (pseudo-list?? xpr)
     622;;; -------------------
     623;;; pseudo-list selector
     624(define-selector pseudo-list?? any?? (lambda (x) #t))
     625
     626;;; (procedure?? xpr)
     627;;; -----------------
     628;;; procedure selector
     629(define-selector procedure?? any?? procedure?)
     630
     631;;; (index?? xpr)
     632;;; -------------
     633;;; non-negative fixnum selector
     634(define-selector index?? any?? index?)
    514635
    515636;;;;;;;;; method-trees ;;;;;;;;;;;
  • release/4/generics/tags/0.2/generics.setup

    r35252 r35271  
    1010   "generics.import.so"
    1111   "generic-helpers.import.so")
    12  '((version "0.1")))
     12 '((version "0.2")))
  • release/4/generics/tags/0.2/tests/run.scm

    r35252 r35271  
    6060(define-test (Selectors)
    6161  (check
    62     (define-selector number?? number? any??)
    63     (define-selector integer?? integer? number??)
    64     (define-selector fixnum?? fixnum? integer??)
    65 
    66     (define-selector vector?? vector? any??)
    67     (define-selector string?? string? vector??)
    68     (define-selector list?? list? string??)
    69 
    70     (define-selector 0<=?? 0<= any??)
    71 
    7262    (selector? fixnum??)
    7363    (equal? (selector-parents fixnum??)
    7464            `(,integer?? ,number?? ,generics#any??))
    75     (eq? (0<=??) any??)
     65    (eq? (index??) any??)
    7666    ))
    7767
     
    10999    (fx= (method-tree-depth tree) 2)
    110100    (equal? (method-tree-show tree)
    111             '((list?? (list?? . append))
    112               (string?? (string?? . string-append))
    113               (number?? (number?? . C_plus))
     101            '((generics#list?? (generics#list?? . append))
     102              (generics#string?? (generics#string?? . string-append))
     103              (generics#number?? (generics#number?? . C_plus))
    114104              ))
    115     (ppp (method-tree-show tree))
    116105    (eq? (method-tree-dispatch tree '() '()) append)
    117106    (eq? (method-tree-dispatch tree #t #t) #f)
     
    139128    (fx= (method-tree-depth tree) 2)
    140129    (equal? (method-tree-show tree)
    141             '((fixnum?? (fixnum?? . fx+)
    142                         (number?? . fn+))
    143               (number?? (fixnum?? . nf+)
    144                         (number?? . nn+))))
     130            '((generics#fixnum?? (generics#fixnum?? . fx+)
     131                                 (generics#number?? . fn+))
     132              (generics#number?? (generics#fixnum?? . nf+)
     133                                 (generics#number?? . nn+))))
    145134    (eq? (method-tree-dispatch tree 0.0 0.0) nn+)
    146135    (eq? (method-tree-dispatch tree 0 0.0) fn+)
     
    243232    (not (condition-case (Add 1 #f) ((exn) #f)))
    244233
    245     (define-generic (At (k 0<=??) (seq list??)) (list-ref seq k))
    246     (define-generic (Drop (k 0<=??) (seq list??)) (list-tail seq k))
    247     (define-generic (Take (k 0<=??) (seq list??))
     234    (define-generic (At (k index??) (seq list??)) (list-ref seq k))
     235    (define-generic (Drop (k index??) (seq list??)) (list-tail seq k))
     236    (define-generic (Take (k index??) (seq list??))
    248237                    ;(compress (make-list k #t) seq))
    249238                    (let loop ((n 0) (lst seq) (result '()))
     
    260249    (not (generic-variadic? At))
    261250    (= (generic-arity At) 2)
    262     (define-method (At (k 0<=??) (seq vector??)) (vector-ref seq k))
    263     (define-method (Drop (k 0<=??) (seq vector??)) (subvector seq k))
    264     (define-method (Take (k 0<=??) (seq vector??)) (subvector seq 0 k))
    265     (define-method (At (k 0<=??) (seq string??)) (string-ref seq k))
    266     (define-method (Drop (k 0<=??) (seq string??)) (substring seq k))
    267     (define-method (Take (k 0<=??) (seq string??)) (substring seq 0 k))
     251    (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
     252    (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
     253    (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
     254    (define-method (At (k index??) (seq string??)) (string-ref seq k))
     255    (define-method (Drop (k index??) (seq string??)) (substring seq k))
     256    (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
    268257    (not (generic-variadic? At))
    269258    (fx= (generic-arity Take) 2)
  • release/4/generics/trunk/generics.scm

    r35252 r35271  
    123123
    124124(module generic-helpers
    125   (generic-helpers named-lambda proc-name 1+ 1- 0<= mfx+ mfx*
    126                    reverse* rsplit-with rsplit-at repeat map*)
     125  (generic-helpers named-lambda proc-name 1+ 1- index? mfx+ mfx*
     126   project reverse* rsplit-with rsplit-at repeat map*)
    127127(import scheme
    128128        (only chicken case-lambda error print fx+ fx- fx* fx<=)
     
    165165      (map* fn xs)
    166166      "maps the items of the nested pseudo-list xs via function fn")
     167    (project
     168      procedure:
     169      (project k)
     170      "returns a procedure which selects the kth item of its argument"
     171      "argument list")
    167172    (1+
    168173      procedure:
     
    173178      (1- n)
    174179      "subtract 1 from fixnum n")
    175     (0<=
    176       procedure:
    177       (0<= n)
     180    (index?
     181      procedure:
     182      (index? n)
    178183      "is fixnum n greater or equal to 0")
    179184    (mfx+
     
    204209(define (1+ n) (fx+ n 1))
    205210(define (1- n) (fx- n 1))
    206 (define (0<= n) (fx<= 0 n))
     211(define (index? n) (fx<= 0 n))
    207212(define (mfx+ . nums)
    208213  (let loop ((nums nums) (result 0))
     
    329334      (else (fn pl)))))
    330335
     336;;; (project k)
     337;;; -----------
     338;;; returns a procedure, which chooses the kth item of its argument list
     339(define (project k)
     340  (lambda args (list-ref args k)))
     341
    331342) ; module generic-helpers
    332343
     
    335346            generic? generic-variadic? generic-arity
    336347            define-selector selector selector? selector-parents
    337             any?? define-method
    338             method-tree-item method-tree-item?
     348            selector-predicate any?? number?? integer?? fixnum?? index??
     349            flonum?? list?? vector?? string?? pseudo-list?? pair?? procedure??
     350            define-method method-tree-item method-tree-item?
    339351            method-tree? method-tree-depth method-tree-show
    340352            method-tree-dispatch method-tree-insert)
     
    342354(import scheme
    343355        (only chicken case-lambda receive condition-case define-values
    344               assert gensym error print fx< fx=)
    345         (only generic-helpers 1+ 1- 0<= reverse* map* proc-name)
     356              assert gensym error print fx< fx= fixnum? flonum?)
     357        (only generic-helpers 1+ 1- index? project reverse* map* proc-name)
    346358        (only simple-cells cell)
    347359        (only data-structures list-of?))
     
    393405    (selector
    394406      procedure:
    395       (selector pred parent??)
     407      (selector parent?? pred)
    396408      "makes a special predicate from predicate pred"
    397409      "and selector parent??, which might be #f")
    398410    (define-selector
    399411      macro:
    400       (define-selector name?? pred parent??)
     412      (define-selector name?? parent?? pred)
    401413      "defines a special predicate, name??,"
    402414      "frome its base pradicate, pred,"
     
    407419      (selector-parents sel??)
    408420      "returns the parents of selector sel??")
     421    (selector-predicate
     422      procedure:
     423      (selector-predicate sel??)
     424      "returns the selector's sel?? generating predicate")
    409425    (any??
    410426      procedure:
    411427      (any?? xpr)
    412428      "selector without parent which always returns #t")
     429    (number??
     430      procedure:
     431      (number?? xpr)
     432      "number selector")
     433    (integer??
     434      procedure:
     435      (integer?? xpr)
     436      "integer selector")
     437    (fixnum??
     438      procedure:
     439      (fixnum?? xpr)
     440      "fixnum selector")
     441    (flonum??
     442      procedure:
     443      (flonum?? xpr)
     444      "flonum selector")
     445    (list??
     446      procedure:
     447      (list?? xpr)
     448      "list selector")
     449    (pseudo-list??
     450      procedure:
     451      (pseudo-list?? xpr)
     452      "pseudo-list selector")
     453    (pair??
     454      procedure:
     455      (pair?? xpr)
     456      "pair selector")
     457    (vector??
     458      procedure:
     459      (vector?? xpr)
     460      "vector selector")
     461    (string??
     462      procedure:
     463      (string?? xpr)
     464      "string selector")
     465    (procedure??
     466      procedure:
     467      (procedure?? xpr)
     468      "procedure selector")
     469    (index??
     470      procedure:
     471      (index?? xpr)
     472      "non-negative fixnum selector")
    413473    (method-tree-item
    414474      procedure:
     
    456516;;;;;;;;; --------- ;;;;;;;;;;;
    457517
    458 ;;; (selector pred parent??)
     518;;; (selector parent?? pred)
    459519;;; ----------------------
    460520;;; makes a selector from predicate pred
     
    466526  (let ((type (gensym 'selector)))
    467527    (values
    468       (lambda (pred parent??)
     528      (lambda (parent?? pred)
    469529        (lambda args
    470530          (if (null? args)
    471             (values parent?? type)
     531            (values parent?? pred type)
    472532            (let recur ((args args))
    473533              (if (null? (cdr args))
     
    478538        (and (procedure? xpr)
    479539             (condition-case
    480                (receive (par typ) (xpr)
     540               (receive (par pre typ) (xpr)
    481541                 (eq? typ type))
    482542               ((exn) #f)))))))
    483543
    484 ;;; (define-selector name?? pred parent??)
     544;;; (define-selector name?? parent?? pred)
    485545;;; --------------------------------------
    486546;;; defines a special predicate, name??,
     
    495555(define-syntax define-selector
    496556  (syntax-rules ()
    497     ((_ name?? pred parent??)
     557    ((_ name?? parent?? pred)
    498558     (define (name?? . args)
    499        (apply (selector pred parent??) args)))))
     559       (apply (selector parent?? pred) args)))))
    500560
    501561;;; (selector-parents sel??)
     
    508568      (reverse result))))
    509569
     570;;; (selector-predicate sel??
     571;;; -------------------------
     572;;; returns the generating predicate of the selector sel??
     573(define (selector-predicate sel??)
     574  (call-with-values sel?? (project 1)))
     575
    510576;;; (any?? xpr)
    511577;;; -----------
    512578;;; selector without parent which always returns #t
    513 (define-selector any?? (lambda (xpr) #t) #f)
     579(define-selector any?? #f (lambda (xpr) #t))
     580
     581;;; (number?? xpr)
     582;;; --------------
     583;;; number selector
     584(define-selector number?? any?? number?)
     585
     586;;; (integer?? xpr)
     587;;; ---------------
     588;;; integer selector
     589(define-selector integer?? number?? integer?)
     590
     591;;; (fixnum?? xpr)
     592;;; --------------
     593;;; fixnum selector
     594(define-selector fixnum?? integer?? fixnum?)
     595
     596;;; (flonum?? xpr)
     597;;; --------------
     598;;; flonum selector
     599(define-selector flonum?? number?? flonum?)
     600
     601;;; (pair?? xpr)
     602;;; ------------
     603;;; pair selector
     604(define-selector pair?? any?? pair?)
     605
     606;;; (vector?? xpr)
     607;;; --------------
     608;;; vector selector
     609(define-selector vector?? pair?? vector?)
     610
     611;;; (string?? xpr)
     612;;; --------------
     613;;; string selector
     614(define-selector string?? vector?? string?)
     615
     616;;; (list?? xpr)
     617;;; ------------
     618;;; list selector
     619(define-selector list?? string?? list?)
     620
     621;;; (pseudo-list?? xpr)
     622;;; -------------------
     623;;; pseudo-list selector
     624(define-selector pseudo-list?? any?? (lambda (x) #t))
     625
     626;;; (procedure?? xpr)
     627;;; -----------------
     628;;; procedure selector
     629(define-selector procedure?? any?? procedure?)
     630
     631;;; (index?? xpr)
     632;;; -------------
     633;;; non-negative fixnum selector
     634(define-selector index?? any?? index?)
    514635
    515636;;;;;;;;; method-trees ;;;;;;;;;;;
  • release/4/generics/trunk/generics.setup

    r35252 r35271  
    1010   "generics.import.so"
    1111   "generic-helpers.import.so")
    12  '((version "0.1")))
     12 '((version "0.2")))
  • release/4/generics/trunk/tests/run.scm

    r35252 r35271  
    6060(define-test (Selectors)
    6161  (check
    62     (define-selector number?? number? any??)
    63     (define-selector integer?? integer? number??)
    64     (define-selector fixnum?? fixnum? integer??)
    65 
    66     (define-selector vector?? vector? any??)
    67     (define-selector string?? string? vector??)
    68     (define-selector list?? list? string??)
    69 
    70     (define-selector 0<=?? 0<= any??)
    71 
    7262    (selector? fixnum??)
    7363    (equal? (selector-parents fixnum??)
    7464            `(,integer?? ,number?? ,generics#any??))
    75     (eq? (0<=??) any??)
     65    (eq? (index??) any??)
    7666    ))
    7767
     
    10999    (fx= (method-tree-depth tree) 2)
    110100    (equal? (method-tree-show tree)
    111             '((list?? (list?? . append))
    112               (string?? (string?? . string-append))
    113               (number?? (number?? . C_plus))
     101            '((generics#list?? (generics#list?? . append))
     102              (generics#string?? (generics#string?? . string-append))
     103              (generics#number?? (generics#number?? . C_plus))
    114104              ))
    115     (ppp (method-tree-show tree))
    116105    (eq? (method-tree-dispatch tree '() '()) append)
    117106    (eq? (method-tree-dispatch tree #t #t) #f)
     
    139128    (fx= (method-tree-depth tree) 2)
    140129    (equal? (method-tree-show tree)
    141             '((fixnum?? (fixnum?? . fx+)
    142                         (number?? . fn+))
    143               (number?? (fixnum?? . nf+)
    144                         (number?? . nn+))))
     130            '((generics#fixnum?? (generics#fixnum?? . fx+)
     131                                 (generics#number?? . fn+))
     132              (generics#number?? (generics#fixnum?? . nf+)
     133                                 (generics#number?? . nn+))))
    145134    (eq? (method-tree-dispatch tree 0.0 0.0) nn+)
    146135    (eq? (method-tree-dispatch tree 0 0.0) fn+)
     
    243232    (not (condition-case (Add 1 #f) ((exn) #f)))
    244233
    245     (define-generic (At (k 0<=??) (seq list??)) (list-ref seq k))
    246     (define-generic (Drop (k 0<=??) (seq list??)) (list-tail seq k))
    247     (define-generic (Take (k 0<=??) (seq list??))
     234    (define-generic (At (k index??) (seq list??)) (list-ref seq k))
     235    (define-generic (Drop (k index??) (seq list??)) (list-tail seq k))
     236    (define-generic (Take (k index??) (seq list??))
    248237                    ;(compress (make-list k #t) seq))
    249238                    (let loop ((n 0) (lst seq) (result '()))
     
    260249    (not (generic-variadic? At))
    261250    (= (generic-arity At) 2)
    262     (define-method (At (k 0<=??) (seq vector??)) (vector-ref seq k))
    263     (define-method (Drop (k 0<=??) (seq vector??)) (subvector seq k))
    264     (define-method (Take (k 0<=??) (seq vector??)) (subvector seq 0 k))
    265     (define-method (At (k 0<=??) (seq string??)) (string-ref seq k))
    266     (define-method (Drop (k 0<=??) (seq string??)) (substring seq k))
    267     (define-method (Take (k 0<=??) (seq string??)) (substring seq 0 k))
     251    (define-method (At (k index??) (seq vector??)) (vector-ref seq k))
     252    (define-method (Drop (k index??) (seq vector??)) (subvector seq k))
     253    (define-method (Take (k index??) (seq vector??)) (subvector seq 0 k))
     254    (define-method (At (k index??) (seq string??)) (string-ref seq k))
     255    (define-method (Drop (k index??) (seq string??)) (substring seq k))
     256    (define-method (Take (k index??) (seq string??)) (substring seq 0 k))
    268257    (not (generic-variadic? At))
    269258    (fx= (generic-arity Take) 2)
Note: See TracChangeset for help on using the changeset viewer.