;;;; 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
  (chicken base)
  (chicken fixnum)
  (chicken foreign)
  (chicken type)
  (chicken syntax))

;; Symbol Table

(: root-symbol-table-size (--> fixnum))
;
(define root-symbol-table-size
  (foreign-lambda* int ()
    "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )

(: root-symbol-table-element (fixnum --> pair))
;
(define root-symbol-table-element
  (foreign-lambda* scheme-object ((int i))
    "C_return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )

(: bucket-symbol (pair --> symbol))
;
(define bucket-symbol
  (foreign-lambda* scheme-object ((scheme-object bucket))
    "C_return( raw_bucket_symbol( bucket ) );"))

(: bucket-link (pair --> list))
;
(define bucket-link
  (foreign-lambda* scheme-object ((scheme-object bucket))
    "C_return( raw_bucket_link( bucket ) );"))

(: bucket-last? (list --> boolean))
;
(define bucket-last? null?)

(: bucket-symbol-ref (list --> (or boolean symbol)))
;
(define (bucket-symbol-ref bkt)
  (and
    (not (bucket-last? bkt))
    (bucket-symbol bkt) ) )

(: bucket-link-ref (list --> (or boolean list)))
;
(define (bucket-link-ref bkt)
  (and
    (not (bucket-last? bkt))
    (bucket-link bkt)) )

;; Symbol Table Cursor

(define-type symbol-table-cursor pair)

(: make-symbol-table-cursor (* * --> symbol-table-cursor))
;
(define make-symbol-table-cursor cons)

(: cursor-active? (* --> boolean))
;
(define cursor-active? pair?)

(: symbol-table-cursor? (* --> boolean))
;
(define (symbol-table-cursor? obj)
  (or
    (not obj)
    (cursor-active? obj)) )

(: cursor-index (symbol-table-cursor --> *))
;
(define cursor-index car)

(: set-cursor-index! (symbol-table-cursor * -> void))
;
(define set-cursor-index! set-car!)

(: cursor-bucket (symbol-table-cursor --> *))
;
(define cursor-bucket cdr)

(: set-cursor-bucket! (symbol-table-cursor * -> void))
;
(define set-cursor-bucket! set-cdr!)

(: symbol-table-cursor (--> symbol-table-cursor))
;
(define (symbol-table-cursor)
  (make-symbol-table-cursor -1 '()) )

;;;

;;

(: cursor-next (symbol-table-cursor --> (or boolean symbol-table-cursor)))
;
(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 (fx+ 1 idx)))
          (and
            ;more to go ?
            (fx< idx (root-symbol-table-size))
            ;this slot
            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )

(: cursor-first (--> (or boolean symbol-table-cursor)))
;
(define (cursor-first)
  (cursor-next (symbol-table-cursor)) )

(: cursor-current (symbol-table-cursor --> (or boolean symbol)))
;
(define (cursor-current cursor)
  (and
    (cursor-active? cursor)
    (bucket-symbol-ref (cursor-bucket cursor)) ) )

) ;module symbol-table-access