Changeset 2416 in project


Ignore:
Timestamp:
11/14/06 01:10:14 (15 years ago)
Author:
Kon Lovett
Message:

Added procedure property list support.

Location:
proplist
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • proplist/proplist-eggdoc.scm

    r1936 r2416  
    3232                (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    3333                (history
     34                        (version "1.5" "Procedure slot support")
    3435                        (version "1.4" "Extra symbol slot support")
    3536                        (version "1.3" "Renamed get-properties, removed rem-properties[/all]!")
     
    5253                                (p "Lisp-like property list procedures.")
    5354
    54                                 (p "The " (tt "NAME") " argument below may be a symbol, hash-table, "
     55                                (p "The " (tt "NAME") " argument below may be a procedure, symbol, hash-table, "
    5556                                "or a property-list.")
    5657
    57                                 (p "A property key " (tt "PROPKEY") " argument below should be a symbol.")
     58                                (p "A property key " (tt "PROPKEY") " argument below should be a symbol; an "
     59                                "identity test is performed.")
    5860
    5961                                (group
    6062
    61                                         (parameter "(current-property-list-uses-extraslot [FLAG])"
     63                                        (parameter "(proplist-extraslot [FLAG])"
    6264                                                (p "The property list is sourced from the symbol extraslot when "
    6365                                                (tt "FLAG") " is " (code "#t") ". "
     
    6567                                                (tt "FLAG") " is " (code "#f") " the property list is found in "
    6668                                                "a separate table.") )
     69
     70                                        (parameter "(proplist-procslot [FLAG])"
     71                                                (p "The property list is sourced from the procedure extended data when "
     72                                                (tt "FLAG") " is " (code "#t") ". "
     73                                                "Should the " (tt "FLAG") " be " (code "#f") " the property list is found in "
     74                                                "a separate table.")
     75                                               
     76                                                (p "The procedure " (b "must") " be initialized before using as a property list handle. "
     77                                                "Example: " (code "(define foo (proplist-procedure (lambda () #t)))") ".") )
     78
     79                                        (procedure "(proplist-procedure PROC)"
     80                                                (p "Returns the extended procedure with an empty property list.") )
    6781
    6882                                        (procedure "(getprop NAME PROPKEY [DEFAULT #f])"
  • proplist/proplist-test.scm

    r1936 r2416  
    11(use test-infrastructure)
    2 
    32(use proplist)
    43
     
    76        (test-group "Property List"
    87
    9                 #;(side-effect (current-property-list-uses-extraslot #f))
    10                 (gloss (conc "Using Extraslot: " (->string (current-property-list-uses-extraslot))))
     8                (test-group "Symbol"
    119
    12                 (expect-false (getprop 'foo 'bar))
    13                 (expect-true (getprop 'foo 'bar #t))
     10                        (gloss (conc "Using Extraslot: " (->string (proplist-extraslot))))
    1411
    15                 (expect-success (putprop! 'foo 'bar 23))
    16                 (expect-eqv 23 (getprop 'foo 'bar))
     12                        (expect-false (getprop 'foo 'bar))
     13                        (expect-true (getprop 'foo 'bar #t))
    1714
    18                 (expect-success (putprop! 'foo 'bar #t))
    19                 (expect-true (getprop 'foo 'bar))
     15                        (expect-success (putprop! 'foo 'bar 23))
     16                        (expect-eqv 23 (getprop 'foo 'bar))
    2017
    21                 (expect-success (remprop! 'foo 'bar))
    22                 (expect-eqv 23 (getprop 'foo 'bar))
     18                        (expect-success (putprop! 'foo 'bar #t))
     19                        (expect-true (getprop 'foo 'bar))
    2320
    24                 (expect-success (putprop! 'foo 'bar #t))
    25                 (expect-success (setprop! 'foo 'bar 123))
    26                 (expect-eqv 123 (getprop 'foo 'bar))
     21                        (expect-success (remprop! 'foo 'bar))
     22                        (expect-eqv 23 (getprop 'foo 'bar))
    2723
    28                 (expect-success (putprop! 'xxx 'ski 'Rossi 'boot "Snug Fit"))
     24                        (expect-success (putprop! 'foo 'bar #t))
     25                        (expect-success (setprop! 'foo 'bar 123))
     26                        (expect-eqv 123 (getprop 'foo 'bar))
    2927
    30                 (expect-equal "Snug Fit" (getprop 'xxx 'boot))
    31                 (expect-equal '(boot "Snug Fit" ski Rossi) (get-proplist 'xxx))
    32                 (expect-equal '(ski Rossi) (proplist 'xxx 'ski))
     28                        (expect-success (putprop! 'xxx 'ski 'Rossi 'boot "Snug Fit"))
    3329
    34                 (expect-equal '((boot . "Snug Fit") (ski . Rossi)) (get-proplist->alist 'xxx))
    35                 (expect-equal '((ski . Rossi)) (proplist->alist 'xxx 'ski))
     30                        (expect-equal "Snug Fit" (getprop 'xxx 'boot))
     31                        (expect-equal '(boot "Snug Fit" ski Rossi) (get-proplist 'xxx))
     32                        (expect-equal '(ski Rossi) (proplist 'xxx 'ski))
     33
     34                        (expect-equal '((boot . "Snug Fit") (ski . Rossi)) (get-proplist->alist 'xxx))
     35                        (expect-equal '((ski . Rossi)) (proplist->alist 'xxx 'ski))
     36                )
     37
     38                (test-group "No extraslot"
     39
     40                        (side-effect (proplist-extraslot #f))
     41                        (gloss (conc "Using Extraslot: " (->string (proplist-extraslot))))
     42
     43                        (expect-false (getprop 'foo 'bar))
     44                        (expect-true (getprop 'foo 'bar #t))
     45
     46                        (expect-success (putprop! 'foo 'bar 23))
     47                        (expect-eqv 23 (getprop 'foo 'bar))
     48
     49                        (expect-success (putprop! 'foo 'bar #t))
     50                        (expect-true (getprop 'foo 'bar))
     51
     52                        (expect-success (remprop! 'foo 'bar))
     53                        (expect-eqv 23 (getprop 'foo 'bar))
     54
     55                        (expect-success (putprop! 'foo 'bar #t))
     56                        (expect-success (setprop! 'foo 'bar 123))
     57                        (expect-eqv 123 (getprop 'foo 'bar))
     58
     59                        (expect-success (putprop! 'xxx 'ski 'Rossi 'boot "Snug Fit"))
     60
     61                        (expect-equal "Snug Fit" (getprop 'xxx 'boot))
     62                        (expect-equal '(boot "Snug Fit" ski Rossi) (get-proplist 'xxx))
     63                        (expect-equal '(ski Rossi) (proplist 'xxx 'ski))
     64
     65                        (expect-equal '((boot . "Snug Fit") (ski . Rossi)) (get-proplist->alist 'xxx))
     66                        (expect-equal '((ski . Rossi)) (proplist->alist 'xxx 'ski))
     67                )
     68
     69                (test-group "Procedure" (
     70                                [baz (proplist-procedure (lambda () #t))]
     71                        )
     72
     73                        (gloss (conc "Using Procslot: " (->string (proplist-procslot))))
     74
     75                        (expect-false (getprop baz 'bar))
     76                        (expect-true (getprop baz 'bar #t))
     77
     78                        (expect-success (putprop! baz 'bar 23))
     79                        (expect-eqv 23 (getprop baz 'bar))
     80
     81                        (expect-success (putprop! baz 'bar #t))
     82                        (expect-true (getprop baz 'bar))
     83
     84                        (expect-success (remprop! baz 'bar))
     85                        (expect-eqv 23 (getprop baz 'bar))
     86
     87                        (expect-success (putprop! baz 'bar #t))
     88                        (expect-success (setprop! baz 'bar 123))
     89                        (expect-eqv 123 (getprop baz 'bar))
     90                )
    3691        )
    3792)
    3893
    39 (test-apply #;output-style-compact test-proplist)
     94(test-apply output-style-compact test-proplist)
  • proplist/proplist.scm

    r1936 r2416  
    88;; - Some property operations are not very efficient.
    99
    10 (use srfi-69)
     10(use srfi-1 extras lolevel srfi-69)
    1111
    1212(eval-when (compile)
    1313        (declare
    1414        (usual-integrations)
    15         (uses srfi-1 extras)
    1615        (fixnum)
    1716                (inline)
    1817                (export
    19                         current-property-list-uses-extraslot
     18                        proplist-extraslot
     19                        proplist-procslot
     20                        proplist-procedure
    2021                        getprop putprop! setprop!
    2122                        remprop! remprop/all!
     
    3738)
    3839
    39 ;;;
    40 
    41 (define-constant very-big-fixnum 1073741823)
    42 
    43 (define void-value (void))
    44 
    45 ;;; Extra Symbol Slot
    46 
    47 #;(define extraslot-feature? (not (not (memq #:extraslot (features)))))
    48 (define extraslot-feature? (##sys#fudge 33))
    49 
    50 (define-constant DEFAULT-USE-EXTRASLOT #t)
    51 
    52 (define *use-extraslot* (and extraslot-feature? DEFAULT-USE-EXTRASLOT))
    53 
    54 (define current-property-list-uses-extraslot
     40;;; Symbol/Procedure Slot
     41
     42(define has-extraslot-feature?
     43        #;(not (not (memq #:extraslot (features))))
     44        (##sys#fudge 33) )
     45
     46(define *use-extraslot* has-extraslot-feature?)
     47
     48(define proplist-extraslot
    5549        (make-parameter *use-extraslot*
    5650                (lambda (x)
    57                         (if (and extraslot-feature? (boolean? x))
    58                                 (begin (set! *use-extraslot* x) x)
    59                                 *use-extraslot* ) )) )
     51                        (when (boolean? x)
     52                                (set! *use-extraslot* (and has-extraslot-feature? x)))
     53                        *use-extraslot*)))
    6054
    6155(define-inline (extraslot-ref sym #!optional default)
    6256        (let ([val (##sys#slot sym 2)])
    63                 (if (eq? void-value val) default val) ) )
     57                (if (eq? (void) val) default val) ) )
    6458
    6559(define-inline (extraslot-set! sym obj)
    6660        (##sys#setslot sym 2 obj) )
    6761
     62(define *use-procslot* #t)
     63
     64(define proplist-procslot
     65        (make-parameter *use-procslot*
     66                (lambda (x)
     67                        (when (boolean? x)
     68                                (set! *use-procslot* x))
     69                        *use-procslot*)))
     70
    6871;;; Primitive Property List Accessors
    6972
    7073(define *property-hashtable* (make-hash-table eq? hash-by-identity))
    7174
    72 (define (proplist-ref name)
     75(define-inline (proplist-ref name)
    7376        (cond
     77                [(and *use-extraslot* (symbol? name)) (extraslot-ref name '())]
     78                [(and *use-procslot* (procedure? name)) (procedure-data name)]
    7479                [(list? name) name]
    75                 [(and *use-extraslot* (symbol? name)) (extraslot-ref name '())]
    7680                [else (hash-table-ref/default *property-hashtable* name '())] ) )
    7781
    78 (define (proplist-set! name proplist)
     82(define-inline (proplist-set! name proplist)
    7983        (cond
     84                [(and *use-extraslot* (symbol? name)) (extraslot-set! name proplist) name]
     85                [(and *use-procslot* (procedure? name)) (set-procedure-data! name proplist) name]
    8086                [(list? name) proplist]
    81                 [(and *use-extraslot* (symbol? name)) (extraslot-set! name proplist) name]
    8287                [else (hash-table-set! *property-hashtable* name proplist) name] ) )
    8388
     
    105110
    106111;;; Property List Accessors
     112
     113(define (proplist-procedure proc)
     114        (extend-procedure proc '()) )
    107115
    108116;; getprop Name Property [Default]
  • proplist/proplist.setup

    r1798 r2416  
    11(include "setup-header")
    22
    3 (install-dynld+docu proplist "1.4")
     3(install-dynld+docu proplist "1.5")
Note: See TracChangeset for help on using the changeset viewer.