Changeset 16076 in project


Ignore:
Timestamp:
09/25/09 00:37:22 (10 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/procedure-decoration/trunk
Files:
2 edited

Legend:

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

    r16074 r16076  
    1111    make-procedure-decorator
    1212    procedure-decorator?
    13     procedure-decorator-become?
    1413    procedure-decorator-getter-and-setter
    1514    decorated-procedure?
     
    2221  (import scheme
    2322          chicken
     23          (only data-structures conc)
    2424          (only type-checks
    2525                check-procedure check-cardinal-fixnum
    2626                define-check+error-type))
    2727
    28   (require-library type-checks)
     28  (require-library data-structures type-checks)
    2929
    3030;;;
     
    3636;;
    3737
    38 (define (##sys#update-lambda-decoration proc pred decr)
     38(define (update-lambda-decoration! proc pred decr)
    3939  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
    4040  (##sys#decorate-lambda proc pred setter) )
    4141
    42 ;;
    43 
    44 (define *lambda-decoration ##sys#lambda-decoration)
    45 
    46 (define *decorate-lambda ##sys#update-lambda-decoration)
    47 
    48 (define (*decorated-lambda? proc pred) (->boolean (##sys#lambda-decoration proc pred)))
     42(define (procedure-become old new) (##sys#become! `((,old . ,new))))
    4943
    5044;;
     
    5852  (check-procedure loc obj3) )
    5953
    60 (define-check+error-type decorated-lambda *decorated-lambda?)
    61 
    6254;;
    6355
    6456(define (decorated-lambda? proc pred)
    6557  (check-procedure2 'decorated-lambda? proc pred)
    66   (*decorated-lambda? proc pred) )
     58  (->boolean (##sys#lambda-decoration proc pred)) )
    6759
    6860(define (lambda-decoration proc pred)
    6961  (check-procedure2 'lambda-decoration proc pred)
    70   (*lambda-decoration proc pred) )
     62  (##sys#lambda-decoration proc pred) )
    7163
    7264(define (decorate-lambda proc pred decr)
    7365  (check-procedure3 'decorate-lambda proc pred decr)
    74   (*decorate-lambda proc pred decr) )
     66  (update-lambda-decoration! proc pred decr) )
    7567
    7668;;;
     
    7971
    8072(define-record-type procedure-decorator
    81   (*make-procedure-decorator pred intr decr getr bcmf)
     73  (**make-procedure-decorator pred mutr retr)
    8274  procedure-decorator?
    83   (bcmf procedure-decorator-become?)
    8475  (pred procedure-decorator-predicate)
    85   (intr procedure-decorator-initializer)
    86   (decr procedure-decorator-mutator)
    87   (getr procedure-decorator-retriever) )
     76  (mutr procedure-decorator-mutator)
     77  (retr procedure-decorator-retriever))
    8878
    8979;;
     
    9383;;
    9484
    95 (define (*procedure-decoration proc dctr)
    96   (*lambda-decoration proc (procedure-decorator-predicate dctr)) )
     85(define ((*mutator-initializer decr) . args) (apply decr (void) args))
    9786
    98 (define (*retrieve-procedure-decoration proc dctr args)
    99   ((procedure-decorator-retriever dctr) (*procedure-decoration proc dctr) args) )
     87(define ((*decorator-maker pred intr) proc args)
     88  (update-lambda-decoration! proc pred (lambda (obj) (apply intr args))) )
    10089
    101 (define (*procedure-become proc new) (##sys#become! `((,proc . ,new))) proc)
     90(define ((*decorator-replacer makr) proc args)
     91  (procedure-become proc (makr proc args)) )
    10292
    103 (define (*decorate-procedure proc dctr args)
    104   (let* ((pred (procedure-decorator-predicate dctr)))
    105     (if (*decorated-lambda? proc pred)
    106         (let ((decr (lambda (obj) ((procedure-decorator-mutator dctr) obj args))))
    107           (*decorate-lambda proc pred decr) )
    108         (let* ((intr (lambda (obj) ((procedure-decorator-initializer dctr) args)))
    109                (new (*decorate-lambda proc pred intr)) )
    110           (if (not (procedure-decorator-become? dctr)) new
    111               (*procedure-become proc new) ) ) ) ) )
     93(define (*decorator-initializer pred intr rplc?)
     94  (let ((makr (*decorator-maker pred intr)))
     95    (if rplc? (*decorator-replacer makr)
     96        makr ) ) )
    11297
    113 (define ((*decorator-initializer decr) . args) (apply decr (void) args))
    114 
    115 (define ((*procedure-decorator-getter dctr) proc)  (*retrieve-procedure-decoration proc dctr '()))
    116 (define ((*procedure-decorator-setter dctr) proc val) (*decorate-procedure proc dctr (list val)))
     98(define ((*decorator-mutator pred decr dctr-intr) proc args)
     99  (if (not (##sys#lambda-decoration proc pred)) (dctr-intr proc args)
     100      (update-lambda-decoration! proc pred (lambda (obj) (apply decr obj args))) ) )
    117101
    118102;;
    119103
    120 (define (make-procedure-decorator pred decr retr
    121                                   #!key (initializer #f)
    122                                         (replace? #f))
     104(define (*procedure-decorator-mutator pred decr intr rplc?)
     105  (*decorator-mutator
     106    pred
     107    decr
     108    (*decorator-initializer pred (or intr (*mutator-initializer decr)) rplc?)) )
     109
     110(define ((*procedure-decorator-retriever pred retr) proc args)
     111  (and-let* ((deco (##sys#lambda-decoration proc pred)))
     112    (apply retr deco args) ) )
     113
     114(define (*make-procedure-decorator pred decr retr intr rplc?)
     115  (**make-procedure-decorator
     116    pred
     117    (*procedure-decorator-mutator pred decr intr rplc?)
     118    (*procedure-decorator-retriever pred retr)) )
     119
     120;;
     121
     122(define (make-procedure-decorator pred decr retr #!key (initializer #f) (replace? #f))
    123123  (check-procedure3 'make-procedure-decorator pred decr retr)
    124124  (when initializer (check-procedure 'make-procedure-decorator initializer))
    125   (let ((intr (or initializer (*decorator-initializer initializer decr))))
    126     (*make-procedure-decorator pred intr decr retr replace?) ) )
    127 
    128 (define (procedure-decorator-replace? dctr)
    129   (check-procedure-decorator 'procedure-decorator-replace? dctr)
    130   (procedure-decorator-become? dctr) )
     125  (*make-procedure-decorator pred decr retr initializer replace?) )
    131126
    132127(define (procedure-decorator-getter-and-setter dctr)
    133128  (check-procedure-decorator 'procedure-decorator-getter-and-setter dctr)
    134   (getter-with-setter (*procedure-decorator-getter dctr) (*procedure-decorator-setter dctr)) )
     129  (getter-with-setter
     130    (lambda (proc) ((procedure-decorator-retriever dctr) proc '()))
     131    (lambda (proc obj) ((procedure-decorator-mutator dctr) proc `(,obj)))) )
    135132
    136133;;
     
    139136  (check-procedure 'decorated-procedure? proc)
    140137  (check-procedure-decorator 'decorated-procedure? dctr)
    141   (*decorated-lambda? proc (procedure-decorator-predicate dctr)) )
     138  (->boolean (##sys#lambda-decoration proc (procedure-decorator-predicate dctr))) )
    142139
    143140(define (procedure-decoration proc dctr . args)
    144141  (check-procedure 'procedure-decoration proc)
    145142  (check-procedure-decorator 'procedure-decoration dctr)
    146   (*retrieve-procedure-decoration proc dctr args) )
     143  ((procedure-decorator-retriever dctr) proc args) )
    147144
    148145(define (decorate-procedure proc dctr . args)
    149146  (check-procedure 'decorate-procedure proc)
    150147  (check-procedure-decorator 'decorate-procedure dctr)
    151   (*decorate-procedure proc dctr args) )
     148  ((procedure-decorator-mutator dctr) proc args) )
    152149
    153150;;;
     
    156153
    157154(define (make-procedure-extender tag)
    158   (make-procedure-decorator (lambda (obj) (and (pair? obj) (eq? tag (car obj))))
    159                             (lambda (_ new) (cons tag new))
    160                             cdr
    161                             #:become? #t) )
     155  (*make-procedure-decorator
     156    (lambda (obj) (and (pair? obj) (eq? tag (car obj))))
     157    (lambda (old new) (cons tag new))
     158    cdr
     159    #f
     160    #t) )
    162161
    163162;; Define procedures for getting, setting, & testing a decorated procedure
    164163
    165164(define-for-syntax (procdecrname tag suff) (string->symbol (conc tag #\- suff)))
     165
     166; TAG [GETTER-NAME [PREDICATE-NAME]]
    166167
    167168(define-syntax define-procedure-extender
     
    174175            (_procedure-decorator-getter-and-setter (rnm 'procedure-decorator-getter-and-setter))
    175176            (_decorated-procedure? (rnm 'decorated-procedure?)) )
    176       (let-optionals ?rest ((?getrname (procdecrname ?tag 'decoration))
    177                             (?predname (procdecrname ?tag 'decorated?)))
    178         (let ((?dctrname (procdecrname ?tag 'decorator)))
    179           `(,_begin
    180             (,_define ,?getrname)
    181             (,_define ,?predname)
    182             (,_define ,?dctrname)
    183             (let ((dctr (,_make-procedure-extender ',?tag)))
    184               (set! ,?dctrname dctr)
    185               (set! ,?getrname (,_procedure-decorator-getter-and-setter dctr))
    186               (set! ,?predname (cut ,_decorated-procedure? <> dctr)) ) ) ) ) ) ) ) )
     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)))
     182            `(,_begin
     183               (,_define ,dctrname (,_make-procedure-extender ',?tag))
     184               (,_define ,?getrname (,_procedure-decorator-getter-and-setter ,dctrname))
     185               (,_define ,?predname (cut ,_decorated-procedure? <> ,dctrname)) ) ) ) ) ) ) ) )
    187186
    188187) ;module procedure-decoration
  • release/4/procedure-decoration/trunk/tests/run.scm

    r16072 r16076  
     1;;;; procedure-decoration-test.scm
     2
     3(use test)
     4(use procedure-decoration)
     5
     6;;;
     7
     8(test-group "Become? yes"
     9  (define (test-proc) #t)
     10  (define-procedure-extender docstring procedure-documentation documented-procedure?)
     11
     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)
     18
     19(test-group "Become? no"
     20  (define (test-proc) #t)
     21  (define dctr)
     22  (define decr-test-proc)
     23
     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)))
     29
     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)
Note: See TracChangeset for help on using the changeset viewer.