;;AUTOLOAD: defstruct-soft
;;AUTODOC: defstruct-soft "simple structure package"
;;(defstruct-soft struct-name fields...)
;;
;;Common-lisp compatible Structure package
;;The functions are postfixed by -soft, but are actually obsolete versions
;;ofg the non -soft parts. requiring defstruct-soft will also define
;;defstruct to be defstruct-soft. Use them only in legacy code
;;    (defstruct XXX YYY)
;;Defines a structure XXX, whose instance can then be built by calls to:
;;    (make-XXX [:YYY value]...) 
;;Fast Accessor functions named XXX-YYY are also built, than can used to
;;    (XXX-YYY structure-instance)               ; get field contents or ()
;;    (XXX-YYY structure-instance value)         ; set field contents to value
;;This is a very convenient and efficient way to structure data, but does not
;;offer a lot of security
;;Fields can be keywords or atom (but are stored internally as atoms)
;;A Structure is a vector with first field the symbol '# and second
;;the name (atom) of the structure type, whose value is the structure 
;;definition (record with field names as returned by defstruct)
;;A field can be a symbol (default value is nil), or a pair 
;;(symbol default-value)
;;
;;Example
;;    (defstruct Record :name (age 0) adress) 
;;      ==> [# Record name age adress]
;;    (make-Record :name "foo") ==> [# Record foo () ()]
;;    (setq r (make-Record :name "foo" :adress "rtfm"))
;;    (Record-age r) ==> 0
;;    (Record-age r 23) ;; sets age field to 23
;;
;; Older versions used 'Structure instead of '#. This behavior can be emulated 
;; by doing (setq defstruct::tag 'Structure) before (re-)loading this package
;;
;; Note: this is the old implementation of defstruct
;;
;;SEE_ALSO: structp struct-get struct-put struct-send

(if (not (boundp 'vector)) (setq vector list))
;; this can be set to 'Structure for backcompat with old packages
;; before loading this file
(if (not (boundp 'defstruct::tag)) (setq defstruct::tag '#))
(if (not (boundp 'defstruct:-funcs)) (setq defstruct:-funcs t))

(defmacro defstruct (struct-name &rest fields &aux 
    (field-names (list))
    (field-decls (list))
  )
  (dolist (f fields)
    (lappend field-names (atom-of (if (typep f List) (get f 0 "nil") f)))
    (lappend field-decls (if (typep f List) 
	(list (atom-of (get f 0 "nil")) (getn f 1)) (atom-of f)
    ))
  )
  ;; make-foo
  `(progn
    (set (intern (+ "make-" ',struct-name))
      (if ',fields
	(lambda (&key ,@field-decls)
	  (vector ',defstruct::tag ',struct-name ,@field-names)
	)
	(lambda () (vector ',defstruct::tag ',struct-name))
    ))
    ;; fields: foo-bar
    (if defstruct:-funcs
      (with (n 1) (dolist (f ',field-names)
	  (set (intern (+ ',struct-name "-" f)) (incf n))
    )))
    ;; the struct itself for remainder
    (setq ,struct-name (+ (vector defstruct::tag ',struct-name) ',field-names))
  )
)
(setq defstruct-soft defstruct)

;;AUTOLOAD: defstruct-soft-extends
;;AUTODOC: defstruct-soft-extends "define a struct extending another one"
;; (defstruct-soft-extends struct-name parent-struct fields...)
;;
;; Just like defstruct but first fields are copied from the parent-struct
;; structure

(defmacro defstruct-extends (struct-name parent &rest fields)
  (if (not (structp (eval parent)))
    (error "parent struct %0 not a struct" parent))
  `(defstruct ,struct-name ,@(subseq (eval parent) 2) ,@fields)
)
(setq defstruct-soft-extends defstruct-extends)

;;AUTOLOAD: #
;;AUTODOC: # "raw structure constructor"
;;(# structure field-values...)
;;
;;Builds a structure (see defstruct-soft). This constructor is a raw one, 
;;faster than make-Record (~ 5 times) but without any check of arguments, 
;;which must be given in totality and in the right order.
;;Example:
;;    if    (defstruct Record name age adress)
;;    then, (make-Record :name "foo" :age 42 :adress "rtfm")
;;    is equivalent to (# Record "foo" 42 "rtfm")

(set defstruct::tag 
  (lambdaq (&whole defstruct::whole) (Vector defstruct::whole))
)

;;AUTOLOAD: structp-soft
;;AUTODOC: structp -soft"tests if an object is a structure"
;;(structp-soft object [structure])
;;
;;returns non-nil when object is exactly of structure type structure, 
;;which can be the structure or the name (symbol)
;;If no structure is given or (), tests that object is a valid structure
;;e.g.:
;;    (defstruct Record name age adress)
;;    (structp-soft obj 'Record)
;;    (structp-soft obj Record)

(defun structp-soft (obj &optional struct)
  (or    
    (and struct 
      (typep obj Vector)
      (eq (getn obj 0) defstruct::tag)
      (or 
	(and (typep struct Atom)
	  (eq (getn obj 1) struct)
	)
	(and (typep struct Vector)
	  (eq (getn obj 1) (getn struct 1))
    )))
    (and (typep obj Vector)
      (eq (getn obj 0) defstruct::tag)
      (typep (getn obj 1) Atom)
)))
(setq structp structp-soft)

;; backcompat for the following functions
(if (not (boundp 'atom-of)) 
  (defun atom-of (obj)
    (if (typep obj Keyword) (intern (subseq obj 1)) (Atom obj))
))

(if (not (boundp 'defstruct:slot))
  (defun defstruct:slot (obj sel)
    (and (typep object Vector)
      (eq (getn object 0) defstruct::tag)
      (seekq (eval (getn object 1)) (atom-of selector))
)))

;; a print method to be used by the kernel one day?
;;AUTOLOAD: struct-print-soft
;;AUTODOC: struct-print-soft "prints verbosely a defstruct structure"
;; (struct-print object [stream])
;;
;; Prints a structure instance verbosely (with field names as keywords) 
;; on stdout or stream
;; See struct-pp for a prettyier output.

(defun struct-print-soft (obj &optional (stream *standard-output*))
  (if (and (typep obj Vector)
      (eq (getn obj 0) defstruct::tag)) (progn
      (write-string "[" stream)
      (write-string defstruct::tag stream)
      (write-string " " stream)
      (write (getn obj 1) stream)
      (dolist (elt (subseq (eval (getn obj 1)) 2))
	(write-string " :" stream)
	(write elt stream)
	(write-string " " stream)
	(write (struct-get obj elt) stream)
      )
      (write-string "]" stream)
    )
    (error "Not a defstruct structure: %0" obj)
))
(setq struct-print struct-print-soft)

;;AUTOLOAD: struct-pp-soft
;;AUTODOC: struct-pp-soft "pretty-prints verbosely a defstruct structure"
;; (struct-pp -softobject [stream])
;;
;; Prints a structure instance verbosely (with field names, one per line)
;; on stdout or stream
;; See struct-print for a simpler output.

(defun struct-pp-soft (obj &optional (stream *standard-output*))
  (if (and (typep obj Vector)
      (eq (getn obj 0) defstruct::tag)) (progn
      (print-format stream "[%1 %0\n" (getn obj 1) defstruct::tag)
      (dolist (elt (subseq (eval (getn obj 1)) 2))
	(print-format stream "  :%0 %r1\n" elt (struct-get obj elt))
      )
      (print-format stream "]\n")
    )
    (error "Not a defstruct structure: %0" obj)
))
(setq struct-pp struct-pp-soft)

;;===========================================================================
;; Small (and Slow) OO layer

;; Common error
(setq struct-send:error "defstruct: not such field %0 in object %1")

;;AUTOLOAD: struct-send
;AUTODOC: struct-send "sends a message to a structure"
;; (struct-send selector object arguments...)
;;
;; If the field name "selector" (can be an atom or a keyword) exists, it is
;; applied to the object and the arguments, otherwise the error
;; struct-send:error is triggered.
;; Thus the value of the selector must be a function with N+1 arguments, (if
;; there are Nth arguments to struct-send), the first one being the structure
;; object itself
;;SEE_ALSO: struct-get struct-put defstruct

(defun struct-send (selector &rest args &aux
    (object (0 args))
    (slot (defstruct:slot object selector))
  )
  (if slot (apply (slot object) args)
    (error struct-send:error selector object 'send args)
))


;;AUTOLOAD: struct-get
;AUTODOC: struct-get "gets a field of a structure"
;; (struct-get object selector [default_value])
;;
;; If the field name "selector" (can be an atom or a keyword) exists, its
;; value is returned, else the struct-send:error is triggered, unless
;; default_value is provided, in which case default_value is evaluated and 
;; returned.
;; Being dynamic, struct-get is ~20 times slower than a direct access
;; e.g:
;;    (struct-get customer :ticket '(create-new-customer-ticket))
;;SEE_ALSO: struct-send struct-put defstruct

(defun struct-get (object selector &optional 
    (def '(error struct-send:error selector object 'get def))
    &aux
    (slot (defstruct:slot object selector))
  )
  (if slot (slot object)
    (eval def)
))

;;AUTOLOAD: struct-put
;AUTODOC: struct-put "sets a field of a structure"
;; (struct-get object selector value)
;;
;; If the field name "selector" (can be an atom or a keyword) exists, its
;; value is set, else the struct-send:error is triggered.
;; e.g:
;;    (struct-put customer :ticket 47)
;;SEE_ALSO: struct-send struct-get defstruct


(defun struct-put (object selector value &aux
    (slot (defstruct:slot object selector))
  )
  (if slot (slot object value)
    (error struct-send:error selector object 'put value)
))

;AUTODOC: struct-make "creates an instance of a structure"
;; (struct-make structure args...)
;;
;; Equivalent to (make-XXX args...) for a structure XXX

(defun struct-make (obj &rest args)
  (if (and (typep obj Vector)
      (eq (getn obj 0) defstruct::tag)) (progn
      (apply (eval (intern (+ "make-" (get obj 1 "")))) args)
    )
    (error "Not a defstruct structure: %0" obj)
))
