Changeset 35335 in project


Ignore:
Timestamp:
03/24/18 22:28:40 (8 months ago)
Author:
kon
Message:

use csi+csc test runner, add types, reflow

Location:
release/4/procedure-decoration/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/procedure-decoration/trunk/procedure-decoration.meta

    r28422 r35335  
    1111  (check-errors "1.12.1"))
    1212 (test-depends test)
    13  (files "procedure-decoration.scm" "procedure-decoration.meta" "procedure-decoration.setup" "tests/run.scm") )
     13 (files
     14  "procedure-decoration.meta" "procedure-decoration.setup"
     15  "procedure-decoration.scm"
     16  "tests/run.scm" "tests/procedure-decoration-test.scm") )
  • release/4/procedure-decoration/trunk/procedure-decoration.scm

    r28422 r35335  
    33(module procedure-decoration
    44
    5   (;export
    6     ;; Checked API
    7     decorated-lambda?
    8     lambda-decoration
    9     decorate-lambda
    10     ;;
    11     make-procedure-decorator
    12     procedure-decorator?
    13     procedure-decorator-getter-and-setter
    14     decorated-procedure?
    15     procedure-decoration
    16     decorate-procedure
    17     ;; Tagged API
    18     make-procedure-extender
    19     define-procedure-extender)
    20 
    21   (import scheme
    22           chicken
    23           (only data-structures conc)
    24           (only type-checks
    25                 check-procedure check-cardinal-fixnum
    26                 define-check+error-type))
    27 
    28   (require-library data-structures type-checks)
     5(;export
     6  ;; Checked API
     7  decorated-lambda?
     8  lambda-decoration
     9  decorate-lambda
     10  ;;
     11  make-procedure-decorator
     12  procedure-decorator?
     13  procedure-decorator-getter-and-setter
     14  decorated-procedure?
     15  procedure-decoration
     16  decorate-procedure
     17  ;; Tagged API
     18  make-procedure-extender
     19  define-procedure-extender)
     20
     21(import scheme chicken)
     22(use
     23  (only data-structures conc)
     24  (only lolevel object-become!)
     25  (only type-checks
     26    check-procedure check-cardinal-fixnum
     27    define-check+error-type))
     28
     29(declare
     30  (bound-to-procedure
     31    ##sys#lambda-decoration
     32    ##sys#decorate-lambda))
    2933
    3034;;;
     
    3640;;
    3741
     42(: update-lambda-decoration! (procedure procedure procedure -> procedure))
     43;
    3844(define (update-lambda-decoration! proc pred decr)
    3945  (##sys#decorate-lambda
     
    4450      proc)) )
    4551
    46 (define (procedure-become old new) (##sys#become! `((,old . ,new))))
    47 
    48 ;;
    49 
     52(: procedure-become (procedure procedure -> void))
     53;
     54(define (procedure-become old new)
     55  (object-become! `((,old . ,new))) )
     56
     57;;
     58
     59(: decorated-lambda? (procedure procedure --> boolean))
     60;
    5061(define (decorated-lambda? proc pred)
    51   (check-procedure 'decorated-lambda? proc 'procedure)
    52   (check-procedure 'decorated-lambda? pred 'predicate)
    53   (->boolean (##sys#lambda-decoration proc pred)) )
    54 
     62  (and
     63    (procedure? proc)
     64    (->boolean
     65      (##sys#lambda-decoration
     66        proc
     67        (check-procedure 'decorated-lambda? pred 'predicate)))) )
     68
     69(: lambda-decoration (procedure procedure --> *))
     70;
    5571(define (lambda-decoration proc pred)
    56   (check-procedure 'lambda-decoration proc 'procedure)
    57   (check-procedure 'lambda-decoration pred 'predicate)
    58   (##sys#lambda-decoration proc pred) )
    59 
     72  (##sys#lambda-decoration
     73    (check-procedure 'lambda-decoration proc 'procedure)
     74    (check-procedure 'lambda-decoration pred 'predicate)) )
     75
     76(: decorate-lambda (procedure procedure procedure -> procedure))
     77;
    6078(define (decorate-lambda proc pred decr)
    61   (check-procedure 'decorate-lambda proc 'procedure)
    62   (check-procedure 'decorate-lambda pred 'predicate)
    63   (check-procedure 'decorate-lambda decr 'decorator)
    64   (update-lambda-decoration! proc pred decr) )
     79  (update-lambda-decoration!
     80    (check-procedure 'decorate-lambda proc 'procedure)
     81    (check-procedure 'decorate-lambda pred 'predicate)
     82    (check-procedure 'decorate-lambda decr 'decorator)) )
    6583
    6684;;;
    6785
    6886;;
     87
     88(define-type procedure-decorator (struct procedure-decorator))
    6989
    7090(define-record-type procedure-decorator
     
    81101;;
    82102
    83 (define ((*mutator-initializer decr) . args) (apply decr (void) args))
     103(define ((*mutator-initializer decr) . args)
     104  (apply decr (void) args) )
    84105
    85106(define ((*decorator-maker pred intr) proc args)
     
    91112(define (*decorator-initializer pred intr rplc?)
    92113  (let ((makr (*decorator-maker pred intr)))
    93     (if rplc? (*decorator-replacer makr)
    94         makr ) ) )
     114    (if rplc?
     115      (*decorator-replacer makr)
     116      makr ) ) )
    95117
    96118(define ((*decorator-mutator pred decr dctr-intr) proc args)
    97   (if (not (##sys#lambda-decoration proc pred)) (dctr-intr proc args)
    98       (update-lambda-decoration! proc pred (lambda (obj) (apply decr obj args))) ) )
     119  (if (not (##sys#lambda-decoration proc pred))
     120    (dctr-intr proc args)
     121    (update-lambda-decoration! proc pred (lambda (obj) (apply decr obj args))) ) )
    99122
    100123;;
     
    107130
    108131(define ((*procedure-decorator-retriever pred retr) proc args)
    109   (and-let* ((deco (##sys#lambda-decoration proc pred)))
     132  (and-let* (
     133    (deco (##sys#lambda-decoration proc pred)) )
    110134    (apply retr deco args) ) )
    111135
     
    118142;;
    119143
     144(: make-procedure-decorator (procedure procedure procedure #!rest -> procedure-decorator))
     145;
    120146(define (make-procedure-decorator pred decr retr #!key (initializer #f) (replace? #f))
    121   (check-procedure 'make-procedure-decorator pred 'predicate)
    122   (check-procedure 'make-procedure-decorator decr 'decorator)
    123   (check-procedure 'make-procedure-decorator retr 'retriever)
    124147  (when initializer (check-procedure 'make-procedure-decorator initializer))
    125   (*make-procedure-decorator pred decr retr initializer replace?) )
    126 
     148  (*make-procedure-decorator
     149    (check-procedure 'make-procedure-decorator pred 'predicate)
     150    (check-procedure 'make-procedure-decorator decr 'decorator)
     151    (check-procedure 'make-procedure-decorator retr 'retriever)
     152    initializer
     153    replace?) )
     154
     155(: procedure-decorator-getter-and-setter (procedure -> procedure))
     156;
    127157(define (procedure-decorator-getter-and-setter dctr)
    128158  (check-procedure-decorator 'procedure-decorator-getter-and-setter dctr)
    129159  (getter-with-setter
    130     (lambda (proc) ((procedure-decorator-retriever dctr) proc '()))
    131     (lambda (proc obj) ((procedure-decorator-mutator dctr) proc `(,obj)))) )
    132 
    133 ;;
    134 
     160    (lambda (proc)
     161      ((procedure-decorator-retriever dctr) proc '()))
     162    (lambda (proc obj)
     163      ((procedure-decorator-mutator dctr) proc `(,obj)))) )
     164
     165;;
     166
     167(: decorated-procedure? (procedure procedure-decorator -> boolean))
     168;
    135169(define (decorated-procedure? proc dctr)
    136   (check-procedure 'decorated-procedure? proc)
    137   (check-procedure-decorator 'decorated-procedure? dctr)
    138   (->boolean (##sys#lambda-decoration proc (procedure-decorator-predicate dctr))) )
    139 
     170  (and
     171    (procedure? proc)
     172    (->boolean
     173      (##sys#lambda-decoration
     174        proc
     175        (procedure-decorator-predicate
     176          (check-procedure-decorator 'decorated-procedure? dctr))))) )
     177
     178(: procedure-decoration (procedure procedure-decorator #!rest -> *))
     179;
    140180(define (procedure-decoration proc dctr . args)
    141   (check-procedure 'procedure-decoration proc)
    142   (check-procedure-decorator 'procedure-decoration dctr)
    143   ((procedure-decorator-retriever dctr) proc args) )
    144 
     181  ((procedure-decorator-retriever (check-procedure-decorator 'procedure-decoration dctr))
     182    (check-procedure 'procedure-decoration proc)
     183    args) )
     184
     185(: decorate-procedure (procedure procedure-decorator #!rest -> procedure))
     186;
    145187(define (decorate-procedure proc dctr . args)
    146   (check-procedure 'decorate-procedure proc)
    147   (check-procedure-decorator 'decorate-procedure dctr)
    148   ((procedure-decorator-mutator dctr) proc args) )
     188  ((procedure-decorator-mutator (check-procedure-decorator 'decorate-procedure dctr))
     189    (check-procedure 'decorate-procedure proc)
     190    args) )
    149191
    150192;;;
     
    152194;; A simple procedure decorator
    153195
     196(: make-procedure-extender (* -> procedure-decorator))
     197;
    154198(define (make-procedure-extender tag)
    155199  (*make-procedure-decorator
     
    162206;; Define procedures for getting, setting, & testing a decorated procedure
    163207
    164 (define-for-syntax (procdecrname tag suff) (string->symbol (conc tag #\- suff)))
    165 
    166 ; TAG [GETTER-NAME [PREDICATE-NAME]]
    167 
     208(define-for-syntax (hypen-name tag suff)
     209  (string->symbol (conc tag #\- suff)) )
     210
     211;TAG [GETTER-NAME [PREDICATE-NAME]]
    168212(define-syntax define-procedure-extender
    169213  (er-macro-transformer
    170214    (lambda (frm rnm cmp)
    171       (let ((_define (rnm 'define))
    172             (_set! (rnm 'set!))
    173             (_begin (rnm 'begin))
    174             (_make-procedure-extender (rnm 'make-procedure-extender))
    175             (_procedure-decorator-getter-and-setter (rnm 'procedure-decorator-getter-and-setter))
    176             (_decorated-procedure? (rnm 'decorated-procedure?)) )
    177       (let ((?tag (cadr frm))
    178             (?rest (cddr frm)) )
    179         (let-optionals ?rest ((?getrname (procdecrname ?tag 'decoration))
    180                               (?predname (procdecrname ?tag 'decorated?)))
    181           (let ((dctrname (procdecrname ?tag 'decorator)))
     215      (let (
     216        (_: (rnm ':))
     217        (_define (rnm 'define))
     218        (_set! (rnm 'set!))
     219        (_begin (rnm 'begin))
     220        (_make-procedure-extender (rnm 'make-procedure-extender))
     221        (_procedure-decorator-getter-and-setter (rnm 'procedure-decorator-getter-and-setter))
     222        (_decorated-procedure? (rnm 'decorated-procedure?))
     223        (_procedure-decorator (rnm 'procedure-decorator')) )
     224      (let (
     225        (?tag (cadr frm))
     226        (?rest (cddr frm)) )
     227        (let-optionals ?rest (
     228          (?getrname (hypen-name ?tag 'decoration))
     229          (?predname (hypen-name ?tag 'decorated?)))
     230          (let (
     231            (dctrname (hypen-name ?tag 'decorator)) )
    182232            `(,_begin
     233               (,_: ,dctrname (struct ,_procedure-decorator))
    183234               (,_define ,dctrname (,_make-procedure-extender ',?tag))
     235               (,_: ,?getrname procedure)
    184236               (,_define ,?getrname (,_procedure-decorator-getter-and-setter ,dctrname))
     237               (,_: ,?predname (* -> boolean : procedure))
    185238               (,_define ,?predname (cut ,_decorated-procedure? <> ,dctrname)) ) ) ) ) ) ) ) )
    186239
  • release/4/procedure-decoration/trunk/procedure-decoration.setup

    r28422 r35335  
    55(verify-extension-name "procedure-decoration")
    66
    7 (setup-shared-extension-module 'procedure-decoration (extension-version "2.0.2")
     7(setup-shared-extension-module 'procedure-decoration (extension-version "2.1.0")
    88  #:inline? #t
    99  #:types? #t
  • release/4/procedure-decoration/trunk/tests/run.scm

    r28422 r35335  
    1 ;;;; procedure-decoration-test.scm
    21
    3 (use test)
    4 (use procedure-decoration)
     2(define EGG-NAME "procedure-decoration")
     3
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     5
     6(use files)
     7
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
     10
     11(define *args* (argv))
     12
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
     15
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    524
    625;;;
    726
    8 (test-group "Become? yes"
    9   (define (test-proc) #t)
    10   (define-procedure-extender docstring procedure-documentation documented-procedure?)
     27(set! EGG-NAME (egg-name))
    1128
    12   (test-assert (not (documented-procedure? test-proc)))
    13   (test-assert (set! (procedure-documentation test-proc) "test-proc is foo"))
    14   (test-assert (documented-procedure? test-proc))
    15   (test "test-proc is foo" (procedure-documentation test-proc))
    16   (test-assert (test-proc))
    17 )
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    1837
    19 (test-group "Become? no"
    20   (define (test-proc) #t)
    21   (define dctr)
    22   (define decr-test-proc)
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    2340
    24   (test-assert
    25     (set! dctr
    26      (make-procedure-decorator (lambda (obj) (and (pair? obj) (eq? 'foo (car obj))))
    27                                (lambda (_ new) (cons 'foo new))
    28                                cdr)))
     41;;;
    2942
    30   (test-assert (not (decorated-procedure? test-proc dctr)))
    31   (test-assert (set! decr-test-proc (decorate-procedure test-proc dctr "test-proc is foo")))
    32   (test-assert "Procedure did not \"become\"" (not (eq? test-proc decr-test-proc)))
    33   (test-assert (decorated-procedure? decr-test-proc dctr))
    34   (test "test-proc is foo" (procedure-decoration decr-test-proc dctr))
    35   (test-assert (test-proc))
    36   (test-assert (decr-test-proc))
    37 )
    38 
    39 (test-exit)
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.