; .EnTete "Le-Lisp (c) version 15.2" " " "Les abre'viations"
; .EnPied " " "%" " "
; .SuperTitre "Les abre'viations du lecteur"
;
; .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: abbrev.ll,v 4.1 88/01/13 12:18:10 kuczynsk Rel $"


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

(add-feature 'abbrev)

; .Section "Gestion des abre'viations"

; Les abre'viations sont stocke'es dans une aliste globale de
; nom #:system:abbrevs-alist sous la forme :
;      ((symb . abbrev) ... (symb . abbrev))

(unless (boundp '#:system:abbrevs-alist)
	(defvar #:system:abbrevs-alist ()))


(defvar errsxtacc 
#- #:system:foreign-language "mauvaise abreviation {}"
#+ #:system:foreign-language "bad {} abbreviation"
)

(defvar errsxtclosingacc
#- #:system:foreign-language "} en dehors d'une abreviation {}"
#+ #:system:foreign-language "} not within {}"
)

(defvar errnotanabbrev
#- #:system:foreign-language "l'argument n'est pas une abreviation"
#+ #:system:foreign-language "not an abbreviation"
)

(dmd defabbrev (symb abbrev)
    `(put-abbrev ',symb ',abbrev))

(de put-abbrev (symb abbrev)
    ; si l'abre'viation existait de'ja` elle est modifie'e.
    (until (symbolp symb)
           (setq symb (error 'put-abbrev 'errsym symb)))
    (until (symbolp abbrev)
           (setq abbrev (error 'put-abbrev 'errsym abbrev)))
    (let ((old (assq symb #:system:abbrevs-alist)))
         (if (consp old)
             (rplacd old abbrev)
             (setq #:system:abbrevs-alist
                            (acons symb abbrev #:system:abbrevs-alist))))
    symb)

(de rem-abbrev (symb)
    (until (symbolp symb)
           (setq symb (error 'rem-abbrev 'errsym symb)))
    (setq #:system:abbrevs-alist (delq (assq symb #:system:abbrevs-alist)
				       #:system:abbrevs-alist))
    symb)

(de get-abbrev (symb)
    (until (and (symbolp symb)
                (abbrevp symb))
           (setq symb (error 'get-abbrev errnotanabbrev symb)))
    (cassq symb #:system:abbrevs-alist))

(de abbrevp (symb)
    (if (consp (assq symb #:system:abbrevs-alist))
        t
        ()))

(de has-an-abbrev (symb)
    (car (rassq symb #:system:abbrevs-alist)))

; .Section "Lecture des abre'viations"

(dmc |}| ()
     (error '|}| errsxtclosingacc ()))

(dmc |{| ()
    (let ((l (read-delimited-list #/})))
         (until (and (consp l)
                     (symbolp (car l))
                     (null (cdr l)))
                (setq l (error '|{| errsxtacc l)))
         (setq l (get-abbrev (car l)))
         (reread (if l (explode l) '(#/| #/|))))
    (with ((typecn #/: 'cpkgc))
          (read)))


; .Section "Impression des abre'viations"

(unless (boundp '#:system:print-with-abbrev-flag)
	(defvar #:system:print-with-abbrev-flag t))

(de #:symbol:prin (symb)
    ; impression d'un symbole
    (if (and #:system:print-with-abbrev-flag
             (has-an-abbrev (packagecell symb)))
        (progn (let ((#:system:print-for-read ())) (pratom '|{|))
               (pratom (has-an-abbrev (packagecell symb)))
               (let ((#:system:print-for-read ())) (pratom '|}:|))
               (let ((#:system:print-package-flag ())) (pratom symb)))
        (pratom symb)))