source: project/release/3/srfi-89/srfi-89-support.scm

Last change on this file was 7231, checked in by felix winkelmann, 13 years ago

added srfi-89

File size: 1.8 KB
Line 
1;;;; srfi-89-support.scm
2
3
4;------------------------------------------------------------------------------
5
6; Procedures needed at run time (called by the expanded code):
7
8; Perfect hash-tables with keyword keys.
9
10(define ($hash-keyword key n)
11  (let ((str (keyword->string key)))
12    (let loop ((h 0) (i 0))
13      (if (fx< i (string-length str))
14          (loop (fxmod (fx+ (fx* h 65536) (char->integer (string-ref str i)))
15                       n)
16                (fx+ i 1))
17          h))))
18
19(define ($perfect-hash-table-lookup table key)
20  (let* ((n (fx/ (vector-length table) 2))
21         (x (fx* 2 ($hash-keyword key n))))
22    (and (eq? (vector-ref table x) key)
23         (vector-ref table (fx+ x 1)))))
24
25; Handling of named parameters.
26
27(define $undefined (list 'undefined))
28
29(define ($req-key key-values i)
30  (let ((val (vector-ref key-values i)))
31    (if (eq? val $undefined)
32        (error "a required named parameter was not provided")
33        val)))
34
35(define ($opt-key key-values i default)
36  (let ((val (vector-ref key-values i)))
37    (if (eq? val $undefined)
38        (default)
39        val)))
40
41(define ($process-keys args key-hash-table key-values)
42  (let loop ((args args))
43    (if (null? args)
44        args
45        (let ((k (car args)))
46          (if (not (keyword? k))
47              args
48              (let ((i ($perfect-hash-table-lookup key-hash-table k)))
49                (if (not i)
50                    (error "unknown parameter keyword" k)
51                    (if (null? (cdr args))
52                        (error "a value was expected after keyword" k)
53                        (begin
54                          (if (eq? (vector-ref key-values i) $undefined)
55                              (vector-set! key-values i (cadr args))
56                              (error "duplicate parameter" k))
57                          (loop (cddr args)))))))))))
Note: See TracBrowser for help on using the repository browser.