source: project/release/5/apropos/trunk/symbol-table-access.scm @ 40266

Last change on this file since 40266 was 40266, checked in by Kon Lovett, 2 months ago

updated test runner, comments, reflow

File size: 3.9 KB
Line 
1;;;; symbol-table-access.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4#>
5/*special stuff from the runtime & scheme API*/
6#define ROOT_SYMBOL_TABLE_NAME  "."
7
8#define raw_symbol_table_size( stable )       ((stable)->size)
9#define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
10
11#define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
12#define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
13
14static C_regparm C_SYMBOL_TABLE *
15find_root_symbol_table()
16{
17  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
18}
19
20static C_regparm C_SYMBOL_TABLE *
21remember_root_symbol_table()
22{
23  static C_SYMBOL_TABLE *root_symbol_table = NULL;
24  if(!root_symbol_table) {
25    root_symbol_table = find_root_symbol_table();
26  }
27
28  return root_symbol_table;
29}
30
31//FIXME root_symbol_table re-allocated?
32//#define use_root_symbol_table   find_root_symbol_table
33#define use_root_symbol_table    remember_root_symbol_table
34<#
35
36(module symbol-table-access
37
38(;export
39  cursor-first
40  cursor-current
41  cursor-next)
42
43(import scheme)
44(import (chicken base))
45(import (chicken foreign))
46(import (chicken type))
47(import (chicken syntax))
48
49;;
50
51(define-type symbol-table-cursor (pair fixnum list))
52
53(: cursor-next (symbol-table-cursor --> (or false symbol-table-cursor)))
54(: cursor-first (--> (or false symbol-table-cursor)))
55(: cursor-current (symbol-table-cursor --> (or false symbol)))
56
57(: root-symbol-table-size (-> fixnum))
58(: root-symbol-table-element (fixnum -> pair))
59(: bucket-symbol (pair -> symbol))
60(: bucket-link (pair -> list))
61
62(: bucket-last? (list --> boolean))
63(: bucket-symbol-ref (list -> (or false symbol)))
64(: bucket-link-ref (list -> (or false list)))
65(: make-symbol-table-cursor (* * -> symbol-table-cursor))
66(: cursor-active? (* -> boolean))
67(: symbol-table-cursor? (* -> boolean))
68(: cursor-index (symbol-table-cursor -> *))
69(: set-cursor-index! (symbol-table-cursor * -> void))
70(: cursor-bucket (symbol-table-cursor -> *))
71(: set-cursor-bucket! (symbol-table-cursor * -> void))
72(: symbol-table-cursor (-> symbol-table-cursor))
73
74;; Symbol Table
75
76(define root-symbol-table-size
77  (foreign-lambda* int ()
78    "return( raw_symbol_table_size( use_root_symbol_table() ) );") )
79
80(define root-symbol-table-element
81  (foreign-lambda* scheme-object ((unsigned-integer i))
82    "return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
83
84(define bucket-symbol
85  (foreign-lambda* scheme-object ((scheme-object bucket))
86    "return( raw_bucket_symbol( bucket ) );"))
87
88(define bucket-link
89  (foreign-lambda* scheme-object ((scheme-object bucket))
90    "return( raw_bucket_link( bucket ) );"))
91
92(define bucket-last? null?)
93
94(define (bucket-symbol-ref bkt)
95  (and
96    (not (bucket-last? bkt))
97    (bucket-symbol bkt) ) )
98
99(define (bucket-link-ref bkt)
100  (and
101    (not (bucket-last? bkt))
102    (bucket-link bkt)) )
103
104;; Symbol Table Cursor
105
106
107(define make-symbol-table-cursor cons)
108(define cursor-active? pair?)
109(define cursor-index car)
110(define set-cursor-index! set-car!)
111(define cursor-bucket cdr)
112(define set-cursor-bucket! set-cdr!)
113
114(define (symbol-table-cursor) (make-symbol-table-cursor -1 '()))
115(define (symbol-table-cursor? obj) (or (not obj) (cursor-active? obj)) )
116
117;;
118
119(define (cursor-next cursor)
120  (and
121    (cursor-active? cursor)
122    (let loop ( (bkt (bucket-link-ref (cursor-bucket cursor)))
123                (idx (cursor-index cursor)) )
124      ;gotta bucket ?
125      (if (and bkt (not (bucket-last? bkt)))
126        ;then found something => where we are
127        (make-symbol-table-cursor idx bkt)
128        ;else try next hash-root slot
129        (let ((idx (add1 idx)))
130          (and
131            ;more to go ?
132            (< idx (root-symbol-table-size))
133            ;this slot
134            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
135
136(define (cursor-first)
137  (cursor-next (symbol-table-cursor)) )
138
139(define (cursor-current cursor)
140  (and
141    (cursor-active? cursor)
142    (bucket-symbol-ref (cursor-bucket cursor)) ) )
143
144) ;module symbol-table-access
Note: See TracBrowser for help on using the repository browser.