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

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

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

(: cursor-current (symbol-table-cursor* --> (or false symbol)))

(: cursor-next (symbol-table-cursor* --> symbol-table-cursor*))
(: cursor-first (--> symbol-table-cursor*))

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

;; Internals

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

;

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

;; 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))

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

(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))
(define-inline (set-cursor-index! a b) (set-car! a b))
(define-inline (cursor-bucket x) (cdr x))
(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)))

;;

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

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

(define (cursor-next cursor)
  (and (cursor-active? cursor)
                  ;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 ?
                    ;cannot cache N since arbitrary mutation possible between calls
                    (fx< idx (root-symbol-table-size))
                    ;this slot
                    (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )

;;

(define (cursor-fold g seed #!optional (cursor (symbol-table-cursor)))
  (let ((siz (root-symbol-table-size)))
    (if (or (fx= 0 siz) (not (cursor-active? cursor))) seed
                   ;starting from the "next" bucket!
        (let loop ((bkt (bucket-link-ref (cursor-bucket cursor)))
                   (idx (cursor-index cursor))
                   (seed seed) )
          (if (bucket-active? bkt)
              ;then continue to walk the bucket chain
              (loop (bucket-link-ref bkt) idx (g seed (bucket-symbol-ref 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