apropos/symbol-access.scm

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

;; Issues
;;
;; - "variable" rather than parameter since only 1 symbol-table? seems
;; slightly faster.

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

(module symbol-access

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

(import scheme)
(import (scheme case-lambda))
(import (chicken base))
(import (chicken type))
(import (chicken syntax))
(import (chicken fixnum))
(import (only srfi-13 string-prefix? string-skip string-drop
              string-take string-index))

(define-type module-names (list-of string))

(: toplevel-module-symbol (#!optional symbol -> symbol))

(: *excluded-module-name? (string module-names --> boolean))
(: *split-prefixed-symbol (symbol string --> string string))

;these depend on a parameter, so cannot be --> but are #:clean
(: excluded-module-name? (string #!optional module-names -> boolean))
(: global-symbol-bound? (symbol -> boolean))
(: global-symbol-ref (symbol -> *))
(: split-prefixed-symbol (symbol #!optional string -> string string))

;;(srfi 1)

(import (only (srfi 1) any))
#; ;UNUSED until no (srfi 1)
(define (any pred lis1)
  (and (not (null? lis1))
       (let lp ((head (car lis1)) (tail (cdr lis1)))
         (if (null? tail)
             (pred head)    ; Last PRED app is tail call.
             (or (pred head) (lp (car tail) (cdr tail)))))) )

;;moremacros

;NOTE see Issues above
(define-syntax define-variable
  (syntax-rules ()
    ((define-variable ?name ?value ?guard)
     (define ?name
       (let* ((guard ?guard)
              (val (guard ?value)))
         (case-lambda
           (() val)
           ((obj)
             (set! val (guard obj))
             val ) ) ) ) )
    ((define-variable ?name ?value)
     (define-variable ?name ?value identity))
    ((define-variable ?name)
     (define-variable ?name (void)))))

;;

(define TOPLEVEL-MODULE-SYMBOL '||)

;;

(define-inline (namespace-tag-length str)
  ;namespaced identifier begins w/ '##'
  (or (string-skip str #\#)
      0) )

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

;; Toplevel Symbols

(define-variable toplevel-module-symbol #f
  (lambda (obj)
    (cond ((not obj) TOPLEVEL-MODULE-SYMBOL)
          ((symbol? obj) obj)
          (else
            (error 'toplevel-module-symbol "bad argument type - not a symbol or #f" obj)))))

;; Raw Access Renames

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

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

;;

(define (*excluded-module-name? str excld)
  (any (cut string-prefix? <> str) excld) )

(define (excluded-module-name? str #!optional (excld '()))
  (*excluded-module-name? str excld) )

;=> module-name identifier-name
;
(define (*split-prefixed-symbol sym topstr)
  (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 (fx+ idx 1)))
        (values topstr str) ) ) )

;=> module-name identifier-name
;
(define (split-prefixed-symbol sym #!optional (topstr (symbol->string (toplevel-module-symbol))))
  (*split-prefixed-symbol sym topstr) )

) ;module symbol-access