source: project/release/3/logging/trunk/logging-catalogs.scm @ 9025

Last change on this file since 9025 was 9025, checked in by Kon Lovett, 12 years ago

Canon dir struct

File size: 3.5 KB
Line 
1;;;; logging-catalogs.scm
2;;;; Kon Lovett, Sep '06
3
4(use srfi-18 utils)
5(use lookup-table synch miscmacros)
6(use logging-errors)
7
8(eval-when (compile)
9  (declare
10                (usual-integrations)
11        (fixnum)
12        (inline)
13        (export
14                log$empty-catalog
15                log$fill-catalog
16                        log$source-catalog->source
17                        log$field-catalog->field
18                        log$level-catalog->level
19                        log$entry-catalog->entry
20                        log$log-catalog->log
21                        log$catalog-value
22                        log$catalog-key
23                        log$catalog-ref
24                        log$catalog-add!
25                        log$catalog-set!
26                        log$catalog-delete!
27                log$source-catalog-for-each
28                log$field-catalog-for-each
29                log$level-catalog-for-each
30                log$entry-catalog-for-each
31                log$log-catalog-for-each) ) )
32
33;;; Catalog Support
34
35;; Lookup entry by symbol id or actual value
36
37(define (catalog-key/value cat key)
38        (%let/synch ([dict cat])
39                (if (symbol? key)
40                        (values
41                          key
42                          (dict-ref dict key))
43                        (values
44                                (dict-search dict
45                                        (lambda (id value)
46                                                (and (equal? key value)
47                                                           (begin (set! key id) #t))))
48                                key) ) ) )
49
50(define (log$catalog-value cat key)
51        (let-values (([id obj] (catalog-key/value cat key)))
52                (and id
53                     obj) ) )
54
55(define (log$catalog-key cat key)
56        (let-values (([id obj] (catalog-key/value cat key)))
57                (and obj
58                     id) ) )
59
60(define (log$catalog-ref cat key)
61        (%let/synch ([dict cat])
62                (dict-ref dict key) ) )
63
64(define (log$catalog-add! cat key value loc)
65        (let/synch ([dict cat])
66                (if (dict-ref dict key)
67                        (log$error loc "identifier in use" key)
68                        (dict-set! dict key value)) ) )
69
70(define (log$catalog-set! cat key value loc)
71        (%let/synch ([dict cat])
72                (dict-set! dict key value) ) )
73
74(define (log$catalog-delete! cat key)
75        ; Can remove from a catalog even if object in use
76        (%let/synch ([dict cat])
77                (dict-delete! dict key) ) )
78
79(define-constant INITIAL-CATALOG-SIZE 1)
80
81(define (make-catalog/synch id #!optional (dict (make-dict INITIAL-CATALOG-SIZE eq?)))
82        (make-object/synch dict id) )
83
84;;; Logger Catalog
85
86;; There is only one
87
88(define log$source-catalog->source #f)
89(define log$field-catalog->field #f)
90(define log$level-catalog->level #f)
91(define log$entry-catalog->entry #f)
92(define log$log-catalog->log #f)
93
94(define (log$empty-catalog)
95        (set! log$source-catalog->source (make-catalog/synch 'source-catalog->source))
96        (set! log$field-catalog->field (make-catalog/synch 'field-catalog->field))
97        (set! log$level-catalog->level (make-catalog/synch 'level-catalog->level))
98        (set! log$entry-catalog->entry (make-catalog/synch 'entry-catalog->entry))
99        (set! log$log-catalog->log (make-catalog/synch 'log-catalog->log)) )
100
101(define (log$fill-catalog sources fields levels entries logs)
102        (set! log$source-catalog->source
103                (make-catalog/synch 'source-catalog->source sources))
104        (set! log$field-catalog->field
105                (make-catalog/synch 'field-catalog->field fields))
106        (set! log$level-catalog->level
107                (make-catalog/synch 'level-catalog->level levels))
108        (set! log$entry-catalog->entry
109                (make-catalog/synch 'entry-catalog->entry entries))
110        (set! log$log-catalog->log
111                (make-catalog/synch 'log-catalog->log logs)) )
112
113;;;
114
115(define (catalog-for-each cat proc)
116        (let/synch ([dict cat])
117                (dict-for-each dict proc) ) )
118
119(define (log$source-catalog-for-each proc)
120        (catalog-for-each log$source-catalog->source proc) )
121
122(define (log$field-catalog-for-each proc)
123        (catalog-for-each log$field-catalog->field proc) )
124
125(define (log$level-catalog-for-each proc)
126        (catalog-for-each log$level-catalog->level proc) )
127
128(define (log$entry-catalog-for-each proc)
129        (catalog-for-each log$entry-catalog->entry proc) )
130
131(define (log$log-catalog-for-each proc)
132        (catalog-for-each log$log-catalog->log proc) )
133
Note: See TracBrowser for help on using the repository browser.