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

Last change on this file since 36254 was 36254, checked in by kon, 3 months ago

better symbol-table-access api

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  (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(: bucket-symbol-ref (list --> (or boolean symbol)))
81;
82(define (bucket-symbol-ref bkt)
83  (and
84    (not (bucket-last? bkt))
85    (bucket-symbol bkt) ) )
86
87(: bucket-link-ref (list --> (or boolean list)))
88;
89(define (bucket-link-ref bkt)
90  (and
91    (not (bucket-last? bkt))
92    (bucket-link bkt)) )
93
94;; Symbol Table Cursor
95
96(define-type symbol-table-cursor pair)
97
98(: make-symbol-table-cursor (* * --> symbol-table-cursor))
99;
100(define make-symbol-table-cursor cons)
101
102(: cursor-active? (* --> boolean))
103;
104(define cursor-active? pair?)
105
106(: symbol-table-cursor? (* --> boolean))
107;
108(define (symbol-table-cursor? obj)
109  (or
110    (not obj)
111    (cursor-active? obj)) )
112
113(: cursor-index (symbol-table-cursor --> *))
114;
115(define cursor-index car)
116
117(: set-cursor-index! (symbol-table-cursor * -> void))
118;
119(define set-cursor-index! set-car!)
120
121(: cursor-bucket (symbol-table-cursor --> *))
122;
123(define cursor-bucket cdr)
124
125(: set-cursor-bucket! (symbol-table-cursor * -> void))
126;
127(define set-cursor-bucket! set-cdr!)
128
129(: symbol-table-cursor (--> symbol-table-cursor))
130;
131(define (symbol-table-cursor)
132  (make-symbol-table-cursor -1 '()) )
133
134;;;
135
136;;
137
138(: cursor-next (symbol-table-cursor --> (or boolean symbol-table-cursor)))
139;
140(define (cursor-next cursor)
141  (and
142    (cursor-active? cursor)
143    (let loop (
144      (bkt (bucket-link-ref (cursor-bucket cursor)))
145      (idx (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            (fx< idx (root-symbol-table-size))
155            ;this slot
156            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
157
158(: cursor-first (--> (or boolean symbol-table-cursor)))
159;
160(define (cursor-first)
161  (cursor-next (symbol-table-cursor)) )
162
163(: cursor-current (symbol-table-cursor --> (or boolean symbol)))
164;
165(define (cursor-current cursor)
166  (and
167    (cursor-active? cursor)
168    (bucket-symbol-ref (cursor-bucket cursor)) ) )
169
170) ;module symbol-table-access
Note: See TracBrowser for help on using the repository browser.