;;; .EnTete "Le-Lisp (c) version 15.2" " " "Fichier de test de setf"
;;; .EnPied "testsetf.ll" "%" " "
;;;
;;; .SuperTitre "Fichier de test de setf"
;;;
;;; .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: testsetf.ll,v 1.1 88/12/06 14:18:17 kuczynsk Exp $"

(unless (>= (version) 15.2)
        (error 'load 'erricf 'testsetf))
 
(unless (featurep 'testcomm)
        (libload testcomm))

(gc)
(testfn ())


        (test-serie "[Setf d'origine]" ())

(setf l '(1 2 3))                          (1 2 3)
l                                          (1 2 3)
(setf (car l) '(0))                        (0)
l                                          ((0) 2 3)
(setf (cdr l) '(1 2))                      (1 2)
l                                          ((0) 1 2)
(progn (setf (nth 1 l) 11) l)              ((0) 11 2)
(progn (setf (caar l) 100) l)              ((100) 11 2)

(setf v (vector 1 2 3))                    #[1 2 3]
(setf (vref v 1) 22)                       22
v                                          #[1 22 3]

(setf (get 'foo 'ind) 33)                  33
(get 'foo 'ind)                            33
(setf (getprop 'foo 'ind) 33)              33
(getprop 'foo 'ind)                        33
(setf foo 99)                              99
foo                                        99
;;; Setf de valfn ?

        (test-serie "[Setf sur Defstruct]" ())

(defstruct tsetf x y)                          tsetf
(setq tsetf (#:tsetf:make))                    #:tsetf:#[() ()]
(#:tsetf:x tsetf)                              ()
(setf (#:tsetf:x tsetf) 'val)                  val
(#:tsetf:x tsetf)                              val
(#:tsetf:y tsetf)                              ()
(setf (#:tsetf:y tsetf) 'val)                  val
(#:tsetf:y tsetf)                              val
tsetf                                          #:tsetf:#[val val]

        (test-serie "[Setf sur des Macros]" ())

(defmacro kar (x) `(car ,x))               kar
(setf l '(0 3 4))                          (0 3 4)
(setf (kar l) '(1 2))                      (1 2)
l                                          ((1 2) 3 4)
(defmacro quar (x) `(kar ,x))              quar
(progn (setf (quar l) '(0 1 2)) l)         ((0 1 2) 3 4)
(progn (setf (kar (car l))  100) l)        ((100 1 2) 3 4)

        (test-serie "[Setf & Defsetf]" ())

;;; le cas simple
(defsetf kkar (x) (y) `(progn (rplaca ,x ,y) ,y)) kkar
(setq l '(1 2 3))                                 (1 2 3)
(setf (kkar l) 11)                                11
l                                                 (11 2 3)

;This Example is very weird.  It is not a real setf.

;;; un cas + complique' qui ne fait rien mais...:
;;; pour verifier que chaque parametre n'est e'value' qu'une fois
(defsetf fuu (x) (y) `(list ,x ,x ,y))            fuu
(setq n 3)                                        3
(setf (fuu n) 55)                                 (3 3 55)
(setf (fuu (incr n)) 44)                          (4 4 44)
n                                                 4


        (test-serie "[Setf & Define-Setf-Method]" ())
(defmacro :values l `(list ,@l)))                 :values

(define-setf-method kdr (x)
  (let ((v2 (gensym)))
    (:values ()         ; temp. parametres 
	     ()         ; parametres
	     (list v2)  ; new value
	     `(rplacd ,x ,v2) ; update form
	     `(cdr ,x))))     ; access form
                                                  kdr
(setf l '(1 2 3))                                 (1 2 3)
(setf (kdr l) 2)                                  (1 . 2)

;;; plus complique': avec plusieurs parametres, chacun utilise'
;;; plusieurs fois.
(define-setf-method fii (x y)
  (let ((v1 (gensym))(v2 (gensym))(v3 (gensym)))
    (:values (list v1 v2)
	    (list x y)
	    (list v3)
	    `(progn (rplaca (cdr (setq res
				       (append ,v1
					       (cons ,v2
						     (cons ,v2 ,v1))))) ,v3)
		    ,v3)
	    `(cadr (append ,v1 ,v2 ,v1)))))
                                                  fii
(setq res ())                                     ()
(setf l '(1 2 3) nn 4)                            4
;;; le minimun qu'on puisse faire
(setf (fii l nn) 22)                              22
res                                               (1 22 3 4 4 1 2 3)
(setq l '(0))                                     (0)
(setf (fii l nn) 44)                              44
res                                               (0 44 4 0)
(setq l '(1 2) n 10)                              10

;;; pour verifier que chaque parametre n'est e'value' qu'une seule fois:
nn                                                4
l                                                 (1 2)
(setf (fii l (incr nn)) 22)                       22
nn                                                5
res                                               (1 22 5 5 1 2)

;;; idem avec le 1er parametre, mais avec la meme variable utilise'e
;;; pour les 2 parametres pour verifier l'ordre d'e'valuation droite->gauche
n                                                 10
l                                                 (1 2)
(setf (fii (rplaca l (incr n)) n) 22)             22
res                                               (11 22 11 11 11 2)
n                                                 11
l                                                 (11 2)

        (test-serie "[Define-Modify-Macro]" ())
(setq l '(1 2 3) n 1 m 1)                         1
(defun foo (x y) (cons y x))                      foo
(define-modify-macro setfoo (a) foo)              setfoo
(setfoo l 0)                                      (0 1 2 3)
(setfoo l (incr n))                               (2 0 1 2 3)
n                                                 2
(setfoo (nth 1 l) (incr n))                       (3 . 0)
l                                                 (2 (3 . 0) 1 2 3)
n                                                 3
(setfoo (nth (incr m) l) (incr n))                (4 . 1)
l                                                 (2 (3 . 0) (4 . 1) 2 3)
n                                                 4
m                                                 2

(test-serie "[Fin des Tests de SETF.]" ())