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

;;

(define-check+error-type symbol)
(define-check+error-type list)

;;

;;NOTE Symbol table access (unsupported)

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

;; 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)
              ;Library Unit w/ path
        (cond ((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-reference loc pkgnam) tplnam)
  (let ((tmpt (required-global-ref loc (required-localized-template pkgnam tplnam))))
    (localized-template-set! pkgnam tplnam tmpt) ) )

(define (fixup-references loc pkgnam var-tplnams)
  (every (fixup-reference loc (check-package-name loc pkgnam))
         (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