apropos/symbol-table-access.scm

;;;; symbol-table-access.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

#>
/*special stuff from the runtime & scheme API*/
#define ROOT_SYMBOL_TABLE_NAME  "."

#define raw_symbol_table_size( stable )       ((stable)->size)
#define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])

#define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
#define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))

static C_regparm C_SYMBOL_TABLE *
find_root_symbol_table()
{
  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
}

static C_regparm C_SYMBOL_TABLE *
remember_root_symbol_table()
{
  static C_SYMBOL_TABLE *root_symbol_table = NULL;
  if(!root_symbol_table) {
    root_symbol_table = find_root_symbol_table();
  }

  return root_symbol_table;
}

/* FIXME root_symbol_table re-allocated?
#define use_root_symbol_table   find_root_symbol_table
*/
#define use_root_symbol_table   remember_root_symbol_table
<#

(module symbol-table-access

(;export
  ;
  #; ;UNUSED
  cursor-current
  #; ;UNUSED
  cursor-first
  #; ;UNUSED
  cursor-next
  ;
  cursor-foldl)

(import scheme)
(import (chicken base))
(import (chicken fixnum))
(import (chicken foreign))
(import (chicken type))
(import (chicken syntax))

;internal
(define-inline (%immediate? obj) (not (##core#inline "C_blockp" obj)))

(define-type symbol-table-cursor (pair fixnum list))
(define-type symbol-table-cursor* (or false symbol-table-cursor))

#; ;UNUSED
(: cursor-current (symbol-table-cursor* --> (or false symbol)))
#; ;UNUSED
(: cursor-first (--> symbol-table-cursor*))
#; ;UNUSED
(: cursor-next (symbol-table-cursor* --> symbol-table-cursor*))

(: cursor-foldl (('a symbol -> 'a) 'a #!optional symbol-table-cursor --> 'a))

#; ;closer than fold ;=)
(: cursor-unfold (('a -> booleam) ('a symbol -> 'a) 'a #!optional symbol-table-cursor --> 'a))

;;

(: root-symbol-table-size (-> fixnum))
(: root-symbol-table-element (fixnum -> pair))
(: bucket-symbol (pair -> symbol))
(: bucket-link (pair -> list))

(: bucket-last? (list --> boolean))
#; ;UNUSED
(: bucket-symbol-ref (list -> (or false symbol)))
#; ;UNUSED
(: bucket-link-ref (list -> (or false list)))
(: make-symbol-table-cursor (* * -> symbol-table-cursor))
(: cursor-active? (* -> boolean))
(: symbol-table-cursor? (* -> boolean))
(: cursor-index (symbol-table-cursor -> *))
#; ;UNUSED
(: set-cursor-index! (symbol-table-cursor * -> void))
(: cursor-bucket (symbol-table-cursor -> *))
#; ;UNUSED
(: set-cursor-bucket! (symbol-table-cursor * -> void))
(: symbol-table-cursor (-> symbol-table-cursor))

;; Symbol Table

(define root-symbol-table-size
  (foreign-lambda* int ()
    "return( raw_symbol_table_size( use_root_symbol_table() ) );") )

(define root-symbol-table-element
  (foreign-lambda* scheme-object ((unsigned-integer i))
    "return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )

(define bucket-symbol
  (foreign-lambda* scheme-object ((scheme-object bkt))
    "return( raw_bucket_symbol( bkt ) );"))

(define bucket-link
  (foreign-lambda* scheme-object ((scheme-object bkt))
    "return( raw_bucket_link( bkt ) );"))

(define-inline (bucket-last? bkt) (null? bkt))

#; ;UNUSED
(define-inline (bucket-symbol-ref bkt)
  (and (not (bucket-last? bkt))
       (bucket-symbol bkt) ) )

#; ;UNUSED
(define-inline (bucket-link-ref bkt)
  (and (not (bucket-last? bkt))
       (bucket-link bkt)) )

(define-inline (bucket-active? bkt)
  (and bkt
       (not (bucket-last? bkt))
       (not (%immediate? (bucket-symbol bkt)))) )

;; Symbol Table Cursor

(define-inline (make-symbol-table-cursor a b) (cons a b))
(define-inline (cursor-active? x) (pair? x))
(define-inline (cursor-index x) (car x))
#; ;UNUSED
(define-inline (set-cursor-index! a b) (set-car! a b))
(define-inline (cursor-bucket x) (cdr x))
#; ;UNUSED
(define-inline (set-cursor-bucket! a b) (set-cdr! a b))

(define-inline (symbol-table-cursor) (make-symbol-table-cursor -1 '()))

(define-inline (symbol-table-cursor? obj) (or (not obj) (cursor-active? obj)))

;;

#; ;UNUSED
(define (cursor-current cursor)
  (and (cursor-active? cursor)
       (bucket-symbol-ref (cursor-bucket cursor)) ) )

#; ;UNUSED
(define (cursor-first) (cursor-next (symbol-table-cursor)))

#; ;UNUSED
(define (cursor-next cursor)
  (and (cursor-active? cursor)
       ;cache table size since assuming no shape-shifting
       (let ((siz (root-symbol-table-size)))
                    ;starting from the "next" bucket!
         (let loop ((bkt (bucket-link-ref (cursor-bucket cursor)))
                    (idx (cursor-index cursor)) )
           ;gotta bucket ?
           (if (bucket-active? bkt)
               ;then found something => where we are
               (make-symbol-table-cursor idx bkt)
               ;else try next hash-root slot
               (let ((idx (fx+ idx 1)))
                 (and ;more to go ?
                      (fx< idx siz)
                      ;this slot
                      (loop (root-symbol-table-element idx) idx) ) ) ) ) ) ) )

;;

(define (cursor-foldl g seed #!optional (cursor (symbol-table-cursor)))
  ;cache table size since assuming no shape-shifting
  (let ((siz (root-symbol-table-size)))
    (if (or (fx= 0 siz) (not (cursor-active? cursor))) seed
                   ;starting at the current bucket!
        (let loop ((bkt (cursor-bucket cursor))
                   (idx (cursor-index cursor))
                   (seed seed) )
          (if (bucket-active? bkt)
              ;then continue to walk the bucket chain
              (loop (bucket-link bkt) idx (g seed (bucket-symbol bkt)))
              ;else walk the next bucket chain
              (let ((idx (fx+ idx 1)))
                ;exit when no more buckets
                (if (fx>= idx siz) seed
                    ;else continue w/ next bucket chain
                    (loop (root-symbol-table-element idx) idx seed) ) ) ) ) ) ) )

) ;module symbol-table-access