; .EnTete "Le-Lisp (c) version 15.2" " " "Les Structures"
; .EnPied "defstruct.ll" "G-%" " "
; .Annexe G "Les Structures"
; .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: defstruct.ll,v 4.3 88/11/19 17:06:45 nuyens Exp $"

; Un defstruct tre`s simple, tire' de celui d'Alcyone avec :
;   - l'utilisation des vecteurs type's
;   - fonction d'acce`s sous forme d'EXPR qui ne consent pas
;   - fonction de cre'ation : #:type:make
;   - compatibilite' d'utilisation avec Ceyx (Objval et TCONS libres)
;   - utilisation des P-listes des types.

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

; Tous les symboles pre'ce'de's de : seront cre'e's dans le package DEFSTRUCT

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

(add-feature 'defstruct)

(defvar #:system:defstruct-all-access-flag t)

; .Section "Le type STRUCTURE"

; La Pliste d'une structure contient, sous l'indicateur defstruct
; un CONS qui contient :
;   - le segment de valeur d'appel a` la fonction VECTOR
;     pour cre'er le segment de vecteur de ce type simple.
;   - la liste des noms des champs a` la de'finition (pour la
;     lecture et l'e'criture de la syntaxe #S(nom val .....) )
; P.S. les noms des champs he'rite's et leurs valeurs initiales ne sont
; pas sauvegarde's sur la P-liste.

(de structurep (x)
    (if (and (vectorp x)
             (getprop (typevector x) 'defstruct))
        t
        ()))

; .Section "La fonction de de'finition de structure"

(defmacro defstruct (name . lfield)
  ; pose de la valeur initiale () par de'faut
  (unless (variablep name)
          (error 'defstruct 'errnva name))
  (let ((name1 name)
        (index -1)
        (make (mapcar (lambda (x)
                              (cond ((symbolp x) ())
                                    ((or (atom x)
                                         (not (symbolp (car x))))
                                     (error 'defstruct 'errnaa x))
                                    (t (cadr x))))
                      lfield))
        (lfieldt (mapcar (lambda (x)
                                 (if (atom x) x (car x)))
                         lfield)))
       ; C'est ca qui sera sauve sur la plist.
       (setq lfield (cons make lfieldt))
       (until (or (eq (packagecell name1) '||)
                  (null (getprop (packagecell name1) 'defstruct)))
              (setq name1 (packagecell name1))
              (setq make (append (car (getprop name1 'defstruct)) make))
              (setq lfieldt (append (cdr (getprop name1 'defstruct))
                                    lfieldt)))
       `(exportable-definition  ',name 'structure
               (putprop ',name ',lfield 'defstruct)
               (de ,(symbol name 'make) ()
                    (let ((vector (vector ,@make)))
                         (typevector vector ',name)
                         vector))
              ,@(mapcan
                       (lambda (f)
                               (incr index)
                               (when (or #:system:defstruct-all-access-flag
                                         (memq f lfield))
                                 (setq f (symbol name f))
                                 `((de ,f &nobind
                                       (#:system:structaccess ',f ,index
                                        (arg 0) 
                                        (arg 1)
                                        (arg)))
				   (when (featurep 'setf) (defsetf ,f ,f))
				   (when (featurep 'compiler)
                                         (defmacro-open
					   ,f (struct . valeur)
					   (ifn valeur
						`(vref ,struct ,,index)
						`(vset ,struct 
						       ,,index
						       ,(car valeur))))
                                 ))))
                       lfieldt)
             )))


; .Section "La fonction de cre'ation ge'ne'rique"

(de new (type)
    (if (getprop type 'defstruct)
        (apply (symbol type 'make) ())
        (error 'new 'errstc type)))