;;;; 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
  initial-symbol-table-cursor
  root-symbol
  next-root-symbol)

(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?)

;;

(define-type symbol-table-cursor pair)

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

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

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

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

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

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

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

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

(: 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)) )

;;;

;;

(: next-root-symbol (symbol-table-cursor --> (or boolean symbol-table-cursor)))
;
(define (next-root-symbol cursor)
  (and
    (symbol-table-cursor-active? cursor)
    (let loop (
      (bkt (bucket-link-ref (symbol-table-cursor-bucket cursor)))
      (idx (symbol-table-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 ?
            (< idx (root-symbol-table-size))
            ;this slot
            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )

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

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

) ;module symbol-table-access