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

Last change on this file since 38992 was 38992, checked in by Kon Lovett, 13 months ago

type is interface, more specific return type for symbol-table-cursor

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)
52
53(: root-symbol-table-size (-> fixnum))
54(: root-symbol-table-element (fixnum -> pair))
55(: bucket-symbol (pair -> symbol))
56(: bucket-link (pair -> list))
57(: bucket-last? (list --> boolean))
58(: bucket-symbol-ref (list -> (or false symbol)))
59(: bucket-link-ref (list -> (or false list)))
60(: make-symbol-table-cursor (* * -> symbol-table-cursor))
61(: cursor-active? (* -> boolean))
62(: symbol-table-cursor? (* -> boolean))
63(: cursor-index (symbol-table-cursor -> *))
64(: set-cursor-index! (symbol-table-cursor * -> void))
65(: cursor-bucket (symbol-table-cursor -> *))
66(: set-cursor-bucket! (symbol-table-cursor * -> void))
67(: symbol-table-cursor (-> symbol-table-cursor))
68(: cursor-next (symbol-table-cursor -> (or false symbol-table-cursor)))
69(: cursor-first (-> (or false symbol-table-cursor)))
70(: cursor-current (symbol-table-cursor -> (or false symbol)))
71
72;; Symbol Table
73
74(define root-symbol-table-size
75  (foreign-lambda* int ()
76    "return( raw_symbol_table_size( use_root_symbol_table() ) );") )
77
78(define root-symbol-table-element
79  (foreign-lambda* scheme-object ((int i))
80    "return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
81
82(define bucket-symbol
83  (foreign-lambda* scheme-object ((scheme-object bucket))
84    "return( raw_bucket_symbol( bucket ) );"))
85
86(define bucket-link
87  (foreign-lambda* scheme-object ((scheme-object bucket))
88    "return( raw_bucket_link( bucket ) );"))
89
90(define bucket-last? null?)
91
92(define (bucket-symbol-ref bkt)
93  (and
94    (not (bucket-last? bkt))
95    (bucket-symbol bkt) ) )
96
97(define (bucket-link-ref bkt)
98  (and
99    (not (bucket-last? bkt))
100    (bucket-link bkt)) )
101
102;; Symbol Table Cursor
103
104
105(define make-symbol-table-cursor cons)
106(define cursor-active? pair?)
107(define cursor-index car)
108(define set-cursor-index! set-car!)
109(define cursor-bucket cdr)
110(define set-cursor-bucket! set-cdr!)
111
112(define (symbol-table-cursor) (make-symbol-table-cursor -1 '()))
113(define (symbol-table-cursor? obj) (or (not obj) (cursor-active? obj)) )
114
115;;
116
117(define (cursor-next cursor)
118  (and
119    (cursor-active? cursor)
120    (let loop (
121      (bkt (bucket-link-ref (cursor-bucket cursor)))
122      (idx (cursor-index cursor)) )
123      ;gotta bucket ?
124      (if (and bkt (not (bucket-last? bkt)))
125        ;then found something => where we are
126        (make-symbol-table-cursor idx bkt)
127        ;else try next hash-root slot
128        (let ((idx (add1 idx)))
129          (and
130            ;more to go ?
131            (< idx (root-symbol-table-size))
132            ;this slot
133            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
134
135(define (cursor-first)
136  (cursor-next (symbol-table-cursor)) )
137
138(define (cursor-current cursor)
139  (and
140    (cursor-active? cursor)
141    (bucket-symbol-ref (cursor-bucket cursor)) ) )
142
143) ;module symbol-table-access
Note: See TracBrowser for help on using the repository browser.