;;;; srfi-29-logic.scm
;;;; Kon Lovett, Jun '17
;;;; Kon Lovett,
;;;; Kon Lovett, Dec '05

;; Issues
;;
;; - Uses `module-rename' to construct a module qualified identifier; copied
;; from unit modules.

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

(module srfi-29-logic

(;export
  load-localized-compiled-code)

(import scheme
	utf8
	(chicken base)
	(chicken type)
	(only (chicken load) load-library load-relative load-noisily)
  (only (chicken platform) register-feature!)
	(only (srfi 1) first second every)
	(only type-checks check-symbol check-list define-check+error-type)
	(only type-errors-basic error-bound-value)
	(srfi 29))

;;;

;FIXME template variable
(define-type template-identifier-name (or symbol (pair symbol *)))

(: load-localized-compiled-code ((or symbol list) symbol (list-of template-identifier-name) -> void))

;;NOTE Symbol table access (unsupported)

(define (%global-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
(define (%global-ref sym) (##sys#slot sym 0))

;;; "Logic Bundle"

;; Support

;;(unit modules)

(define (module-rename sym prefix)
  (string->symbol
    (string-append
      (symbol->string prefix) "#" (symbol->string sym) ) ) )

;Support both "styles" of alist element: (key . (value ...)) & (key . value)
;where value is assumed to be an atom.
;Assumes valid argument!
(define (alist-element-atomic-value p)
  (let ((val (cdr p)))
    (if (pair? val) (car val) val) ) )

;Assumes valid argument!
(define (make-identifier ident)
  (if (pair? ident)
    ;qualified name
    (module-rename (alist-element-atomic-value ident) (car ident))
    ;unqualified name
    ident ) )

;Assumes valid argument!
(define (required-global-ref loc ident)
  (let ((ident (make-identifier ident)))
    (if (and ident (%global-bound? ident))
      (%global-ref ident)
      (error-bound-value loc (void) ident) ) ) )

;; Form checks

(define (template-identifier-name? obj)
  (or (symbol? obj)
      (and (pair? obj)
           (symbol? (car obj))
           (symbol? (alist-element-atomic-value obj)))) )

(define-check+error-type template-identifier-name)

(define (check-template-variable-name loc pkgnam obj #!optional argnam)
  (check-template-identifier-name
    loc
    (required-localized-template pkgnam (check-symbol loc obj argnam))
    argnam)
  obj )

(define (check-template-variable-names loc pkgnam obj #!optional argnam)
  (for-each
    (cut check-template-variable-name loc pkgnam <> argnam)
    (check-list loc obj argnam))
  obj )

;There must be a better way using sys namespace operations.
;(Chicken 4.2.2 had a query for ALL loaded binaries.)
;(KRL dloader branch still does.)

; A `library-name' is a pathname or unitname.
(define loaded-library?)
(define loaded-library!)
(let ((+loaded-libraries+ '()))
  ;
  (set! loaded-library? (lambda (ln)
    (member ln +loaded-libraries+) ) )
  ;
  (set! loaded-library! (lambda (ln)
    (set! +loaded-libraries+ (cons ln +loaded-libraries+)) ) ) )

;;

(define (load-code loc libspec)
  (let (
    (unit
      (let ((itm (if (pair? libspec) (first libspec) libspec)))
        (and (symbol? itm) itm)))
    (path
      (let ((itm (if (pair? libspec) (second libspec) libspec)))
        (cond
          ((string? itm)
            itm)
          ((symbol? itm)
            (symbol->string itm))
          (else
            #f)))) )
    ;pathname is preferred to a unitname
    (let ((pn (or path unit)))
      (unless (loaded-library? pn)
        (cond
          ;Library Unit w/ path
          ((and unit path)
            (load-library unit path) )
          ;Library Unit
          (unit
            (load-library unit) )
          ;Must be absolute pathaname, otherwise pathname is relative to
          ;the "current file"
          (path
            (load-relative path) )
          (else
            (error loc "invalid library load specificiation" libspec) ) )
        (loaded-library! pn) ) ) ) )

;;

(define (fixup-references loc pkgnam var-tplnams)
  (check-package-name loc pkgnam)
  (every
    (lambda (tplnam)
      (localized-template-set!
        pkgnam tplnam
        (required-global-ref loc (required-localized-template pkgnam tplnam))) )
    (check-template-variable-names loc pkgnam var-tplnams)) )

;;;

;;

(define (load-localized-compiled-code libspec pkgnam var-tplnams)
  (load-code 'load-localized-compiled-code libspec)
  (fixup-references 'load-localized-compiled-code pkgnam var-tplnams) )

;;

(register-feature! 'srfi-29-logic)

) ;module srfi-29-logic