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

(declare
  (bound-to-procedure
    ##sys#symbol-has-toplevel-binding?))

(module symbol-access

(;export
  ;
  toplevel-module-symbol
  ;
  global-symbol-bound?
  global-symbol-ref
  ;
  internal-module-name?
  ;
  split-prefixed-symbol)

(import scheme
	(chicken base)
	(chicken type)
	(only (srfi 13) string-skip string-drop string-take string-index))

(: toplevel-module-symbol (#!optional symbol -> symbol))
(: cached-toplevel-module-string (-> string))
(: global-symbol-ref (symbol -> *))
(: global-symbol-bound? (symbol -> boolean))
(: internal-module-name? (string -> boolean))
(: split-prefixed-symbol (symbol -> string string))

;;

(define-constant TOPLEVEL-MODULE-SYMBOL '||)

;;

(define-inline (namespace-tag-length str)
  ;namespaced identifier begins w/ '##'
  (cond ((string-skip str #\#) => identity)
    (else 0) ) )

(define (global-symbol-name-start str)
  ;modulename & namespace identifier has no '#' (?)
  (string-index str #\# (namespace-tag-length str)) )

;; Toplevel Symbols

(define toplevel-module-symbol (make-parameter #f (lambda (x)
  (cond ((not x)
          TOPLEVEL-MODULE-SYMBOL)
        ((symbol? x)
          x)
        (else
          (warning 'toplevel-module-symbol "not a symbol" x)
          (toplevel-module-symbol))))))

;symbol keyed memoized string
(define cached-toplevel-module-string
  (let ((topsym (string->uninterned-symbol ""))
        (topstr "") )
    (lambda ()
      (if (eq? topsym (toplevel-module-symbol))
          topstr
          (begin
            (set! topsym (toplevel-module-symbol))
            (set! topstr (symbol->string topsym))
            (cached-toplevel-module-string) ) ) ) ) )

;; Raw Access Renames

(define (global-symbol-bound? sym) (##sys#symbol-has-toplevel-binding? sym))

(define (global-symbol-ref sym) (##sys#slot sym 0))

;;

(define (internal-module-name? str)
  (not (zero? (namespace-tag-length str))) )

;=> module-name identifier-name
;
(define (split-prefixed-symbol sym)
  (let* (;symbol name (keyword w/o print-mark)
         (str (symbol->string sym))
         ;module break char index
         (idx (global-symbol-name-start str)) )
    ;module?
    (if idx
        (values (string-take str idx) (string-drop str (add1 idx)))
        (values (cached-toplevel-module-string) str) ) ) )

) ;module symbol-access