;;;; 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
  cursor-first
  cursor-current
  cursor-next)

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

;;

(define-type symbol-table-cursor pair)

(: root-symbol-table-size (-> fixnum))
(: root-symbol-table-element (fixnum -> pair))
(: bucket-symbol (pair -> symbol))
(: bucket-link (pair -> list))
(: bucket-last? (list --> boolean))
(: bucket-symbol-ref (list -> (or false symbol)))
(: 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 -> *))
(: set-cursor-index! (symbol-table-cursor * -> void))
(: cursor-bucket (symbol-table-cursor -> *))
(: set-cursor-bucket! (symbol-table-cursor * -> void))
(: symbol-table-cursor (-> symbol-table-cursor))
(: cursor-next (symbol-table-cursor -> (or false symbol-table-cursor)))
(: cursor-first (-> (or false symbol-table-cursor)))
(: cursor-current (symbol-table-cursor -> (or false symbol)))

;; 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 ((int i))
    "return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )

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

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

(define bucket-last? null?)

(define (bucket-symbol-ref bkt)
  (and
    (not (bucket-last? bkt))
    (bucket-symbol bkt) ) )

(define (bucket-link-ref bkt)
  (and
    (not (bucket-last? bkt))
    (bucket-link bkt)) )

;; Symbol Table Cursor


(define make-symbol-table-cursor cons)
(define cursor-active? pair?)
(define cursor-index car)
(define set-cursor-index! set-car!)
(define cursor-bucket cdr)
(define set-cursor-bucket! set-cdr!)

(define (symbol-table-cursor) (make-symbol-table-cursor -1 '()))
(define (symbol-table-cursor? obj) (or (not obj) (cursor-active? obj)) )

;;

(define (cursor-next cursor)
  (and
    (cursor-active? cursor)
    (let loop (
      (bkt (bucket-link-ref (cursor-bucket cursor)))
      (idx (cursor-index cursor)) )
      ;gotta bucket ?
      (if (and bkt (not (bucket-last? bkt)))
        ;then found something => where we are
        (make-symbol-table-cursor idx bkt)
        ;else try next hash-root slot
        (let ((idx (add1 idx)))
          (and
            ;more to go ?
            (< idx (root-symbol-table-size))
            ;this slot
            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )

(define (cursor-first)
  (cursor-next (symbol-table-cursor)) )

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

) ;module symbol-table-access