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

Last change on this file since 36241 was 36241, checked in by kon, 9 months ago

split symbol-table-access into own module, rel 3.2.0

File size: 4.2 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  initial-symbol-table-cursor
40  root-symbol
41  next-root-symbol)
42
43(import scheme
44  (chicken base)
45  (chicken fixnum)
46  (chicken foreign)
47  (chicken type)
48  (chicken syntax))
49
50;; Symbol Table
51
52(: root-symbol-table-size (--> fixnum))
53;
54(define root-symbol-table-size
55  (foreign-lambda* int ()
56    "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )
57
58(: root-symbol-table-element (fixnum --> pair))
59;
60(define root-symbol-table-element
61  (foreign-lambda* scheme-object ((int i))
62    "C_return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
63
64(: bucket-symbol (pair --> symbol))
65;
66(define bucket-symbol
67  (foreign-lambda* scheme-object ((scheme-object bucket))
68    "C_return( raw_bucket_symbol( bucket ) );"))
69
70(: bucket-link (pair --> list))
71;
72(define bucket-link
73  (foreign-lambda* scheme-object ((scheme-object bucket))
74    "C_return( raw_bucket_link( bucket ) );"))
75
76(: bucket-last? (list --> boolean))
77;
78(define bucket-last? null?)
79
80;;
81
82(define-type symbol-table-cursor pair)
83
84(: make-symbol-table-cursor (* * --> symbol-table-cursor))
85;
86(define make-symbol-table-cursor cons)
87
88(: symbol-table-cursor-active? (* --> boolean))
89;
90(define symbol-table-cursor-active? pair?)
91
92(: symbol-table-cursor? (* --> boolean))
93;
94(define (symbol-table-cursor? obj)
95  (or
96    (not obj)
97    (symbol-table-cursor-active? obj)) )
98
99(: symbol-table-cursor-index (symbol-table-cursor --> *))
100;
101(define symbol-table-cursor-index car)
102
103(: set-symbol-table-cursor-index! (symbol-table-cursor * -> void))
104;
105(define set-symbol-table-cursor-index! set-car!)
106
107(: symbol-table-cursor-bucket (symbol-table-cursor --> *))
108;
109(define symbol-table-cursor-bucket cdr)
110
111(: set-symbol-table-cursor-bucket! (symbol-table-cursor * -> void))
112;
113(define set-symbol-table-cursor-bucket! set-cdr!)
114
115(: symbol-table-cursor (--> symbol-table-cursor))
116;
117(define (symbol-table-cursor)
118  (make-symbol-table-cursor -1 '()) )
119
120(: bucket-symbol-ref (list --> (or boolean symbol)))
121;
122(define (bucket-symbol-ref bkt)
123  (and
124    (not (bucket-last? bkt))
125    (bucket-symbol bkt) ) )
126
127(: bucket-link-ref (list --> (or boolean list)))
128;
129(define (bucket-link-ref bkt)
130  (and
131    (not (bucket-last? bkt))
132    (bucket-link bkt)) )
133
134;;;
135
136;;
137
138(: next-root-symbol (symbol-table-cursor --> (or boolean symbol-table-cursor)))
139;
140(define (next-root-symbol cursor)
141  (and
142    (symbol-table-cursor-active? cursor)
143    (let loop (
144      (bkt (bucket-link-ref (symbol-table-cursor-bucket cursor)))
145      (idx (symbol-table-cursor-index cursor)))
146      ;gotta bucket ?
147      (if (and bkt (not (bucket-last? bkt)))
148        ;then found something => where we are
149        (make-symbol-table-cursor idx bkt)
150        ;else try next hash-root slot
151        (let ((idx (fx+ 1 idx)))
152          (and
153            ;more to go ?
154            (< idx (root-symbol-table-size))
155            ;this slot
156            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
157
158(: initial-symbol-table-cursor (--> (or boolean symbol-table-cursor)))
159;
160(define (initial-symbol-table-cursor)
161  (next-root-symbol (symbol-table-cursor)) )
162
163(: root-symbol (symbol-table-cursor --> (or boolean symbol)))
164;
165(define (root-symbol cursor)
166  (and
167    (symbol-table-cursor-active? cursor)
168    (bucket-symbol-ref (symbol-table-cursor-bucket cursor)) ) )
169
170) ;module symbol-table-access
Note: See TracBrowser for help on using the repository browser.