; .Entete "Le-Lisp (c) version 15.2" " " "Les manipulations de fichiers"
; .EnPied "files.ll" "B-%" " "
; .Annexe B "Les Manipulations de Fichiers"
; .nr % 1
;
; .Centre "*****************************************************************"
; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
; .Centre "*****************************************************************"

; .Centre "$Header: files.ll,v 4.7 88/11/22 22:18:06 nuyens Exp $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'files))

(defvar #:sys-package:colon 'system)

; .Section "Gestion des FEATURES"

(unless (boundp '#:system:features-list)
    (defvar #:system:features-list ()))

(de featurep (feature)
    (if (memq feature #:system:features-list)
        feature
        ()))

(de add-feature (feature)
    (unless (featurep feature)
            (newl #:system:features-list feature)))

(de rem-feature (feature)
    (setq #:system:features-list (delq feature #:system:features-list)))

(de list-features ()
    (copy #:system:features-list))

; .Section "Load et Autoload"

(defvar :previous-def-flag ())

; .SSection "Test sur les fichiers"

(de probepathf (file)
    ; cherche si le fichier {PATH}file[.ll] existe.
    (setq file (coerce-namestring file))
    (or (search-in-path :path (suffixe file :lelisp-extension))
	(search-in-path :path file)))

(de probepathm (file)
    ; cherche si le fichier {PATH}file[.lm] existe.
    (search-in-path :path (suffixe file :mod-extension)))

(de probepatho (file)
    ; cherche si le fichier {PATH}file[.lo] existe.
    (search-in-path :path (suffixe file :obj-extension)))

(de suffixe (file suff)
    (if (eq (index suff file) (sub (slength file) (slength suff)))
        file
        (catenate file suff) ))

(de search-in-path (path file)
    ; cherche si le fichier {PATH}file existe.
    (when path
          (let ((real-file (catenate (if (consp path) (car path) path) file)))
               (if (probefile real-file)
                   real-file
                   (when (consp path) (search-in-path (cdr path) file))))))

; .SSection "des fichiers simples"

(df load (file . redef?)
    (loadfile file (car redef?)) )

(de loadfile (file redef?)
    (ifn (probefile file)
         (error 'loadfile 'errfile file)
         (let ((:loaded-from-file file)
               (:redef-flag redef?)
               (#:sys-package:colon #:sys-package:colon)
               (:in-read-flag ())
               (inchan (inchan)) )
              (inchan (openi file))
              (protect (untilexit eof (eval (read)))
                       (let ((in (inchan)))
                            (when in (close in)))
                       (inchan inchan) ))
         file ))
 

; .SSection "des fichiers des bibliothe`ques"

(df libload (file . redef?)
    (libloadfile file redef?) )

(de libloadfile (file redef?)
    (let ((real-file (probepathf file)))
         (ifn real-file
              (error 'libloadfile 'errfile file)
              (loadfile real-file redef?) )))

; .SSection "des fichiers compile's"

(de loadobjectfile (file)
    (let ((file-obj? (probepatho file)))
         (ifn file-obj?
              (error 'loadobjectfile 'errfile file)
	      (let ((save #:system:read-case-flag))
		(setq #:system:read-case-flag 'loadobjectfile)
		(loadfile file-obj? t)
		(when (eq #:system:read-case-flag 'loadobjectfile)
		      ; Personne n'y a touche: on remet l'ancienne
		      (setq #:system:read-case-flag save))
		file-obj?))))

; .SSection "des fichiers autoload"

(df autoload (file . lfnt)
    ; de'finition de fonctions autoload (autoload mod at1 ... atN)
    (mapc (lambda (fnt)
                  (setfn fnt 'fexpr
                         `(:b (:std-autoload ',fnt :b 'loadfile)))
                  (putprop fnt file 'autoload))
          lfnt))
    
(df libautoload (file . lfnt)
    ; de'finition de fonctions autoload (libautoload mod at1 ... atN)
    (mapc (lambda (fnt)
                  (setfn fnt 'fexpr
                         `(:b (:std-autoload ',fnt :b 'libloadfile)))
                  (putprop fnt file 'autoload))
          lfnt))

(de :std-autoload (:f :b :load-fct)
    (let ((:of (valfn :f)) 
          (:ot (typefn :f))
          (:autoload-file (getprop :f 'autoload)))
         (cond ((null :autoload-file)
		(error 'autoload 'ERRFILE :f))
	       ((and (catcherror t (funcall :load-fct :autoload-file t))
		     (neq :of (valfn :f)))
                (remprop :f 'autoload)
                (eval (cons :f :b)))
               (t
		(setfn :f :ot :of)
		(error 'autoload 'errudf :f)))))