133 lines
3.4 KiB
Scheme
133 lines
3.4 KiB
Scheme
;;;; 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
|