; .EnTete "Le-Lisp (c) version 15.2" " " "La fonction FORMAT"
; .EnPied " " "%" " "
; .Chapitre 16 "La fonction FORMAT"
;
; .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: format.ll,v 4.1 88/01/13 12:19:42 kuczynsk Rel $"
(unless (>= (version) 15.2)
(error 'load 'erricf 'format))
; Tous les symboles pre'ce'de's de : seront cre'e's dans le package FORMAT.
(defvar #:sys-package:colon 'format)
(add-feature 'format)
; .Section "La fonction d'appel"
(de prinf (:f-string . :args)
(ifn (stringp :f-string) (:error 'format :f-string))
(mapc 'princn (:format (pname :f-string) :args ())))
(de format (:where :f-string . :args)
(ifn (stringp :f-string) (:error 'format :f-string))
(let ((:result (:format (pname :f-string) :args ())))
(cond
((null :where) (:string :result))
((or (fixp :where) (eq :where t))
(when (eq :where t) (setq :where ()))
(with ((outchan :where)) (mapc 'princn :result) ()))
(t (:error 'format :where)))))
; .Section "Les fonctions internes"
(de :format (:format :args :r)
(let ((:f :format)(:l :args))
(tag format (tag hat (:format1))))
:r)
(de :format1 ()
(let ((:char (nextl :f)))
(cond
((null :char) (exit format))
((eq :char #/~)
(let ((:par1)(:par2)(:par3)(:par4)
(:par5)(:par6)(:par7)
(:at-sign)(:colon)(:par-n 1))
(:tilde-decode)))
(t (newr :r :char))))
(:format1))
(de :tilde-decode ()
(let ((:c (nextl :f)))
(selectq :c
((#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9 #/- #/+)
(set (symbol 'format (concat 'par :par-n)) (:read-n (list :c)))
(:tilde-decode))
(#/'
(set (symbol 'format (concat 'par :par-n)) (nextl :f))
(:tilde-decode))
((#/v #/V)
(set (symbol 'format (concat 'par :par-n)) (nextl :l))
(:tilde-decode))
(#/#
(set (symbol 'format (concat 'par :par-n)) (length :l))
(:tilde-decode))
(#/, (incr :par-n) (:tilde-decode))
(#/@ (setq :at-sign t) (:tilde-decode))
(#/: (setq :colon t) (:tilde-decode))
(#/A (:format-ascii (nextl :l)))
(#/S (:format-sexpr (nextl :l)))
(#/D (:format-decimal (nextl :l)))
(#/B (:format-binary (nextl :l)))
(#/O (:format-octal (nextl :l)))
(#/X (:format-hexa (nextl :l)))
(#/R (:format-radix (nextl :l)))
(#/P (:format-plural))
(#/C (:format-char (nextl :l)))
(#/E (:format-e-float (nextl :l)))
(#/F (:format-f-float (nextl :l)))
(#/G (:format-g-float (nextl :l)))
(#/% (:format-nl))
(#\lf (:format-eol))
(#/~ (:format-tilde))
(#/T (:format-tab))
(#/* (:format-ignore))
(#/? (:format-indirect))
(#/[ (:format-cond))
(#/{ (:format-iter ()))
(#/↑ (:format-hat))
(#/] (:error 'format
#- #:system:foreign-language "~] hors contexte"
#+ #:system:foreign-language "~] out of context"))
(#/; (:error 'format
#- #:system:foreign-language "~; hors contexte"
#+ #:system:foreign-language "~; out of context"))
(#/} (:error 'format
#- #:system:foreign-language "~} hors contexte"
#+ #:system:foreign-language "~} out of context"))
(#/) (:error 'format
#- #:system:foreign-language "~) hors contexte"
#+ #:system:foreign-language "~) out of context"))
(#/> (:error 'format
#- #:system:foreign-language "~> hors contexte"
#+ #:system:foreign-language "~> out of context"))
(t (:error 'format (string (list #/~ :c)))))))
(de :pad (:val :wide :side :padchar)
(let ((:length (length :val)))
(if (>= :length :wide) :val
(if :side
(nconc :val (makelist (- :wide :length) :padchar))
(nconc (makelist (- :wide :length) :padchar) :val)))))
(de :pad-4 (:val :wide :side :padchar :colinc :minpad)
(setq :val (if :side (nconc :val (makelist :minpad :padchar))
(nconc (makelist :minpad :padchar) :val)))
(:pad-4-loop (length :val)))
(de :pad-4-loop (:length)
(if (<= :wide :length) :val
(setq :val (if :side (nconc :val (makelist :colinc :padchar))
(nconc (makelist :colinc :padchar) :val)))
(:pad-4-loop (length :val))))
; .Section "Les diffe'rents spe'cialistes des FORMATS"
(de :format-pad (:val :par-1 :par-2)
(setq :r (nconc :r (ifn :par-1 :val
(:pad :val :par-1 :at-sign
(if :par-2 :par-2 #\sp))))))
(de :format-ascii (:arg)
(let ((#:system:print-for-read ()))
(if (or :par3 :par4)
(setq :r (nconc :r (:pad-4 (explode :arg) (if :par1 :par1 0)
:at-sign (if :par4 :par4 #\sp)
(if :par2 :par2 1)
(if :par3 :par3 0))))
(:format-pad (explode :arg) :par1 :par2))))
(de :format-sexpr (:arg)
(let ((#:system:print-for-read t))
(if (or :par3 :par4)
(setq :r (nconc :r (:pad-4 (explode :arg) (if :par1 :par1 0)
:at-sign (if :par4 :par4 #\sp)
(if :par2 :par2 1)
(if :par3 :par3 0))))
(:format-pad (explode :arg) :par1 :par2))))
(de :format-decimal (:arg)
(with ((obase 10))
(let ((#:system:print-for-read ()))
(:format-pad (explode :arg) :par1 :par2))))
(de :format-binary (:arg)
(with ((obase 2))
(let ((#:system:print-for-read ()))
(:format-pad (explode :arg) :par1 :par2))))
(de :format-octal (:arg)
(with ((obase 8))
(let ((#:system:print-for-read ()))
(:format-pad (explode :arg) :par1 :par2))))
(de :format-hexa (:arg)
(with ((obase 16))
(let ((#:system:print-for-read ()))
(:format-pad (explode :arg) :par1 :par2))))
(de :format-radix (:arg)
(ifn (fixp :par1) (:error ':format-radix "pas de base"))
(with ((obase :par1))
(let ((#:system:print-for-read ()))
(:format-pad (explode :arg) :par2 :par3))))
(de :format-plural ()
(let ((:arg (ifn :colon (nextl :l)
(nth (- (length :args) (length :l) 1) :args))))
(if (eq :arg 1)
(if :at-sign (setq :r (nconc1 :r #/y)))
(setq :r (nconc :r
(if :at-sign (list #/i #/e #/s) (list #/s)))))))
(de :format-char (:arg)
(ifn (asciip :arg) (:error ':format-char :arg))
(cond
((and :at-sign :colon)
(:error ':format-char
#- #:system:foreign-language "pas @ et : ensemble"
#+ #:system:foreign-language "@ and : not together"))
(:at-sign (setq :r (nconc :r
(cond
((= :arg #\del) (append '#"#\del" ()))
((> :arg #\sp) (list #/# #// :arg))
((= :arg #\sp) (append '#"#\sp" ()))
(t (list #/# #/↑ (logor #$40 :arg)))))))
(:colon (setq :r
(let ((:name (cassq :arg :char-names)))
(if :name (nconc :r (pname :name))
(nconc1 :r :arg)))))
(t (setq :r (nconc1 :r :arg)))))
(defvar :char-names ())
(for (i 0 1 31)
(newl :char-names (cons i (concat 'control- (ascii (logor #$40 i))))))
(progn (newl :char-names '(0 . null))
(newl :char-names '(7 . bell))
(newl :char-names '(8 . back-space))
(newl :char-names '(9 . tab))
(newl :char-names '(10 . line-feed))
(newl :char-names '(13 . return))
(newl :char-names '(27 . escape))
(newl :char-names '(32 . space))
(newl :char-names '(127 . delete)))
(de :float-pad (:wide :ovfchar :padchar :val)
(let ((:length (length :val)))
(setq :r
(nconc :r
(ifn :wide :val
(if (and :ovfchar (< :wide :length))
(makelist :wide :ovfchar)
(nconc (makelist (- :wide :length)
(if :padchar :padchar #\sp))
:val)))))))
(de :float-digits (:count)
(let* ((:x (* :f (power 10 (- 0 1 :exp))))
(:y (* .5 (power 10 (- :count))))
(:rest (+ :x :y))
(:list))
(when (> (fix :rest)(fix :x)) ; Au cas ou` l'arrondi nous engendre un
(setq :rest :x)) ;digit de plus avant la virgule(ex: 9.9 -> 10.0)
(while (> :count 0)
(let ((:fix (fix (* :rest 1e+4))))
(setq :list (nconc :list (:next-digits (explode :fix))))
(setq :rest (- (* :rest 1e+4) :fix))
(setq :count (- :count 4))))
:list))
(de :next-digits (:sublist)
(let ((:length (length :sublist)))
(nconc (makelist (- 4 :length) #/0) :sublist)))
(de :format-f-float (:arg)
(ifn (numberp :arg)
(let ((:par1 :par1)(:par2 :par5))
(:format-decimal :arg))
(ifn (floatp :arg) (setq :arg (float :arg)))
(if :par3 (setq :arg (* :arg (power 10 :par3))))
(:float-pad :par1 :par4 :par5
(let ((:rr (if (< :arg 0) (list #/-) (if :at-sign (list #/+))))
(:f (abs :arg)))
(if (or :par1 :par2)
(slet ((:exp (if (= :f 0) 0 (fix (log10 :f))))
(:par1 (or :par1 100))
(:par2
(or :par2
(max 0 (- :par1 2 (max :exp 0)
(if (or :at-sign (< :arg 0))
1 0)))))
(:digits (:float-digits (+ :par2 :exp 1))))
(:float-f) :rr)
(explode :f))))))
(de :float-f ()
(if (< :exp 0)
(let ((:zero (min (- -1 :exp) :par2)))
(ifn (and (= (- :par1 :par2) 1) (not :at-sign) (>= :arg 0))
(newr :rr #/0))
(newr :rr #/.)
(if (zerop :f)
(repeat :zero (newr :rr #/0))
(cond
((<> :zero :par2)
(repeat :zero (newr :rr #/0))
(repeat (- :par2 :zero) (newr :rr (nextl :digits))))
(t (repeat (1- :zero) (newr :rr #/0)) (newr :rr #/1)))))
(repeat (1+ :exp) (newr :rr (nextl :digits)))
(newr :rr #/.)
(repeat :par2 (newr :rr (nextl :digits)))))
(de :format-e-float (:arg)
(ifn (numberp :arg)
(let ((:par1 :par1)(:par2 :par6))
(:format-decimal :arg))
(ifn (floatp :arg) (setq :arg (float :arg)))
(ifn :par4 (setq :par4 1))
(:float-pad :par1 :par5 :par6
(let ((:rr (if (< :arg 0) (list #/-) (if :at-sign (list #/+))))
(:f (abs :arg)))
(if (or :par1 :par2 :par3)
(let ((:exp (if (= :f 0) 0 (floor (log10 :f))))
(:par1 (or :par1 100))
(:exp-r)
(:exp-l))
(:float-exp (- :exp :par4 -1))
(setq :exp-l (length :exp-r))
(if (= :exp-l :par1) :exp-r
(:float-e (- :par1 :exp-l (length :rr)))
(nconc :rr :exp-r)))
(explode :f))))))
(de :float-exp (:t-exp)
(newr :exp-r (or :par7 #/e))
(newr :exp-r (if (>= :t-exp 0) #/+ #/-))
(slet ((:nb-list (pname (abs :t-exp)))(:length (length :nb-list)))
(if (and :par5 :par3 (< :par3 :length))
(setq :exp-r (makelist :par1 :par5))
(setq :exp-r (nconc :exp-r
(if :par3 (makelist (- :par3 :length) #/0))
:nb-list)))))
(de :float-e (:r-length)
(ifn :par2 (setq :par2 (- :r-length 2)))
(cond
((zerop :par4)
(setq :par2 (max :par2 0))
(let ((:digits (:float-digits :par2)))
(:float-e-1 0 0 :par2)))
((> :par4 0)
(setq :par2 (max :par2 (1- :par4)))
(let ((:digits (:float-digits (1+ :par2))))
(:float-e-1 :par4 0 (- :par2 -1 :par4))))
(t (setq :par2 (max :par2 (- 1 :par4)))
(let ((:digits (:float-digits (+ :par2 :par4))))
(:float-e-1 0 (abs :par4) (+ :par2 :par4))))))
(de :float-e-1 (:before :zero :after)
(repeat :before (newr :rr (nextl :digits)))
(if (and (zerop :before) (<> :r-length (+ 1 :zero :after)))
(newr :rr #/0))
(newr :rr #/.)
(if (> :zero 0) (setq :rr (nconc :rr (makelist :zero #/0))))
(repeat :after (newr :rr (nextl :digits))))
(de :format-g-float (:arg)
(ifn (numberp :arg)
(let ((:par1 :par1)(:par2 :par6))
(:format-decimal :arg))
(ifn (floatp :arg) (setq :arg (float :arg)))
(slet ((:n (if (zerop :arg) 0 (1+ (floor (log10 (abs :arg))))))
(:ee (ifn :par3 4 (+ :par3 2)))
(:ww (ifn :par1 () (- :par1 :ee)))
(:q (- :ww 2))
(:d (if :par2 :par2 (max :q (min :n 7))))
(:dd (- :d :n)))
(if (or (< :dd 0) (> :dd :d))
(:format-e-float :arg)
(let ((:par1 :ww)(:par2 :dd)(:par3)(:par4 :par5)(:par5 :par6))
(:format-f-float :arg))
(setq :r (nconc :r (makelist :ee #\sp)))))))
(de :format-nl ()
(ifn :par1 (setq :par1 1))
(setq :r (nconc :r (makelist :par1 #\lf))))
(de :format-eol ()
(cond
((and :at-sign :colon) (:error ':format-eol "pas @ et : ensemble"))
(:at-sign (setq :r (nconc1 :r #\lf))
(while (eq (typecn (car :f)) 'csep) (nextl :f)))
(:colon)
(t (while (eq (typecn (car :f)) 'csep) (nextl :f)))))
(de :format-tilde ()
(ifn :par1 (setq :par1 1))
(setq :r (nconc :r (makelist :par1 #/~))))
(de :format-tab ()
(let ((:back :r))
(while (memq #\lf :back) (setq :back (cdr (memq #\lf :back))))
(setq :back (length :back))
(ifn :par1 (setq :par1 1))
(ifn :par2 (setq :par2 1))
(let ((:n)(:base (if :at-sign 0 :par1))(:pos))
(if :at-sign
(setq :n :par1 :pos (+ :back :par1))
(if (< :back :par1)
(setq :n (- :par1 :back) :pos :par1)
(setq :n 0 :pos :back)))
(let ((:mod (modulo (- :pos :base) :par2)))
(ifn (zerop :mod)
(setq :n (+ :n (- :par2 :mod)))))
(setq :r (nconc :r (makelist :n #\sp))))))
(de :format-ignore ()
(ifn :par1 (setq :par1 (if :at-sign 0 1)))
(cond
((and :at-sign :colon) (:error ':format-ignore "pas @ et : ensemble"))
(:at-sign (setq :l (nthcdr :par1 :args)))
(:colon (let ((:l1 (length :args)) (:l2 (length :l)))
(setq :l (nthcdr (- :l1 :l2 :par1) :args))))
(t (setq :l (nthcdr :par1 :l)))))
(de :format-indirect ()
(slet ((:s (nextl :l))(:format (pname :s)))
(ifn (stringp :s) (:error ':format-indirect :s))
(tag hat
(if :at-sign (:format-ind-at) (:format-ind-list (nextl :l))))))
(de :format-ind-at ()
(let ((:f :format)) (:format-ind-at1 (nextl :f))))
(de :format-ind-at1 (:char)
(cond
((null :char))
((eq :char #/~)
(let ((:par1)(:par2)(:par3)(:par4)
(:par5)(:par6)(:par7)
(:at-sign)(:colon)(:par-n 1))
(:tilde-decode) (:format-ind-at1 (nextl :f))))
(t (newr :r :char) (:format-ind-at1 (nextl :f)))))
(de :format-ind-list (:args)
(ifn (listp :args) (:error ':format-indirect :args))
(let ((:f :format)(:l :args))
(tag format (tag hat (:format1)))))
(de :format-cond ()
(cond
((and :at-sign :colon) (:error ':format-cond "pas @ et : ensemble"))
(:at-sign (setq :par1 (car :l))
(cond
((not :par1) (:search-cond (nextl :f) 0 ()) (nextl :l))
(t (slet ((:format (:search-cond (nextl :f) 0 ()))(:f :format))
(tag format (:format1))))))
(:colon (nextl :l :par1)
(slet ((:format (:search-cond (nextl :f) (if :par1 1 0) ()))
(:f :format))
(tag format (:format1))))
(t (ifn :par1 (nextl :l :par1))
(slet ((:format (:search-cond (nextl :f) :par1 ()))(:f :format))
(tag format (:format1))))))
(de :search-cond (:c :n :ff)
(ifn :c (:error ':format-cond :f))
(if (zerop :n)
(selectq :c
(#/~ (let ((:cc (nextl :f)))
(selectq :cc
(() (:error ':format-cond :f))
(#/] :ff)
(#/; (prog1 :ff (:search-cond (nextl :f) -1 ())))
(#/: (if (eq (car :f) #/;)
(prog1 :ff (:search-cond (nextl :f) -1 ()))
(:search-cond (nextl :f) :n
(nconc :ff (list :c :cc)))))
(t (:search-cond (nextl :f) :n
(nconc :ff (list :c :cc)))))))
(t (:search-cond (nextl :f) :n (nconc1 :ff :c))))
(ifn (eq :c #/~) (:search-cond (nextl :f) :n ())
(nextl :f :c)
(selectq :c
(() (:error ':format-cond :f))
(#/] ())
(#/; (:search-cond (nextl :f) (1- :n) ()))
(#/: (nextl :f :c)
(:search-cond (nextl :f) (if (eq :c #/;) 0 :n) ()))
(t (:search-cond (nextl :f) :n ()))))))
(de :format-iter (:iter-colon)
(let ((:iter-n (if :par1 :par1 -1))
(:iter-n-first)
(:format (:search-iter (nextl :f) () ()))
(:f))
(unless (zerop :iter-n)
(unless :format
(setq :format (nextl :l))
(ifn (stringp :format) (:error ':format-iter :format))
(setq :format (pname :format)))
(setq :iter-n-first :iter-n :f :format)
(cond
((and :at-sign :colon) (tag colon-hat (:iter-colon :l)))
(:at-sign (tag hat (:iter)))
(:colon (tag colon-hat (:iter-colon (nextl :l))))
(t (let ((:args (car :l))(:l (nextl :l)))
(tag hat (:iter))))))))
(de :search-iter (:c :ff :cc)
(cond
((null :c)
(:error ':format-iter
#- #:system:foreign-language "pas referme"
#+ #:system:foreign-language "not closed"))
((eq :c #/~) (nextl :f :cc)
(cond
((eq :cc #/}) :ff)
((and (eq :cc #/:) (eq (car :f) #/}))
(setq :iter-colon t) (nextl :f) :ff)
(t (:search-iter (nextl :f) (nconc :ff (list :c :cc)) ()))))
(t (:search-iter (nextl :f) (nconc1 :ff :c) ()))))
(de :iter ()
(if (null :format) (exit hat))
(if (and (null :l) (not :iter-colon)) (exit hat))
(:iter-loop (nextl :f)))
(de :iter-loop (:char)
(cond
((zerop :iter-n) (exit hat))
((null :char)
(if (null :l) (exit hat))
(decr :iter-n) (setq :f :format) (:iter-loop (nextl :f)))
((eq :char #/~)
(let ((:par1)(:par2)(:par3)(:par4)(:par5)(:par6)(:par7)
(:at-sign)(:colon)(:par-n 1))
(:tilde-decode)))
(t (newr :r :char)))
(:iter-loop (nextl :f)))
(de :iter-colon (:sub-args)
(if (null :format) (exit colon-hat))
(:iter-colon-loop (car :sub-args) (nextl :sub-args)))
(de :iter-colon-loop (:args :l)
(if (and (null :l) (null :sub-args)
(not (and (= :iter-n :iter-n-first) :iter-colon)))
(exit colon-hat))
(if (zerop :iter-n) (exit colon-hat))
(decr :iter-n)
(tag hat (tag format (let ((:f :format)) (:format1))))
(:iter-colon-loop (car :sub-args) (nextl :sub-args)))
(de :format-hat ()
(if (null :par1) (setq :par1 (length :l)))
(if (or (and (null :par2) (null :par3) (zerop :par1))
(and :par2 (null :par3) (= :par1 :par2))
(and :par2 :par3 (or (<= :par1 :par2) (<= :par2 :par3))))
(if :colon (exit colon-hat) (exit hat))))
(de :read-n (:l)
(let ((:c (car :f)))
(cond
((digitp :c) (nextl :f) (:read-n (nconc1 :l :c)))
(t (implode :l)))))
(de :string (:l)
(slet ((:n (length :l))(:s (makestring :n 32))(:l (nreverse :l)))
(while (> :n 0) (decr :n) (chrset :n :s (nextl :l)))
:s))
(de :error (a b) (error "Format" a b))