; .EnTete "Le-Lisp (c) version 15.2" " " "Les modules"
; .EnPied " " "%" " "
; .Chapitre 5 "Les Modules"
;
; .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: module.ll,v 4.9 89/01/11 20:40:19 nuyens Exp $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'module))
(defvar #:sys-package:colon 'module)
; .Section "Les variables globales"
;; Tous les modules charge's en me'moire sont pre'sents dans une
;; des 2 listes suivantes :
(unless (boundp ':compiled-list)
(defvar :compiled-list ()))
(unless (boundp ':interpreted-list)
(defvar :interpreted-list ()))
;; Les messages d'erreur.
(defvar :ERRNMD
#- #:system:foreign-language "module inexistant"
#+ #:system:foreign-language "module not found")
(defvar :ERRFPR
#- #:system:foreign-language "fichier protege"
#+ #:system:foreign-language "protected file")
(defvar :WARINM
#- #:system:foreign-language "chargement du module interprete"
#+ #:system:foreign-language "load interpreted module")
; .Section "Fonctions sur les de'finitions de module"
; Une <de'finition de module> est une A-liste de la forme :
; ((key1 . val1) ... (keyN . valN) (:header . <liste de chai↑nes>))
; La clef interne :header contient une liste de chai↑nes correspondant
; au fichier de descripton de module jusqu'a` l'occurrence de la premie`re
; clef qui ne fait pas partie des clefs connus de l'utilisateur (cette liste
; est contenue dans la variable :list-of-user-key).
; Cette clef est remplace'e par :deadheader si les lignes repre'sentant
; la de'finition des clefs utilisateurs ne peuvent plus e↑tre utilise'es.
; Dans ce cas les lignes sont quand me↑me imprime'es, pre'ce'de'es d'un ;
;; Contient la liste des clefs connus de l'utilisateur.
(defvar :list-of-user-key '(defmodule files import export include))
;; Chai↑ne de se'paration des clefs utilisateur et des clefs syste`me.
;; Comme son nom l'indique, cette chai↑ne est ajoute'e automatiquement.
;; mais n'a qu'une valeur cosme'tique.
(defvar :EndOfHeader ";;; Added automatically, don't type beyond this line.")
;; Le stockage (durant la lecture du fichier de description des modules)
;; des lignes du fichier est re'alise' au moyen des IT programmables.
;; Il demande l'utilisation des 2 variables globales suivantes :
(defvar :header ()) ; contient la liste des lignes courantes.
(defvar :in-user-part ()) ; indicateur d'e'tat de l'automate.
; .SSection "Lecture d'une de'finition de module"
(defun readdefmodule (module-name)
; retourne une de'finition de module.
(let ((module-file (probepathm module-name)))
(ifn module-file
(error 'readdefmodule :ERRNMD module-name)
(with ((inchan (openi module-file)) )
(let ((defmod ())
(header ())
(keyheader ':header)
(#:sys-package:colon #:sys-package:colon)
(#:sys-package:itsoft (cons 'module
#:sys-package:itsoft)))
; pre'paration de l'automate
(setq :header () :in-user-part t)
; lecture des clefs
(untilexit eof
; lecture d'une clef
(newl defmod
(cons (let ((#:system:read-case-flag ()))
(read))
(let ((#:system:read-case-flag t))
(read))))
; changement de :colon
(when (eq (caar defmod) 'defmodule)
(setq #:sys-package:colon (cdar defmod)))
(if (memq (caar defmod) :list-of-user-key)
(if :in-user-part
; rajout des chai↑nes correspondant
; a` la clef utilisateur
(setq header (append :header header)
:header ())
; cas e'trange ou` des clefs
; utilisateur apparaissent apre`s
; les clefs syste`me
(setq keyheader ':deadheader))
(setq :in-user-part ())))
; fabrique la de'finition de module :
; ((key1 . val1) .. (keyN . valN) (:header . strings))
(setq defmod (nreverse (acons keyheader
(nreverse header)
defmod)))
defmod)))))
(defun :bol ()
(super-itsoft 'module 'bol ())
(when :in-user-part
(newl :header (substring (inbuf) 0 (sub (inmax) 2)))))
; .SSection "Fonctions de manipulation des de'finitions de modules"
(defun getdefmodule (defmod key)
(cassq key defmod) )
(defun setdefmodule (defmod key val)
(let ((slot (assq key defmod)))
(if (consp slot)
(progn (rplacd slot val) defmod)
(nconc1 defmod (cons key val)))))
; .SSection "Impression des de'finitions de modules"
(de printdefmodule (defmod mod)
(let ((oldmod (readdefmodule mod))
(header (getdefmodule defmod ':header)))
(unless (equal oldmod defmod)
; ce n'est pas la me↑me description de module
; sinon le fichier n'est pas me↑me touche'.
(let ((outchan (outchan))
(out (probepathm mod)))
(ifn out
(error 'printdefmodule :ERRNMD mod)
(ifn (catcherror () (setq out (openo out)))
(error 'printdefmodule :ERRFPR out)
(outchan out)
(if (and header
(every (lambda (key)
(equal (getdefmodule defmod key)
(getdefmodule oldmod key)))
:list-of-user-key))
; les clefs utilisateur n'ont pas change'
(with ((rmargin (1+ (slen (outbuf)))))
(let ((#:system:print-for-read ()))
(mapc 'print header)
(print)
(print :EndOfHeader)
(:print-rest-of-keys defmod
:list-of-user-key)))
; les clefs utilisateur ont change'es
(when (getdefmodule defmod ':deadheader)
(let ((#:system:print-for-read ()))
(mapc (lambda (x) (print "; " x))
(getdefmodule defmod
':deadheader))))
(:print-rest-of-keys defmod ()))))
(close (outchan))
(outchan outchan))))
mod)
(defun :print-rest-of-keys (defmod except)
(let ((#:system:print-for-read t))
(mapc (lambda (slot)
(let ((key (car slot)))
(unless (or (memq key '(:header :deadheader))
(memq key except))
(print key)
(print (cdr slot)))))
defmod)))
; .Section "Chargement des modules"
(de loadmodule (name . flags)
(let ( (loaded (cons () ())) )
(:loadmodule-aux (concat name) loaded (car flags) (cadr flags))
; Traitement des modules charge's en compile'.
(mapc
(lambda (m)
(setq :compiled-list (delq m :compiled-list))
(setq :interpreted-list (delq m :interpreted-list))
(newl :compiled-list m) )
(car loaded) )
; Traitement des modules charge's en interpre'te'.
(mapc
(lambda (m)
(setq :compiled-list (delq m :compiled-list))
(setq :interpreted-list (delq m :interpreted-list))
(newl :interpreted-list m) )
(cdr loaded) )
name ))
(defun :loadmodule-aux (module loaded clos? inter?)
(let ( (def (readdefmodule module)) (file-obj? (probepatho module)) )
; On se place dans les fichiers charge's.
(if (and file-obj? (not inter?))
(rplaca loaded (cons module (car loaded)))
(setq file-obj? ())
(rplacd loaded (cons module (cdr loaded))) )
(let ( (interp (cdr loaded)) )
; On charge si besoin tous les modules importe's.
(mapc
(lambda (m)
(when (and (not (memq m (car loaded)))
(not (memq m (cdr loaded)))
(or clos?
(not (memq m :compiled-list)) ))
(if (and (not clos?) (memq m :interpreted-list))
; Un module importe' est de'ja` en interpre'te'.
(setq interp t)
; Sinon on charge ce module.
(:loadmodule-aux m loaded clos? inter?) )))
(getdefmodule def 'import) )
; Si le module est compile' on ve'rifie que les modules importe's
; sont bien compile's et que le chargeur existe.
(when (and file-obj?
(or (neq (cdr loaded) interp)
(not (featurep 'loader)) ))
(setq file-obj? ())
(rplaca loaded (delq module (car loaded)))
(rplacd loaded (cons module (cdr loaded))) ))
(if file-obj?
; Chargement module compile'.
(let ( (deb (#:system:ccode)) )
(protect
(loadobjectfile module)
(putprop module (cons deb (#:system:ccode)) ':limit) ))
; Chargement module interpre'te'.
(print ";; " :WARINM " : " module)
(mapc
(lambda (f) (libloadfile f t))
(getdefmodule def 'files) ))))
; .Section "De'finition des modules autoload"
(defun filegetdef (file symb)
(let ((real-file (probepathf file)))
(ifn real-file
(error 'filegetdef 'errfile file)
(let (us
(def ()))
(with ((inchan (openi real-file)))
(untilexit eof
(when (consp (setq us (read)))
(selectq (car us)
((de defun df defmacro dm dmd)
(when (eq (cadr us) symb)
(close (inchan))
(exit eof (setq def us)) ))
(t ; Il faut traiter les synonym et ds.
)))))
def ))))
(df autoloadmodule list-of-module
(mapc (lambda (module)
(let ((defmod (readdefmodule module)))
(mapc (lambda (fnt)
(when (symbolp fnt)
(:makeautoload fnt module
(getdefmodule defmod 'files))))
(getdefmodule defmod 'export) )))
list-of-module))
(defun :makeautoload (fnt module files)
(let ( (def ()) type )
(while (and (null def) files)
(setq def (filegetdef (nextl files) fnt)) )
(ifn def
(error 'autoload "can't find definition of" fnt)
(selectq (car def)
((de defun)
(setq def `(:args (:std-autoload ',fnt) (apply ',fnt :args))
type 'expr ))
(df
(setq def `(:args (:std-autoload ',fnt) (apply ',fnt :args))
type 'fexpr ))
((defmacro dmd)
(setq def `(:args (:std-autoload ',fnt) (cons ',fnt :args))
type 'dmacro ))
(dm
(setq def `(:args (:std-autoload ',fnt) :args)
type 'macro ))
(t (error 'autoload "Bad definition" def)) )
(setfn fnt type def)
(putprop fnt (or module files) 'autoload) )))
(defun :std-autoload (fnt)
(let ( (of (valfn fnt)) (files (getprop fnt 'autoload)) rep )
(if (consp files)
(mapc (lambda (f) (libloadfile f t)) files)
(loadmodule files) )
(when (eq (valfn fnt) of)
(error 'autoload "definition not found" (cons fnt files)) )))
(defun autoloadp (fnt)
(getprop fnt 'autoload))