;;AUTOLOAD: defstruct
;;AUTODOC: defstruct "simple structure package"
;;(defstruct struct-name fields...)
;;
;;Common-lisp compatible Structure package
;;    (defstruct XXX YYY)
;;Defines a structure XXX, whose instance can then be built by calls to:
;;    (make-XXX [:YYY value]...) 
;;Or better, with the .YYY notation (see examples)
;;    
;;This is a very convenient and efficient way to structure data.
;;Fields can be keywords or atoms (but are stored internally as atoms)
;;A Structure is an object of type Structure, a vector with first field the
;;symbol '# and second the name (atom) of the structure type, whose value 
;;is the structure definition (a record with field names as returned by 
;;defstruct)
;;
;;Executing a structure creates an instance of the structure with all fields 
;;set to (). Executing an instances uses the values of the fields as default 
;;values, which are copied in slots, or evaluated in prefixed by ' or comma (,)
;;Note: for backwards compatibility with an old implementation, 
;;
;;A field can be a symbol (default value is nil), or a pair 
;;(symbol default-value), in which case an instance with all the default values
;;is created and set to the name make-XXX
;;
;;Example
;;    (defstruct Record :name (age 0) adress (id (incf *id*)))
;;      ==> [# Record name age adress id]
;;    make-Record 
;;      ==> [# Record () 0 () ,(incf *id*)]
;;    (setq *id* 0)                 ; we initialise the counter
;;    (make-Record :name "foo") ==> [# Record foo 0 () 1]
;;    (Record) ==> [# Record () () () ()]
;;    (setq father (make-Record :name "Colas Nahaboo" 
;;                              :age 40 :adress "France"))
;;      ==> [# Record "Colas Nahaboo" 40 "France" 2]
;;    (setq daughter (father :name "Bilkis Nahaboo" :age 12))
;;      ==> [# Record "Bilkis Nahaboo" 12 "France" 2]  ; warning: id is cloned
;;    father.age ==> 40
;;    (setq father.age 41) ;; sets age field to 41
;;
;;Note that field values can also be functions, and thus be executed, giving
;;some basic OO capabilities. We could put the display "method" as a lambda
;;as value of a field 'display in the structure, and then displaying a Record
;;would be something like (father.display), the lambda being able to access the
;;instance as (eval whole.0.object), if is declared as 
;;(lambda (args... &whole whole ...) ...)
;;
;; Note: for backwards compatibility, 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

(if (not (boundp 'vector)) (setq vector list))
;; this can be set to 'Structure for backcompat with old packages
;; before loading this file

(unless (and (boundp 'Structure) (typep Structure Type))
  ;; well, the C code does not provide structures, use old package
  (load "defstruct-soft")
  (throw 'ERROR)			;and stop reading this file
)

(defmacro defstruct (struct-name &rest fields &aux 
    (field-names (vector))
    (field-names-with-default (list))
    field
  )
  (dolist (f fields)
    (lappend field-names (atom-of (if (typep f List) (get f 0 "nil") f)))
    (when (typep f List) 
      (setq field (0 f))
      (if (typep field Keyword) ()
	(typep field Atom) (setq field (intern (+ ":" field)))
	t (error 'Errors:BadArgType field (+ 1 (seek fields f)) "Keyword")
      )
      (lappend field-names-with-default field)
      ;;for default values, emulate old behavior: expr are evaluated at
      ;;instanciation time (the current built-in default being not to evaluate)
      (lappend field-names-with-default 
	(if (and (typep (1 f) QuotedExpr) (= (intern "'") (0 (1 f)))) ;'-form
	  (1 (1 f))			;change 'a in a
	  ;; non-evualuable types are stored as is
	  (or 
	    (and (typep (1 f) String) (not (typep (1 f) Symbol)))
	    (typep (1 f) Number)
	    (typep (1 f) Vector)
	    (typep (1 f) Function)
	  )
	  (1 f)
	  ;;else force eval via ',a
	  (QuotedExpr (list (intern "'") 
	      (QuotedExpr (list (intern ",") (1 f)))))
      ))
  ))
  `(progn
    ;; define the Structure itself
    (setq ,struct-name (apply structure (+ [# ,struct-name] 
	  ,field-names))
    )
    ;; define the init instance for make-foo
    ,(if field-names-with-default 
      `(setq ,(intern (+ "make-" struct-name)) 
	(,struct-name ,@field-names-with-default)
      )
      `(setq ,(intern (+ "make-" struct-name)) ,struct-name)
    )
    ,struct-name
  )
)

;;AUTOLOAD: structp
;;AUTODOC: structp "tests if an object is a structure"
;;(structp 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 obj 'Record)
;;    (structp obj Record)

(defun structp (obj &optional struct)
  (if (typep struct Structure) (setq struct (1 struct)))
  (and (typep obj Structure)
    (or (not struct)
      (= (1 obj) struct)
)))

;; a print method to be used by the kernel one day?
;;AUTOLOAD: struct-print
;;AUTODOC: struct-print "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 (obj &optional (stream *standard-output*))
  (if (typep obj Structure) (progn
      (write-string "[" stream)
      (write-string '# 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 (get obj elt) stream)
      )
      (write-string "]" stream)
    )
    (error "Not a defstruct structure: %0" obj)
))

;;AUTOLOAD: struct-pp
;;AUTODOC: struct-pp "pretty-prints verbosely a defstruct structure"
;; (struct-pp object [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 (obj &optional (stream *standard-output*))
  (if (typep obj Structure) (progn
      (print-format stream "[%1 %0\n" (getn obj 1) '#)
      (dolist (elt (subseq (eval (getn obj 1)) 2))
	(print-format stream "  :%0 %r1\n" elt (get obj elt))
      )
      (print-format stream "]\n")
    )
    (error "Not a defstruct structure: %0" obj)
))

;; For backcompat, we define on demand the structure-field accessor functions
;; If an error is triggered because a function foo-bar is not found, we look 
;; if the structure foo with field bar has been defined...
;; The tricky part is of course to work as well on fields 
;; a-field-name-with-dases of structures Name-with-dashes

(when (not (boundp 'defstruct:lazy-accessors))
  (require 'doregexp)
  (insert *error-correctors* 0 'defstruct:lazy-accessors)
)
(setq defstruct:lazy-accessors-re (regcomp "-"))

(defun defstruct:lazy-accessors (errorcode &rest data &aux
    (variable (0 data))		;the undefined symbol triggering error
    (result :nil)
  )
  (if (and 
      (or (= errorcode 'Errors:UndefinedVariable)
	(= errorcode 'Errors:UndefinedFunction)
      )
      (typep variable Atom)
      (regexec defstruct:lazy-accessors-re variable)
    )
    (with (offset () varoff 0 re (regcomp "^([^-]+)-(.+)$"))
      (while (regexec re variable varoff)
	(with (class (intern (substring-ptr variable 0 (1 (get re 1))))
	    field (intern (regsub re 2))
	  )
	  (if (and (boundp class)
	      (typep (eval class) Structure)
	      (= (1 (eval class)) class)
	    )				; first part is a struct
	    (if (setq offset (structure-field (eval class) field))
	      (setq result (set variable offset))
	      
	)))
	(setq varoff (0 (get re 2)))
      )
  ))
  result
)

;;AUTOLOAD: struct-make
;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 (typep struct Structure) 
    (apply (eval (intern (+ "make-" (1 obj)))) args)
    (error "Not a defstruct structure: %0" obj)
))
