Changeset 29131 in project


Ignore:
Timestamp:
06/19/13 13:19:53 (8 years ago)
Author:
juergen
Message:

method and the checkers changed

Location:
release/4/multi-methods
Files:
3 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/4/multi-methods/tags/0.4/multi-methods.scm

    r29121 r29131  
    109109       (if (eq? proc state)
    110110         (list doc . docs)
    111          (lambda args
    112            (apply proc args)))))))
    113 
    114 ;;; (command-checker check0 check1 ...)
    115 ;;; -----------------------------------
     111         proc)))))
     112
     113;;; (command-checker (check0 doc0) (check1 doc1) ...)
     114;;; -------------------------------------------------
    116115;;; Each check must be a function of the same arguments as the command
    117 ;;; to be checked and return three values, the query which shows what is
    118 ;;; to be changed, a compare routine comparing query's result before and
    119 ;;; after the call of command, and documentation.
     116;;; to be checked and return two values, the the matching query's
     117;;; result, which shows what is to be changed, a compare routine
     118;;; comparing query's result before and after the call of command.
    120119(define-syntax command-checker
    121120  (syntax-rules ()
    122     ((_ check0 check1 ...)
     121    ((_ (check0 doc0) (check1 doc1) ...)
    123122     (lambda (command)
    124        (lambda args
    125          (let* ((checks (list check0 check1 ...))
    126                 (docs
    127                    (map (lambda (check)
    128                           (call-with-values
    129                             (lambda () (apply check args))
    130                             (lambda (q c doc) doc)))
    131                         checks)))
    132            (cond
    133              ((eq? command state)
    134               docs)
    135              ((effects-checked?)
    136               (let ((olds
    137                       (map (lambda (check)
    138                              (call-with-values
    139                                (lambda () (apply check args))
    140                                (lambda (query c d) query)))
    141                            checks)))
    142                 (apply command args)
    143                 (let loop ((olds olds)
    144                            (news
    145                              (map (lambda (check)
    146                                     (call-with-values
    147                                       (lambda () (apply check args))
    148                                       (lambda (query c d) query)))
    149                                   checks))
    150                            (compares
    151                              (map (lambda (check)
    152                                     (call-with-values
    153                                       (lambda () (apply check args))
    154                                       (lambda (q compare d) compare)))
    155                                   checks))
    156                            (docs docs))
    157                     (cond
    158                       ((null? compares)
    159                        (void)) ; success
    160                       (((car compares) (car olds) (car news))
    161                        (loop (cdr olds) (cdr news) (cdr compares) (cdr docs)))
    162                       (else
    163                         (error (procedure-data command)
    164                                (format #f "postcondition violated: ~s with args ~s, old ~s and new ~s"
    165                                        args
    166                                        (car docs)
    167                                        (car olds)
    168                                        (car news))))))))
    169              (else
    170                (apply command args)))))))))
    171 
    172 ;;; (query-checker check0 check1 ...)
    173 ;;; ---------------------------------
     123       (cond
     124         ((eq? command state)
     125          (list doc0 doc1 ...))
     126         ((not (effects-checked?))
     127          command)
     128         (else
     129           (lambda args
     130             (let ((checks (list check0 check1 ...)))
     131               ;; evalute queries before the call
     132               (let ((olds (map (lambda (check)
     133                                  (call-with-values
     134                                    (lambda () (apply check args))
     135                                    (lambda (query c) query)))
     136                                checks)))
     137                 ;; evaluate command
     138                 (apply command args)
     139                 (let loop ((olds olds)
     140                            ;; evalute queries after the call
     141                            (news (map (lambda (check)
     142                                         (call-with-values
     143                                           (lambda () (apply check args))
     144                                           (lambda (query c) query)))
     145                                       checks))
     146                            (compares (map (lambda (check)
     147                                             (call-with-values
     148                                               (lambda () (apply check args))
     149                                               (lambda (q compare) compare)))
     150                                           checks))
     151                            (docs (list doc0 doc1 ...)))
     152                   (cond
     153                     ((null? compares)
     154                      ; all query results successfully compared
     155                      (void))
     156                     (((car compares) (car olds) (car news))
     157                      ; first query result successfully compared,
     158                      ; check the others
     159                      (loop (cdr olds) (cdr news) (cdr compares) (cdr docs)))
     160                     (else
     161                       (error (procedure-data command)
     162                              (format #f "postcondition violated: ~s with args ~s, old ~s and new ~s"
     163                                      (car docs)
     164                                      args
     165                                      (car olds)
     166                                      (car news)))))))))))))))
     167
     168;;; (query-checker (check0 doc0) (check1 doc1) ...)
     169;;; -----------------------------------------------
    174170;;; where the number of checks is equal to the number of results.
    175171;;; Each check is a procedure of the same arguments as the query to be
    176 ;;; checked - the checker's only argument - and returns two values, a
    177 ;;; predicate on query's returned value and documentation.
     172;;; checked - the checker's only argument - and returns a predicate on
     173;;; query's returned value.
    178174(define-syntax query-checker
    179175  (syntax-rules ()
    180     ((_ check0 check1 ...)
     176    ((_ (check0 doc0) (check1 doc1) ...)
    181177     (lambda (query)
    182        (lambda args
    183          (let ((all-results (call-with-values
    184                               (lambda () (apply query args))
    185                               list))
    186                (all-checks (list check0 check1 ...)))
    187            (assert (fx= (length all-results) (length all-checks)))
    188            (cond
    189              ((not (effects-checked?))
    190               (apply query args))
    191              ((eq? query state)
    192               (map (lambda (check)
    193                      (call-with-values
    194                        (lambda () (apply check args))
    195                        (lambda (proc doc) doc)))
    196                    all-checks))
    197              (else
    198                (let loop ((results all-results) (checks all-checks))
    199                  (cond
    200                    ((null? results)
    201                     (apply values all-results))
    202                    (((apply (car checks) args) (car results))
    203                     (loop (cdr results) (cdr checks)))
    204                    (else
    205                      (error (procedure-data query)
    206                             (format #f "postcondition violated: ~s with args ~s and result ~s"
    207                                      (call-with-values
    208                                        (lambda () (apply (car checks) args))
    209                                        (lambda (proc doc) doc))
    210                                      args (car results))))))))))))))
    211 
    212 
    213 ;;; (method [variadic?]
    214 ;;;         (proc-name proc effect-checker doc . docs)
    215 ;;;         (name pred . preds)
    216 ;;;         ...)
    217 ;;; --------------------------------------------------
     178       (cond
     179         ((eq? query state)
     180          (list doc0 doc1 ...))
     181         ((not (effects-checked?))
     182          query)
     183         (else
     184           (lambda args
     185             (let ((all-results (call-with-values
     186                                  (lambda () (apply query args))
     187                                  list))
     188                   (all-checks (list check0 check1 ...)))
     189               (assert (fx= (length all-results) (length all-checks)))
     190               (let loop ((results all-results)
     191                          (checks all-checks)
     192                          (docs (list doc0 doc1 ...)))
     193               (cond
     194                 ((null? results)
     195                  ;all results checked, return them
     196                  (apply values all-results))
     197                 (((apply (car checks) args) (car results))
     198                  ; first result positively checked, test the others
     199                  (loop (cdr results) (cdr checks) (cdr docs)))
     200                 (else
     201                   (error (procedure-data query)
     202                          (format #f
     203                                  "postcondition violated: ~s with args ~s and result ~s"
     204                                  (car docs) args (car results))))))))))))))
     205
     206
     207;;; (method [variadic?] (proc-name proc effect-checker) (name pred . preds) ...)
     208;;; ----------------------------------------------------------------------------
    218209;;; method datatye constructor.
    219 ;;; proc is the actual procedure which is ultimately called
    220 ;;; effect-checker checks proc's return values or side-effects,
    221 ;;; i.e. either query-checker or command-checker is used,
     210;;; proc is the actual procedure which is ultimately called,
     211;;; effect-checker a procedure which accepts either proc or a special
     212;;; symbol as argument and returns that very proc after having checked
     213;;; its return values or side-effects, or returns documentation. Usually
     214;;; effect-checker is one of no-checker, query-checker or
     215;;; command-checker.
    222216;;; name a symbol describing the predicate (conjoin pred . preds) which
    223217;;; do the argument checks.
     
    240234              (if (null? preds)
    241235                ;; thunk
    242                 (apply proc args)
     236                (proc)
    243237                (receive (tail-args head-args) (split args (- (length preds) 1))
    244238                  (let loop ((head-args head-args) (preds preds))
     
    267261          (proc (cadr head))
    268262          (checker (caddr head))
    269           (docs (cdddr head))
    270263          (names (map car tail))
    271264          (preds (map cdr tail))
    272265          )
    273      `(let ((proc-list
    274               (list
    275                 (extend-procedure (,checker ,proc) ,proc-name)
    276                 ,@(map (lambda (ps n)
    277                          `(extend-procedure (conjoin ,@ps) ,n))
    278                        preds names)))) 
    279        (lambda  args
    280          (if (and (not (null? args))
    281                   (null? (cdr args))
    282                   (eq? (car args) state))
    283            (lambda (sym)
    284              (case sym
    285                ((proc-list) proc-list)
    286                ((effects) (,checker state))
    287                ((doc) (list ,@docs))
    288                ((arity) (length (cdr proc-list)))
    289                ((variadic?) ,variadic?)
    290                ((name) ,proc-name)
    291                ((type) 'method)
    292                (else (error ,proc-name
    293                             "message not understood"
    294                             sym))))
    295            (apply ',check-and-call proc-list ,variadic? args)))))))))
     266          `(let ((proc-list
     267                   (list
     268                     (extend-procedure (,checker ,proc) ,proc-name)
     269                     ,@(map (lambda (ps n)
     270                              `(extend-procedure (conjoin ,@ps) ,n))
     271                            preds names))))
     272             (lambda  args
     273               (if (and (not (null? args))
     274                        (null? (cdr args))
     275                        (eq? (car args) state))
     276                 (lambda (sym)
     277                   (case sym
     278                     ((proc-list) proc-list)
     279                     ((effects) (,checker state))
     280                     ((arity) (length (cdr proc-list)))
     281                     ((variadic?) ,variadic?)
     282                     ((name) ,proc-name)
     283                     ((type) 'method)
     284                     (else (error ,proc-name
     285                                  "message not understood"
     286                                  sym))))
     287                 (apply ',check-and-call proc-list ,variadic? args)))))))))
    296288
    297289(define (method? xpr)
     
    335327        ((no-checker)
    336328         '(macro ()
    337             ((_ doc . docs)
     329            ((_ doc0 doc1 ...)
    338330             "documentation strings or symbols"
    339              "returns a procedure which which returns its procure argument unchecked")))
     331             "returns a procedure which passes its proceure argument unchecked")))
    340332        ((command-checker)
    341333         '(macro ()
    342             ((_ check0 check1 ...)
    343 "checks are procedures of the same arguments as the command to check returning three values - query-call, compare-proc, doc-string -  needed for checking"
    344              "returns the command in case of successfull tests")))
     334            ((_ (check0 doc0) (check1 doc1) ...)
     335"checks are procedures of the same arguments as the command to check returning two values - query-call and compare-proc -  needed for checking"
     336"returns a prodedure, which accepts the command as argument and returns command in case of successfull tests")))
    345337        ((query-checker)
    346338         '(macro ()
    347             ((_ check0 check1 ...)
    348              "all checks are procedures of the same arguments as the query to be checked - the checker's only argument - and return two values, a predicate checking the return value and documentation" "returns the query in case of successfull tests")))
     339            ((_ (check0 doc0) (check1 doc1) ...)
     340"all checks are procedures of the same arguments as the query to be checked and returns a predicate checking the return value"
     341"returns a prodedure, which accepts the query as argument and returns query in case of successfull tests")))
    349342        ((method)
    350343         '(macro ()
    351344            ((_ [variadic?]
    352                 (proc-name proc effect-checker doc . docs)
     345                (proc-name proc effect-checker)
    353346                (name pred . preds)
    354347                ...)
  • release/4/multi-methods/tags/0.4/multi-methods.setup

    r29121 r29131  
    99 'multi-methods
    1010 '("multi-methods.so" "method-helper.import.so" "methods.import.so" "multi-methods.import.so")
    11  '((version "0.3.1")))
     11 '((version "0.4")))
  • release/4/multi-methods/tags/0.4/tests/run.scm

    r29120 r29131  
    77  "EFFECT-CHECKERS"
    88  (= (((no-checker "doc") add1) 5) 6)
    9   (= (((query-checker (lambda (n) (values (lambda (result)
    10                                             (= result (+ n 1)))
    11                                           '(= result (+ n 1)))))
     9  (= (((query-checker ((lambda (n)
     10                         (lambda (result)
     11                           (= result (+ n 1))))
     12                       '(= result (+ n 1))))
    1213       add1) 5) 6)
    1314  (define pair (cons 1 2))
    14   (((command-checker (lambda (pair val)
    15                        (values (car pair)
    16                                (lambda (old new) (equal? (car pair) new))
    17                                "(equal? (car pair) new)")))
     15  (((command-checker ((lambda (pair val)
     16                        (values (car pair)
     17                                (lambda (old new)
     18                                  (equal? (car pair) new))))
     19                      '(equal? (car pair) new)))
    1820    (extend-procedure set-car! 'set-car!))
    1921    pair 10)
    2022  "POSTCONDITION VIOLATED:"
    2123  (condition-case
    22     (((command-checker (lambda (pair val)
    23                          (values (car pair)
    24                                  (lambda (old new)
    25                                    (equal? (car pair) (add1 new)))
    26                                "(equal? (car pair) new)")))
     24    (((command-checker ((lambda (pair val)
     25                          (values (car pair)
     26                                  (lambda (old new)
     27                                    (equal? (car pair) (add1 new)))))
     28                        '(equal? (car pair) new)))
    2729      (extend-procedure set-car! 'set-car!))
    2830     pair 10)
    29     ((exn) #t))
    30   (condition-case
    31     (((query-checker (lambda (n) (values (lambda (result)
    32                                            (= result n))
    33                                          '(= result n))))
     31    ((exn) "postcondition violated"))
     32  (condition-case
     33    (((query-checker ((lambda (n)
     34                        (lambda (result)
     35                          (= result n)))
     36                      '(= result n)))
    3437      add1) 5)
    35     ((exn) #t))
     38    ((exn) "postcondition violated"))
    3639  "THUNK METHOD"
    3740  (define foo
     
    3942             (lambda () 'foo)
    4043             (query-checker
    41                (lambda ()
    42                  (values
    43                    (lambda (result)
    44                      (and (symbol? result) (eq? result 'foo)))
    45                    '(and (symbol? result) (eq? result 'foo))))))))
     44               ((lambda ()
     45                  (lambda (result)
     46                    (and (symbol? result) (eq? result 'foo))))
     47                '(and (symbol? result) (eq? result 'foo)))))))
    4648  (method? foo)
    4749  (eq? (foo) 'foo)
     
    5153             add1
    5254             (query-checker
    53                (lambda (n)
    54                  (values
    55                    (lambda (result)
    56                      (and (fixnum? result) (= result (+ n 1))))
    57                    '(and (fixnum? result) (= result (+ n 1))))))
    58                "add1" "violates postcondition")
     55               ((lambda (n)
     56                  (lambda (result)
     57                    (and (fixnum? result) (= result (+ n 1)))))
     58                '(and (fixnum? result) (= result (+ n 1))))))
    5959            ('1number? number?)))
    6060  (fx= (1+-number? 5) 6)
     
    6666             add1
    6767             (query-checker
    68                (lambda (n)
    69                  (values
    70                    (lambda (result)
    71                      (and (integer? result) (= result (+ n 1))))
    72                    '(and (integer? result) (= result (+ n 1))))))
    73             "add1")
     68               ((lambda (n)
     69                  (lambda (result)
     70                    (and (integer? result) (= result (+ n 1)))))
     71                '(and (integer? result) (= result (+ n 1))))))
    7472            ('1integer?negative? integer? negative?)))
    7573  (define 1+-fixnum?
     
    7775             (cut fx+ <> 1)
    7876             (query-checker
    79                (lambda (n)
    80                  (values
    81                    (lambda (result)
    82                      (and (fixnum? result) (fx= result (fx+ n 1))))
    83                    '(and (fixnum? result) (fx= result (fx+ n 1))))))
    84              "fx1+")
     77               ((lambda (n)
     78                  (lambda (result)
     79                    (and (fixnum? result) (fx= result (fx+ n 1)))))
     80                '(and (fixnum? result) (fx= result (fx+ n 1))))))
    8581            ('1fixnum? fixnum?)))
    8682  (fx= (1+-fixnum? 5) 6)
     
    10096             +
    10197             (query-checker
    102                (lambda (x y)
    103                  (values
    104                    (lambda (result)
    105                      (and (even? result) (= result (+ x y))))
    106                    '(and (even? result) (= result (+ x y))))))
    107              "+" "violates postcondition")
     98               ((lambda (x y)
     99                  (lambda (result)
     100                    (and (even? result) (= result (+ x y)))))
     101                '(and (even? result) (= result (+ x y))))))
    108102            ('1odd? odd?)
    109103            ('2even? even?)))
     
    112106             fx+
    113107             (query-checker
    114                (lambda (x y)
    115                  (values
    116                    (lambda (result)
    117                      (and (fixnum? result) (fx= result (fx+ x y))))
    118                    '(and (fixnum? result) (fx= result (fx+ x y))))))
    119              "fx+")
     108               ((lambda (x y)
     109                  (lambda (result)
     110                    (and (fixnum? result) (fx= result (fx+ x y)))))
     111                '(and (fixnum? result) (fx= result (fx+ x y))))))
    120112            ('1fixnum? fixnum?)
    121113            ('2fixnum? fixnum?)))
     
    124116             +
    125117             (query-checker
    126                (lambda (x y)
    127                  (values
    128                    (lambda (result)
    129                      (and (number? result) (= result (+ x y))))
    130                    '(and (number? result) (= result (+ x y))))))
    131              "+")
     118               ((lambda (x y)
     119                  (lambda (result)
     120                    (and (number? result) (= result (+ x y)))))
     121                '(and (number? result) (= result (+ x y))))))
    132122            ('1fixnum? fixnum?)
    133123            ('2number? number?)))
     
    140130             *
    141131             (query-checker
    142                (lambda xs
    143                  (values
    144                    (lambda (result)
    145                      (and (odd? result) (= result (apply * xs))))
    146                    '(and (odd? result) (= result (apply * xs))))))
    147              "*" "postcondition")
     132               ((lambda xs
     133                  (lambda (result)
     134                    (and (odd? result) (= result (apply * xs)))))
     135                '(and (odd? result) (= result (apply * xs))))))
    148136            ('1list-of-number? (list-of? number?))))
    149137  (define *-list-of-integer?
     
    152140             *
    153141             (query-checker
    154                (lambda xs
    155                  (values
    156                    (lambda (result)
    157                      (and (integer? result) (= result (apply * xs))))
    158                    '(and (integer? result) (= result (apply * xs))))))
    159              "*")
     142               ((lambda xs
     143                  (lambda (result)
     144                    (and (integer? result) (= result (apply * xs)))))
     145                '(and (integer? result) (= result (apply * xs))))))
    160146            ('1list-of-integer? (list-of? integer?))))
    161147  (method-variadic? *-list-of-integer?)
     
    171157             *
    172158             (query-checker
    173                (lambda (x . xs)
    174                  (values
    175                    (lambda (result)
    176                      (and (number? result) (= result (apply * x xs))))
    177                    '(and (number? result) (= result (apply * x xs))))))
    178              "*")
     159               ((lambda (x . xs)
     160                  (lambda (result)
     161                    (and (number? result) (= result (apply * x xs)))))
     162                '(and (number? result) (= result (apply * x xs))))))
    179163            ('1number? number?)
    180164            ('2list-of-number? (list-of? number?))))
     
    190174             fx**
    191175             (query-checker
    192                (lambda (x . xs)
    193                  (values
    194                    (lambda (result)
    195                      (and (fixnum? result) (= result (apply fx** x xs))))
    196                    '(and (fixnum? result) (= result (apply fx** x xs))))))
    197              "fx**")
     176               ((lambda (x . xs)
     177                  (lambda (result)
     178                    (and (fixnum? result) (= result (apply fx** x xs)))))
     179                '(and (fixnum? result) (= result (apply fx** x xs))))))
    198180            ('1fixnum? fixnum?)
    199181            ('2list-of-fixnum? (list-of? fixnum?))))
     
    203185             *
    204186             (query-checker
    205                (lambda (x . xs)
    206                  (values
    207                    (lambda (result)
    208                      (and (number? result) (= result (apply * x xs))))
    209                    '(and (number? result) (= result (apply * x xs))))))
    210              "*")
     187               ((lambda (x . xs)
     188                  (lambda (result)
     189                    (and (number? result) (= result (apply * x xs)))))
     190                '(and (number? result) (= result (apply * x xs))))))
    211191            ('1fixnum? fixnum?)
    212192            ('2list-of-number? (list-of? number?))))
    213 )
    214 
    215 (run-tests
    216193  "A MULTI-METHOD OF ARITY 1"
    217194  (define 1+ (multi-method x))
  • release/4/multi-methods/trunk/multi-methods.scm

    r29121 r29131  
    109109       (if (eq? proc state)
    110110         (list doc . docs)
    111          (lambda args
    112            (apply proc args)))))))
    113 
    114 ;;; (command-checker check0 check1 ...)
    115 ;;; -----------------------------------
     111         proc)))))
     112
     113;;; (command-checker (check0 doc0) (check1 doc1) ...)
     114;;; -------------------------------------------------
    116115;;; Each check must be a function of the same arguments as the command
    117 ;;; to be checked and return three values, the query which shows what is
    118 ;;; to be changed, a compare routine comparing query's result before and
    119 ;;; after the call of command, and documentation.
     116;;; to be checked and return two values, the the matching query's
     117;;; result, which shows what is to be changed, a compare routine
     118;;; comparing query's result before and after the call of command.
    120119(define-syntax command-checker
    121120  (syntax-rules ()
    122     ((_ check0 check1 ...)
     121    ((_ (check0 doc0) (check1 doc1) ...)
    123122     (lambda (command)
    124        (lambda args
    125          (let* ((checks (list check0 check1 ...))
    126                 (docs
    127                    (map (lambda (check)
    128                           (call-with-values
    129                             (lambda () (apply check args))
    130                             (lambda (q c doc) doc)))
    131                         checks)))
    132            (cond
    133              ((eq? command state)
    134               docs)
    135              ((effects-checked?)
    136               (let ((olds
    137                       (map (lambda (check)
    138                              (call-with-values
    139                                (lambda () (apply check args))
    140                                (lambda (query c d) query)))
    141                            checks)))
    142                 (apply command args)
    143                 (let loop ((olds olds)
    144                            (news
    145                              (map (lambda (check)
    146                                     (call-with-values
    147                                       (lambda () (apply check args))
    148                                       (lambda (query c d) query)))
    149                                   checks))
    150                            (compares
    151                              (map (lambda (check)
    152                                     (call-with-values
    153                                       (lambda () (apply check args))
    154                                       (lambda (q compare d) compare)))
    155                                   checks))
    156                            (docs docs))
    157                     (cond
    158                       ((null? compares)
    159                        (void)) ; success
    160                       (((car compares) (car olds) (car news))
    161                        (loop (cdr olds) (cdr news) (cdr compares) (cdr docs)))
    162                       (else
    163                         (error (procedure-data command)
    164                                (format #f "postcondition violated: ~s with args ~s, old ~s and new ~s"
    165                                        args
    166                                        (car docs)
    167                                        (car olds)
    168                                        (car news))))))))
    169              (else
    170                (apply command args)))))))))
    171 
    172 ;;; (query-checker check0 check1 ...)
    173 ;;; ---------------------------------
     123       (cond
     124         ((eq? command state)
     125          (list doc0 doc1 ...))
     126         ((not (effects-checked?))
     127          command)
     128         (else
     129           (lambda args
     130             (let ((checks (list check0 check1 ...)))
     131               ;; evalute queries before the call
     132               (let ((olds (map (lambda (check)
     133                                  (call-with-values
     134                                    (lambda () (apply check args))
     135                                    (lambda (query c) query)))
     136                                checks)))
     137                 ;; evaluate command
     138                 (apply command args)
     139                 (let loop ((olds olds)
     140                            ;; evalute queries after the call
     141                            (news (map (lambda (check)
     142                                         (call-with-values
     143                                           (lambda () (apply check args))
     144                                           (lambda (query c) query)))
     145                                       checks))
     146                            (compares (map (lambda (check)
     147                                             (call-with-values
     148                                               (lambda () (apply check args))
     149                                               (lambda (q compare) compare)))
     150                                           checks))
     151                            (docs (list doc0 doc1 ...)))
     152                   (cond
     153                     ((null? compares)
     154                      ; all query results successfully compared
     155                      (void))
     156                     (((car compares) (car olds) (car news))
     157                      ; first query result successfully compared,
     158                      ; check the others
     159                      (loop (cdr olds) (cdr news) (cdr compares) (cdr docs)))
     160                     (else
     161                       (error (procedure-data command)
     162                              (format #f "postcondition violated: ~s with args ~s, old ~s and new ~s"
     163                                      (car docs)
     164                                      args
     165                                      (car olds)
     166                                      (car news)))))))))))))))
     167
     168;;; (query-checker (check0 doc0) (check1 doc1) ...)
     169;;; -----------------------------------------------
    174170;;; where the number of checks is equal to the number of results.
    175171;;; Each check is a procedure of the same arguments as the query to be
    176 ;;; checked - the checker's only argument - and returns two values, a
    177 ;;; predicate on query's returned value and documentation.
     172;;; checked - the checker's only argument - and returns a predicate on
     173;;; query's returned value.
    178174(define-syntax query-checker
    179175  (syntax-rules ()
    180     ((_ check0 check1 ...)
     176    ((_ (check0 doc0) (check1 doc1) ...)
    181177     (lambda (query)
    182        (lambda args
    183          (let ((all-results (call-with-values
    184                               (lambda () (apply query args))
    185                               list))
    186                (all-checks (list check0 check1 ...)))
    187            (assert (fx= (length all-results) (length all-checks)))
    188            (cond
    189              ((not (effects-checked?))
    190               (apply query args))
    191              ((eq? query state)
    192               (map (lambda (check)
    193                      (call-with-values
    194                        (lambda () (apply check args))
    195                        (lambda (proc doc) doc)))
    196                    all-checks))
    197              (else
    198                (let loop ((results all-results) (checks all-checks))
    199                  (cond
    200                    ((null? results)
    201                     (apply values all-results))
    202                    (((apply (car checks) args) (car results))
    203                     (loop (cdr results) (cdr checks)))
    204                    (else
    205                      (error (procedure-data query)
    206                             (format #f "postcondition violated: ~s with args ~s and result ~s"
    207                                      (call-with-values
    208                                        (lambda () (apply (car checks) args))
    209                                        (lambda (proc doc) doc))
    210                                      args (car results))))))))))))))
    211 
    212 
    213 ;;; (method [variadic?]
    214 ;;;         (proc-name proc effect-checker doc . docs)
    215 ;;;         (name pred . preds)
    216 ;;;         ...)
    217 ;;; --------------------------------------------------
     178       (cond
     179         ((eq? query state)
     180          (list doc0 doc1 ...))
     181         ((not (effects-checked?))
     182          query)
     183         (else
     184           (lambda args
     185             (let ((all-results (call-with-values
     186                                  (lambda () (apply query args))
     187                                  list))
     188                   (all-checks (list check0 check1 ...)))
     189               (assert (fx= (length all-results) (length all-checks)))
     190               (let loop ((results all-results)
     191                          (checks all-checks)
     192                          (docs (list doc0 doc1 ...)))
     193               (cond
     194                 ((null? results)
     195                  ;all results checked, return them
     196                  (apply values all-results))
     197                 (((apply (car checks) args) (car results))
     198                  ; first result positively checked, test the others
     199                  (loop (cdr results) (cdr checks) (cdr docs)))
     200                 (else
     201                   (error (procedure-data query)
     202                          (format #f
     203                                  "postcondition violated: ~s with args ~s and result ~s"
     204                                  (car docs) args (car results))))))))))))))
     205
     206
     207;;; (method [variadic?] (proc-name proc effect-checker) (name pred . preds) ...)
     208;;; ----------------------------------------------------------------------------
    218209;;; method datatye constructor.
    219 ;;; proc is the actual procedure which is ultimately called
    220 ;;; effect-checker checks proc's return values or side-effects,
    221 ;;; i.e. either query-checker or command-checker is used,
     210;;; proc is the actual procedure which is ultimately called,
     211;;; effect-checker a procedure which accepts either proc or a special
     212;;; symbol as argument and returns that very proc after having checked
     213;;; its return values or side-effects, or returns documentation. Usually
     214;;; effect-checker is one of no-checker, query-checker or
     215;;; command-checker.
    222216;;; name a symbol describing the predicate (conjoin pred . preds) which
    223217;;; do the argument checks.
     
    240234              (if (null? preds)
    241235                ;; thunk
    242                 (apply proc args)
     236                (proc)
    243237                (receive (tail-args head-args) (split args (- (length preds) 1))
    244238                  (let loop ((head-args head-args) (preds preds))
     
    267261          (proc (cadr head))
    268262          (checker (caddr head))
    269           (docs (cdddr head))
    270263          (names (map car tail))
    271264          (preds (map cdr tail))
    272265          )
    273      `(let ((proc-list
    274               (list
    275                 (extend-procedure (,checker ,proc) ,proc-name)
    276                 ,@(map (lambda (ps n)
    277                          `(extend-procedure (conjoin ,@ps) ,n))
    278                        preds names)))) 
    279        (lambda  args
    280          (if (and (not (null? args))
    281                   (null? (cdr args))
    282                   (eq? (car args) state))
    283            (lambda (sym)
    284              (case sym
    285                ((proc-list) proc-list)
    286                ((effects) (,checker state))
    287                ((doc) (list ,@docs))
    288                ((arity) (length (cdr proc-list)))
    289                ((variadic?) ,variadic?)
    290                ((name) ,proc-name)
    291                ((type) 'method)
    292                (else (error ,proc-name
    293                             "message not understood"
    294                             sym))))
    295            (apply ',check-and-call proc-list ,variadic? args)))))))))
     266          `(let ((proc-list
     267                   (list
     268                     (extend-procedure (,checker ,proc) ,proc-name)
     269                     ,@(map (lambda (ps n)
     270                              `(extend-procedure (conjoin ,@ps) ,n))
     271                            preds names))))
     272             (lambda  args
     273               (if (and (not (null? args))
     274                        (null? (cdr args))
     275                        (eq? (car args) state))
     276                 (lambda (sym)
     277                   (case sym
     278                     ((proc-list) proc-list)
     279                     ((effects) (,checker state))
     280                     ((arity) (length (cdr proc-list)))
     281                     ((variadic?) ,variadic?)
     282                     ((name) ,proc-name)
     283                     ((type) 'method)
     284                     (else (error ,proc-name
     285                                  "message not understood"
     286                                  sym))))
     287                 (apply ',check-and-call proc-list ,variadic? args)))))))))
    296288
    297289(define (method? xpr)
     
    335327        ((no-checker)
    336328         '(macro ()
    337             ((_ doc . docs)
     329            ((_ doc0 doc1 ...)
    338330             "documentation strings or symbols"
    339              "returns a procedure which which returns its procure argument unchecked")))
     331             "returns a procedure which passes its proceure argument unchecked")))
    340332        ((command-checker)
    341333         '(macro ()
    342             ((_ check0 check1 ...)
    343 "checks are procedures of the same arguments as the command to check returning three values - query-call, compare-proc, doc-string -  needed for checking"
    344              "returns the command in case of successfull tests")))
     334            ((_ (check0 doc0) (check1 doc1) ...)
     335"checks are procedures of the same arguments as the command to check returning two values - query-call and compare-proc -  needed for checking"
     336"returns a prodedure, which accepts the command as argument and returns command in case of successfull tests")))
    345337        ((query-checker)
    346338         '(macro ()
    347             ((_ check0 check1 ...)
    348              "all checks are procedures of the same arguments as the query to be checked - the checker's only argument - and return two values, a predicate checking the return value and documentation" "returns the query in case of successfull tests")))
     339            ((_ (check0 doc0) (check1 doc1) ...)
     340"all checks are procedures of the same arguments as the query to be checked and returns a predicate checking the return value"
     341"returns a prodedure, which accepts the query as argument and returns query in case of successfull tests")))
    349342        ((method)
    350343         '(macro ()
    351344            ((_ [variadic?]
    352                 (proc-name proc effect-checker doc . docs)
     345                (proc-name proc effect-checker)
    353346                (name pred . preds)
    354347                ...)
  • release/4/multi-methods/trunk/multi-methods.setup

    r29121 r29131  
    99 'multi-methods
    1010 '("multi-methods.so" "method-helper.import.so" "methods.import.so" "multi-methods.import.so")
    11  '((version "0.3.1")))
     11 '((version "0.4")))
  • release/4/multi-methods/trunk/tests/run.scm

    r29120 r29131  
    77  "EFFECT-CHECKERS"
    88  (= (((no-checker "doc") add1) 5) 6)
    9   (= (((query-checker (lambda (n) (values (lambda (result)
    10                                             (= result (+ n 1)))
    11                                           '(= result (+ n 1)))))
     9  (= (((query-checker ((lambda (n)
     10                         (lambda (result)
     11                           (= result (+ n 1))))
     12                       '(= result (+ n 1))))
    1213       add1) 5) 6)
    1314  (define pair (cons 1 2))
    14   (((command-checker (lambda (pair val)
    15                        (values (car pair)
    16                                (lambda (old new) (equal? (car pair) new))
    17                                "(equal? (car pair) new)")))
     15  (((command-checker ((lambda (pair val)
     16                        (values (car pair)
     17                                (lambda (old new)
     18                                  (equal? (car pair) new))))
     19                      '(equal? (car pair) new)))
    1820    (extend-procedure set-car! 'set-car!))
    1921    pair 10)
    2022  "POSTCONDITION VIOLATED:"
    2123  (condition-case
    22     (((command-checker (lambda (pair val)
    23                          (values (car pair)
    24                                  (lambda (old new)
    25                                    (equal? (car pair) (add1 new)))
    26                                "(equal? (car pair) new)")))
     24    (((command-checker ((lambda (pair val)
     25                          (values (car pair)
     26                                  (lambda (old new)
     27                                    (equal? (car pair) (add1 new)))))
     28                        '(equal? (car pair) new)))
    2729      (extend-procedure set-car! 'set-car!))
    2830     pair 10)
    29     ((exn) #t))
    30   (condition-case
    31     (((query-checker (lambda (n) (values (lambda (result)
    32                                            (= result n))
    33                                          '(= result n))))
     31    ((exn) "postcondition violated"))
     32  (condition-case
     33    (((query-checker ((lambda (n)
     34                        (lambda (result)
     35                          (= result n)))
     36                      '(= result n)))
    3437      add1) 5)
    35     ((exn) #t))
     38    ((exn) "postcondition violated"))
    3639  "THUNK METHOD"
    3740  (define foo
     
    3942             (lambda () 'foo)
    4043             (query-checker
    41                (lambda ()
    42                  (values
    43                    (lambda (result)
    44                      (and (symbol? result) (eq? result 'foo)))
    45                    '(and (symbol? result) (eq? result 'foo))))))))
     44               ((lambda ()
     45                  (lambda (result)
     46                    (and (symbol? result) (eq? result 'foo))))
     47                '(and (symbol? result) (eq? result 'foo)))))))
    4648  (method? foo)
    4749  (eq? (foo) 'foo)
     
    5153             add1
    5254             (query-checker
    53                (lambda (n)
    54                  (values
    55                    (lambda (result)
    56                      (and (fixnum? result) (= result (+ n 1))))
    57                    '(and (fixnum? result) (= result (+ n 1))))))
    58                "add1" "violates postcondition")
     55               ((lambda (n)
     56                  (lambda (result)
     57                    (and (fixnum? result) (= result (+ n 1)))))
     58                '(and (fixnum? result) (= result (+ n 1))))))
    5959            ('1number? number?)))
    6060  (fx= (1+-number? 5) 6)
     
    6666             add1
    6767             (query-checker
    68                (lambda (n)
    69                  (values
    70                    (lambda (result)
    71                      (and (integer? result) (= result (+ n 1))))
    72                    '(and (integer? result) (= result (+ n 1))))))
    73             "add1")
     68               ((lambda (n)
     69                  (lambda (result)
     70                    (and (integer? result) (= result (+ n 1)))))
     71                '(and (integer? result) (= result (+ n 1))))))
    7472            ('1integer?negative? integer? negative?)))
    7573  (define 1+-fixnum?
     
    7775             (cut fx+ <> 1)
    7876             (query-checker
    79                (lambda (n)
    80                  (values
    81                    (lambda (result)
    82                      (and (fixnum? result) (fx= result (fx+ n 1))))
    83                    '(and (fixnum? result) (fx= result (fx+ n 1))))))
    84              "fx1+")
     77               ((lambda (n)
     78                  (lambda (result)
     79                    (and (fixnum? result) (fx= result (fx+ n 1)))))
     80                '(and (fixnum? result) (fx= result (fx+ n 1))))))
    8581            ('1fixnum? fixnum?)))
    8682  (fx= (1+-fixnum? 5) 6)
     
    10096             +
    10197             (query-checker
    102                (lambda (x y)
    103                  (values
    104                    (lambda (result)
    105                      (and (even? result) (= result (+ x y))))
    106                    '(and (even? result) (= result (+ x y))))))
    107              "+" "violates postcondition")
     98               ((lambda (x y)
     99                  (lambda (result)
     100                    (and (even? result) (= result (+ x y)))))
     101                '(and (even? result) (= result (+ x y))))))
    108102            ('1odd? odd?)
    109103            ('2even? even?)))
     
    112106             fx+
    113107             (query-checker
    114                (lambda (x y)
    115                  (values
    116                    (lambda (result)
    117                      (and (fixnum? result) (fx= result (fx+ x y))))
    118                    '(and (fixnum? result) (fx= result (fx+ x y))))))
    119              "fx+")
     108               ((lambda (x y)
     109                  (lambda (result)
     110                    (and (fixnum? result) (fx= result (fx+ x y)))))
     111                '(and (fixnum? result) (fx= result (fx+ x y))))))
    120112            ('1fixnum? fixnum?)
    121113            ('2fixnum? fixnum?)))
     
    124116             +
    125117             (query-checker
    126                (lambda (x y)
    127                  (values
    128                    (lambda (result)
    129                      (and (number? result) (= result (+ x y))))
    130                    '(and (number? result) (= result (+ x y))))))
    131              "+")
     118               ((lambda (x y)
     119                  (lambda (result)
     120                    (and (number? result) (= result (+ x y)))))
     121                '(and (number? result) (= result (+ x y))))))
    132122            ('1fixnum? fixnum?)
    133123            ('2number? number?)))
     
    140130             *
    141131             (query-checker
    142                (lambda xs
    143                  (values
    144                    (lambda (result)
    145                      (and (odd? result) (= result (apply * xs))))
    146                    '(and (odd? result) (= result (apply * xs))))))
    147              "*" "postcondition")
     132               ((lambda xs
     133                  (lambda (result)
     134                    (and (odd? result) (= result (apply * xs)))))
     135                '(and (odd? result) (= result (apply * xs))))))
    148136            ('1list-of-number? (list-of? number?))))
    149137  (define *-list-of-integer?
     
    152140             *
    153141             (query-checker
    154                (lambda xs
    155                  (values
    156                    (lambda (result)
    157                      (and (integer? result) (= result (apply * xs))))
    158                    '(and (integer? result) (= result (apply * xs))))))
    159              "*")
     142               ((lambda xs
     143                  (lambda (result)
     144                    (and (integer? result) (= result (apply * xs)))))
     145                '(and (integer? result) (= result (apply * xs))))))
    160146            ('1list-of-integer? (list-of? integer?))))
    161147  (method-variadic? *-list-of-integer?)
     
    171157             *
    172158             (query-checker
    173                (lambda (x . xs)
    174                  (values
    175                    (lambda (result)
    176                      (and (number? result) (= result (apply * x xs))))
    177                    '(and (number? result) (= result (apply * x xs))))))
    178              "*")
     159               ((lambda (x . xs)
     160                  (lambda (result)
     161                    (and (number? result) (= result (apply * x xs)))))
     162                '(and (number? result) (= result (apply * x xs))))))
    179163            ('1number? number?)
    180164            ('2list-of-number? (list-of? number?))))
     
    190174             fx**
    191175             (query-checker
    192                (lambda (x . xs)
    193                  (values
    194                    (lambda (result)
    195                      (and (fixnum? result) (= result (apply fx** x xs))))
    196                    '(and (fixnum? result) (= result (apply fx** x xs))))))
    197              "fx**")
     176               ((lambda (x . xs)
     177                  (lambda (result)
     178                    (and (fixnum? result) (= result (apply fx** x xs)))))
     179                '(and (fixnum? result) (= result (apply fx** x xs))))))
    198180            ('1fixnum? fixnum?)
    199181            ('2list-of-fixnum? (list-of? fixnum?))))
     
    203185             *
    204186             (query-checker
    205                (lambda (x . xs)
    206                  (values
    207                    (lambda (result)
    208                      (and (number? result) (= result (apply * x xs))))
    209                    '(and (number? result) (= result (apply * x xs))))))
    210              "*")
     187               ((lambda (x . xs)
     188                  (lambda (result)
     189                    (and (number? result) (= result (apply * x xs)))))
     190                '(and (number? result) (= result (apply * x xs))))))
    211191            ('1fixnum? fixnum?)
    212192            ('2list-of-number? (list-of? number?))))
    213 )
    214 
    215 (run-tests
    216193  "A MULTI-METHOD OF ARITY 1"
    217194  (define 1+ (multi-method x))
Note: See TracChangeset for help on using the changeset viewer.