CHICKEN allows us to associate a number of values to a procedure object, storing them in the procedure object itself, which is a block object similar to a Scheme vector; the maximum number of decorations approaches the maximum length of a Scheme vector. When adding a decoration value: we must make sure that we can identify it by applying a predicate to it.
Iterate over the decoration slots of the procedure object proc searching for a decoration
value that matches the predicate pred. If a match is found: return that value; otherwise
Iterate over the decoration slots of the procedure object proc searching for a decoration value that matches the predicate pred:
Return the values returned by the decorator application. decorator should return the procedure object it received as argument, because, in case of reallocation, that value is the replacement of proc; we have to assume proc itself is no more a valid Scheme object after a call to this system operation.
Let’s define an API to decorate procedure objects, the decoration value is a pair object with a “type symbol” as car:
(define MY_PROCEDURE_DECORATION_KEY 'Sau0oosh8coodahthoa4Ohquic6oshoh) (define (make-my-procedure-decoration-value proc) ;;Build a new decoration value. ;; (cons MY_PROCEDURE_DECORATION_KEY proc)) (define (my-procedure-decoration-value? obj) ;;Return #t if OBJ is a decoration value; otherwise return #f. ;; (and (pair? obj) (eq? MY_PROCEDURE_DECORATION_KEY (car obj)))) (define (decorate-my-procedure proc decoration-value-payload) ;;Decorate the procedure PROC with a new payload value. Return ;;the, possibly reallocated, procedure object. ;; (##sys#decorate-lambda proc my-procedure-decoration-value? (lambda (new-proc slotidx) (##sys#setslot new-proc slotidx (make-my-procedure-decoration-value decoration-value-payload)) new-proc))) (define (my-procedure-decoration-payload proc) ;;Retrieve the payload from the decoration value associated to ;;the procedure object PROC. Raise an error if no such decoration ;;is present. ;; (cond ((##sys#lambda-decoration proc my-procedure-decoration-value?) => cdr) (else (error 'my-procedure-decoration-payload "expected procedure object decorated with my payload" proc))))
now we can decorate procedures as follows:
(define (the-proc) 123) (set! the-proc (decorate-my-procedure the-proc "ciao")) (my-procedure-decoration-payload the-proc)) ⇒ "ciao"
or as follows:
(define the-proc (decorate-my-procedure (lambda () 123) "ciao")) (my-procedure-decoration-payload the-proc)) ⇒ "ciao"